urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-25 04:52:06 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'khrc' of https://github.com/urbit/urbit into siprel/sigwinch

Browse Source
This commit is contained in:
~siprel 2020-06-12 18:27:25 +00:00
commit 57ef4254e4
119 changed files with 13158 additions and 9719 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/solid.pill
View File

@ -1,3 +1,3 @@
version https://git-lfs.github.com/spec/v1
oid sha256:46d79f0b3dc1c4ff5f7ca56f1601a26a0fbc67540ab0ebcc672dc282fe8bbe74
size 13825786
oid sha256:ab1e700ae005ffc73f14deaf1ae4263d378032499c9d63ec77a28187f08a4989
size 13709878

7
nix/cachix/tests.nix Normal file
View File

@ -0,0 +1,7 @@
let
ops = import ../ops/default.nix {};
in
{
results = ops.test;
fakebus = ops.bus;
}

2
nix/deps-env.nix
View File

@ -10,7 +10,7 @@ let
libs =
with pkgs;
[ openssl zlib curl gmp scrypt libsigsegv ncurses openssl zlib lmdb ];
[ openssl curl gmp scrypt libsigsegv openssl zlib lmdb ];
osx =
with pkgs;

3
nix/ops/boot-ship.nix
View File

@ -10,9 +10,10 @@ let
tlon = import ../pkgs { inherit pkgs; };
arvo = tlon.arvo;
urbit = tlon.urbit;
herb = tlon.herb;
in
import ./fakeship {
inherit pkgs tlon deps arvo pill ship debug;
inherit pkgs arvo pill ship urbit herb;
}

8
nix/ops/default.nix
View File

@ -31,16 +31,16 @@ let
ship = "zod";
};
in
rec {
bus = import ./fakeship {
inherit pkgs herb urbit arvo;
pill = bootsolid;
ship = "bus";
};
in
rec {
test = import ./test {
inherit pkgs herb urbit;
ship = bus;

2
nix/ops/fakeship/builder.sh
View File

@ -13,7 +13,7 @@ check () {
[ 3 -eq "$(herb $out -d 3)" ]
}
if check
if check && sleep 10 && check
then
echo "Boot success." >&2
herb $out -p hood -d '+hood/exit' || true

2
nix/ops/test/builder.sh
View File

@ -12,7 +12,7 @@ tailproc=$!
shutdown () {
if [ -e ./ship/.vere.lock ]
then kill $(< ./ship/.vere.lock) || true;
then kill -9 $(< ./ship/.vere.lock) || true;
fi
kill "$tailproc" || true;

2
nix/pkgs/urbit/default.nix
View File

@ -18,7 +18,7 @@ let
deps =
with pkgs;
[ curl gmp libsigsegv ncurses openssl zlib lmdb ];
[ curl gmp libsigsegv openssl zlib lmdb ];
vendor =
[ argon2 softfloat3 ed25519 ent ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 sni ivory-header ca-header ];

3
nix/pkgs/urbit/release.nix
View File

@ -12,7 +12,7 @@ let
crossdeps =
with env;
[ curl libgmp libsigsegv ncurses openssl zlib lmdb ];
[ curl libgmp libsigsegv openssl zlib lmdb ];
vendor =
with deps;
@ -27,7 +27,6 @@ env.make_derivation {
MEMORY_DEBUG = debug;
CPU_DEBUG = debug;
EVENT_TIME_DEBUG = false;
NCURSES = env.ncurses;
name = "${name}-${env_name}";
exename = name;

1
nix/pkgs/urbit/release.sh
View File

@ -17,6 +17,5 @@ bash ./configure
make build/urbit build/urbit-worker -j8
mkdir -p $out/bin
cp -r $NCURSES/share/terminfo $out/bin/$exename-terminfo
cp ./build/urbit $out/bin/$exename
cp ./build/urbit-worker $out/bin/$exename-worker

2
nix/release.nix
View File

@ -33,7 +33,7 @@ let
builds-for-platform = plat:
plat.deps // {
inherit (plat.env) curl libgmp libsigsegv ncurses openssl zlib lmdb;
inherit (plat.env) curl libgmp libsigsegv openssl zlib lmdb;
inherit (plat.env) cmake_toolchain;
ent = ent plat;
ge-additions = ge-additions plat;

30
pkg/arvo/gen/solid.hoon
View File

@ -69,13 +69,37 @@
|= [ovo=ovum ken=*]
[~ (slum ken [now ovo])]
::
:: our boot-ova is a list containing one massive formula:
:: boot-one: lifecycle formula (from +brass)
::
=/ boot-one
=> [boot-formula=** full-sequence=**]
!= =+ [state-gate main-sequence]=.*(full-sequence boot-formula)
|-
?@ main-sequence
state-gate
%= $
main-sequence +.main-sequence
state-gate .*(state-gate [%9 2 %10 [6 %1 -.main-sequence] %0 1])
==
::
:: kernel-formula
::
:: We evaluate :arvo-formula (for jet registration),
:: then ignore the result and produce :installed
:: then ignore the result and produce .installed
::
=/ kernel-formula
[%7 arvo-formula %1 installed]
::
:: boot-two: startup formula
::
=/ boot-two
=> [kernel-formula=** main-sequence=**]
!= [.*(0 kernel-formula) main-sequence]
::
:: boot-ova
::
=/ boot-ova=(list)
[[%7 arvo-formula %1 installed] ~]
[boot-one boot-two kernel-formula ~]
::
:: a pill is a 3-tuple of event-lists: [boot kernel userspace]
::

1
pkg/hs/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
stack.yaml.lock

2
pkg/hs/proto/package.yaml
View File

@ -19,7 +19,7 @@ dependencies:
- transformers
- transformers-compat
- unordered-containers
- urbit-king
- urbit-noun
default-extensions:
- ApplicativeDo

3
pkg/hs/racquire/.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work
*.cabal
test/gold/*.writ

21
pkg/hs/racquire/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

0
pkg/hs/urbit-king/lib/Data/RAcquire.hs → pkg/hs/racquire/lib/Data/RAcquire.hs
View File

66
pkg/hs/racquire/package.yaml Normal file
View File

@ -0,0 +1,66 @@
name: racquire
version: 0.10.4
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- mtl
- unliftio-core
- resourcet
- exceptions
- rio
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

4
pkg/hs/stack.yaml
View File

@ -3,11 +3,15 @@ resolver: lts-14.21
packages:
- lmdb-static
- proto
- racquire
- terminal-progress-bar
- urbit-atom
- urbit-azimuth
- urbit-eventlog-lmdb
- urbit-king
- urbit-termsize
- urbit-noun
- urbit-noun-core
extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38

3
pkg/hs/urbit-eventlog-lmdb/.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work
*.cabal
test/gold/*.writ

21
pkg/hs/urbit-eventlog-lmdb/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

137
pkg/hs/urbit-king/lib/Urbit/Vere/Log.hs → pkg/hs/urbit-eventlog-lmdb/lib/Urbit/EventLog/LMDB.hs
View File

@ -4,27 +4,51 @@
TODO Effects storage logic is messy.
-}
module Urbit.Vere.Log ( EventLog, identity, nextEv, lastEv
, new, existing
, streamEvents, appendEvents, trimEvents
, streamEffectsRows, writeEffectsRow
) where
module Urbit.EventLog.LMDB
( LogIdentity(..)
, EventLog
, identity
, nextEv
, lastEv
, new
, existing
, streamEvents
, appendEvents
, trimEvents
, streamEffectsRows
, writeEffectsRow
)
where
import Urbit.Prelude hiding (init)
import ClassyPrelude
import Data.Conduit
import Data.RAcquire
import Database.LMDB.Raw
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Urbit.Vere.Pier.Types
import Foreign.Storable (peek, poke, sizeOf)
import Data.Conduit (ConduitT, yield)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (peek, poke, sizeOf)
import RIO (HasLogFunc, RIO, display, logDebug, runRIO)
import Urbit.Noun (DecodeErr, Noun, Ship)
import Urbit.Noun (deriveNoun, fromNounExn, toNoun)
import Urbit.Noun (cueBS, jamBS)
import qualified Data.ByteString.Unsafe as BU
import qualified Data.Vector as V
-- Public Types ----------------------------------------------------------------
data LogIdentity = LogIdentity
{ who :: Ship
, isFake :: Bool
, lifecycleLen :: Word
} deriving (Eq, Ord, Show)
deriveNoun ''LogIdentity
-- Types -----------------------------------------------------------------------
type Env = MDB_env
@ -34,29 +58,29 @@ type Dbi = MDB_dbi
type Cur = MDB_cursor
data EventLog = EventLog
{ env :: Env
, _metaTbl :: Dbi
, eventsTbl :: Dbi
, effectsTbl :: Dbi
, identity :: LogIdentity
, numEvents :: IORef EventId
}
{ env :: Env
, _metaTbl :: Dbi
, eventsTbl :: Dbi
, effectsTbl :: Dbi
, identity :: LogIdentity
, numEvents :: TVar Word64
}
nextEv :: EventLog -> RIO e EventId
nextEv = fmap succ . readIORef . numEvents
nextEv :: EventLog -> STM Word64
nextEv = fmap (+1) . lastEv
lastEv :: EventLog -> RIO e EventId
lastEv = readIORef . numEvents
lastEv :: EventLog -> STM Word64
lastEv = readTVar . numEvents
data EventLogExn
= NoLogIdentity
| MissingEvent EventId
| BadNounInLogIdentity ByteString DecodeErr ByteString
| BadKeyInEventLog
| BadWriteLogIdentity LogIdentity
| BadWriteEvent EventId
| BadWriteEffect EventId
deriving Show
= NoLogIdentity
| MissingEvent Word64
| BadNounInLogIdentity ByteString DecodeErr ByteString
| BadKeyInEventLog
| BadWriteLogIdentity LogIdentity
| BadWriteEvent Word64
| BadWriteEffect Word64
deriving Show
-- Instances -------------------------------------------------------------------
@ -64,6 +88,12 @@ data EventLogExn
instance Exception EventLogExn where
-- Utils -----------------------------------------------------------------------
io :: MonadIO m => IO a -> m a
io = liftIO
-- Open/Close an Event Log -----------------------------------------------------
rawOpen :: MonadIO m => FilePath -> m Env
@ -82,7 +112,7 @@ create dir id = do
(m, e, f) <- createTables env
clearEvents env e
writeIdent env m id
EventLog env m e f id <$> newIORef 0
EventLog env m e f id <$> newTVarIO 0
where
createTables env =
rwith (writeTxn env) $ \txn -> io $
@ -98,7 +128,7 @@ open dir = do
id <- getIdent env m
logDebug $ display (pack @Text $ "Log Identity: " <> show id)
numEvs <- getNumEvents env e
EventLog env m e f id <$> newIORef numEvs
EventLog env m e f id <$> newTVarIO numEvs
where
openTables env =
rwith (writeTxn env) $ \txn -> io $
@ -227,10 +257,10 @@ clearEvents env eventsTbl =
appendEvents :: EventLog -> Vector ByteString -> RIO e ()
appendEvents log !events = do
numEvs <- readIORef (numEvents log)
numEvs <- atomically $ readTVar (numEvents log)
next <- pure (numEvs + 1)
doAppend $ zip [next..] $ toList events
writeIORef (numEvents log) (numEvs + word (length events))
atomically $ writeTVar (numEvents log) (numEvs + word (length events))
where
flags = compileWriteFlags [MDB_NOOVERWRITE]
doAppend = \kvs ->
@ -240,21 +270,20 @@ appendEvents log !events = do
True -> pure ()
False -> throwIO (BadWriteEvent k)
writeEffectsRow :: EventLog -> EventId -> ByteString -> RIO e ()
writeEffectsRow log k v = do
rwith (writeTxn $ env log) $ \txn ->
putBytes flags txn (effectsTbl log) k v >>= \case
True -> pure ()
False -> throwIO (BadWriteEffect k)
where
flags = compileWriteFlags []
writeEffectsRow :: MonadIO m => EventLog -> Word64 -> ByteString -> m ()
writeEffectsRow log k v = io $ runRIO () $ do
let flags = compileWriteFlags []
rwith (writeTxn $ env log) $ \txn ->
putBytes flags txn (effectsTbl log) k v >>= \case
True -> pure ()
False -> throwIO (BadWriteEffect k)
-- Read Events -----------------------------------------------------------------
trimEvents :: HasLogFunc e => EventLog -> Word64 -> RIO e ()
trimEvents log start = do
last <- lastEv log
last <- atomically (lastEv log)
rwith (writeTxn $ env log) $ \txn ->
for_ [start..last] $ \eId ->
withWordPtr eId $ \pKey -> do
@ -262,23 +291,21 @@ trimEvents log start = do
found <- io $ mdb_del txn (eventsTbl log) key Nothing
unless found $
throwIO (MissingEvent eId)
writeIORef (numEvents log) (pred start)
atomically $ writeTVar (numEvents log) (pred start)
streamEvents :: HasLogFunc e
=> EventLog -> Word64
-> ConduitT () ByteString (RIO e) ()
streamEvents :: MonadIO m => EventLog -> Word64 -> ConduitT () ByteString m ()
streamEvents log first = do
batch <- lift $ readBatch log first
unless (null batch) $ do
for_ batch yield
streamEvents log (first + word (length batch))
batch <- io $ runRIO () $ readBatch log first
unless (null batch) $ do
for_ batch yield
streamEvents log (first + word (length batch))
streamEffectsRows :: ∀e. HasLogFunc e
=> EventLog -> EventId
=> EventLog -> Word64
-> ConduitT () (Word64, ByteString) (RIO e) ()
streamEffectsRows log = go
where
go :: EventId -> ConduitT () (Word64, ByteString) (RIO e) ()
go :: Word64 -> ConduitT () (Word64, ByteString) (RIO e) ()
go next = do
batch <- lift $ readRowsBatch (env log) (effectsTbl log) next
unless (null batch) $ do
@ -294,12 +321,12 @@ readBatch :: EventLog -> Word64 -> RIO e (V.Vector ByteString)
readBatch log first = start
where
start = do
last <- lastEv log
last <- atomically (lastEv log)
if (first > last)
then pure mempty
else readRows $ fromIntegral $ min 1000 $ ((last+1) - first)
assertFound :: EventId -> Bool -> RIO e ()
assertFound :: Word64 -> Bool -> RIO e ()
assertFound id found = do
unless found $ throwIO $ MissingEvent id

71
pkg/hs/urbit-eventlog-lmdb/package.yaml Normal file
View File

@ -0,0 +1,71 @@
name: urbit-eventlog-lmdb
version: 0.10.4
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- classy-prelude
- stm
- rio
- vector
- bytestring
- lmdb-static
- conduit
- racquire
- urbit-noun-core
- urbit-noun
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

119
pkg/hs/urbit-king/TODO.md Normal file
View File

@ -0,0 +1,119 @@
# New IPC Protocol
Stubbed out:
- [x] Handle replacement events (stubbed out now b/c interface can't
handle unparsed nouns)
- [x] Handle IPC errors by killing serf process.
- [x] Handle `peek` and `pack` in `swimming` flow.
- [x] Documentation for `Urbit.Vere.Serf.IPC`.
- [x] Unstub slog/stder/dead callbacks on serf config.
- [x] Remove GoodParse hack in newRunCompute.
- [x] Bring back tank printing.
- [x] Handle serf stderr message correctly.
- [x] Bring back `logEvent`.
- [x] Snapshots should block until that event is commited to disk.
- [x] Hook up error callbacks to IO Drivers.
- [x] Do something useful with error callbacks from IO Drivers.
Bugs:
- [x] In non-daemon mode, serf slogs/stderr output that happens *before*
the terminal connects should still go to stderr.
- [x] Serf stderr should also be send (along with slogs) to all connected
terminals.
- [x] `king new` should reject pier directories that already exist.
- [x] In non-daemon-mode, ^D doesn't bring down Urbit properly.
- [x] Spinner updated multiple times with the same event, and this causes
logging of events to contain duplicates.
King-Haskell specific features:
- [x] Re-implement `collectFX` flow in Serf/Pier.
- [x] Hook up `collectFX` to CLI.
- [ ] Get `collect-all-fx` flow working again.
Performance:
- [x] Batching during replay.
- [x] Batching during normal operation.
Optimization:
- [x] IO Driver Event Prioritization
Polish:
- [x] Cleanup batching flow.
- [x] Think through how to shutdown the serf on exception.
- [x] King should shutdown promptly on ^C. Always takes 2s in practice.
- [x] Bring back progress bars.
- [x] Make sure replay progress bars go to stderr.
- [x] Logging for new IPC flow.
- [x] Logging for boot sequence.
- [x] Take snapshots on clean shutdown.
# Misc Bugs
- [ ] `king run --collect-fx` flag does nothing. Remove or implement.
- [x] Handle ^C in connected terminals. It should interrupt current
event (send SIGINT to serf, which will cause the current event to
fail promptly).
- [x] The terminal driver seems to have a race condition when spinner
changed too quickly.
# Finding the Serf Executable
- [ ] Right now, `urbit-worker` is found by looking it up in the PATH. This
is wrong, but what is right?
# Take Advantage of New IPC Features
- [ ] Hook up `scry` to drivers.
- Any immediate applications of this?
- [ ] Allow scrys to go into the %work batching flow for better latency.
- Handle event errors in other cases:
- [ ] Ames packet failures should print (but not too often).
- [ ] Incoming Http requests should produce 500 responses.
- [ ] Terminal event errors should be printed in connected terminals.
- [ ] Http client responses should be retried.
# Further IO Driver Startup Flow Betterment
Implement Pier-wide process start events
- [x] Handle %vega and exit effects.
- [x] Handle %trim effect
- [x] Inject entropy event on pier start: ``[//arvo [%wack ENT]]`
- [ ] Verbose flag: `-v` injects `[%verb ~]`
- [ ] CLI event injection: `-I file-path`. The `file-path` is a jammed
noun representing an event: `[wire card]`.
1. Just parse it as an `Ev` for now.
2. Make the serf IPC code not care about the shape of events and effects.
3. Support invalid events throughout the system (use `Lenient`?)
# Polish
- [x] Goot logging output in non-verbose mode.
- [x] Command-Line flag to re-enable verbose output.
# Cleanup
- [x] ShutdownSTM action that's passed to the terminal driver should
live in `KingEnv` and should be available to all drivers.
- [ ] Break most logic from `Main.hs` out into modules.
- [ ] Simplify `Main.hs` flows.
- [ ] Cleanup Terminal Driver code.
- [x] Spin off `racquire` into it's own package.
- [x] Spin off `urbit-noun-core` and `urbit-noun` packages.
- [x] Spin off `urbit-eventlog-lmdb` into it's own package.
- [ ] Spin off `Urbit.Vere.Serf` into it's own package
- Make it care less about the shape of events and effects.
- [ ] Spin off per-pier logic into it's own package.
- Probably `urbit-pier`

5
pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs
View File

@ -79,7 +79,10 @@ instance FromNoun H.StdMethod where
-- Http Server Configuration ---------------------------------------------------
newtype PEM = PEM { unPEM :: Wain }
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
deriving newtype (Eq, Ord, ToNoun, FromNoun)
instance Show PEM where
show _ = "\"PEM (secret)\""
type Key = PEM
type Cert = PEM

26
pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs
View File

@ -3,8 +3,8 @@
-}
module Urbit.Arvo.Effect where
import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Time
import Urbit.Arvo.Common (KingId(..), ServId(..))
import Urbit.Arvo.Common (Header, HttpEvent, HttpServerConf, Method, Mime)
@ -82,22 +82,6 @@ data SyncEf
deriveNoun ''SyncEf
-- UDP Effects -----------------------------------------------------------------
{-|
%init -- "I don't think that's something that can happen"
%west -- "Those also shouldn't happen"
%woot -- "Those also shouldn't happen"
-}
data AmesEf
= AmesEfInit Path ()
| AmesEfWest Path Ship Path Noun
| AmesEfWoot Path Ship (Maybe (Maybe (Term, [Tank])))
deriving (Eq, Ord, Show)
deriveNoun ''AmesEf
-- Timer Effects ---------------------------------------------------------------
{-|
@ -171,7 +155,6 @@ data VaneEf
| VEHttpClient HttpClientEf
| VEHttpServer HttpServerEf
| VEBehn BehnEf
| VEAmes AmesEf
| VETerm TermEf
| VEClay SyncEf
| VESync SyncEf
@ -203,3 +186,10 @@ instance FromNoun Ef where
ReOrg "" s "vega" p _ -> fail "%vega effect expects nil value"
ReOrg "" s tag p val -> EfVane <$> parseNoun (toNoun (s, tag, p, val))
ReOrg _ _ _ _ _ -> fail "Non-empty first path-element"
summarizeEffect :: Lenient Ef -> Text
summarizeEffect ef =
fromNoun (toNoun ef) & \case
Nothing -> "//invalid %effect"
Just (pax :: [Cord], tag :: Cord, val :: Noun) ->
"/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag

17
pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs
View File

@ -202,9 +202,16 @@ deriveNoun ''AmesEv
-- Arvo Events -----------------------------------------------------------------
newtype Entropy = Entropy { entropyBits :: Word512 }
deriving newtype (Eq, Ord, FromNoun, ToNoun)
instance Show Entropy where
show = const "\"ENTROPY (secret)\""
data ArvoEv
= ArvoEvWhom () Ship
| ArvoEvWack () Word512
| ArvoEvWack () Entropy
| ArvoEvWarn Path Noun
| ArvoEvCrud Path Noun
| ArvoEvVeer Atom Noun
@ -350,6 +357,7 @@ instance FromNoun Ev where
ReOrg "vane" s t p v -> fmap EvVane $ parseNoun $ toNoun (s,t,p,v)
ReOrg _ _ _ _ _ -> fail "First path-elem must be ?($ %vane)"
-- Short Event Names -----------------------------------------------------------
{-
@ -374,3 +382,10 @@ getSpinnerNameForEvent = \case
where
isRet (TermEvBelt _ (Ret ())) = True
isRet _ = False
summarizeEvent :: Ev -> Text
summarizeEvent ev =
fromNoun (toNoun ev) & \case
Nothing -> "//invalid %event"
Just (pax :: [Cord], tag :: Cord, val :: Noun) ->
"/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag

21
pkg/hs/urbit-king/lib/Urbit/King/API.hs
View File

@ -4,7 +4,14 @@
ships. Do it or strip it out.
-}
module Urbit.King.API (King(..), kingAPI, readPortsFile) where
module Urbit.King.API
( King(..)
, TermConn
, TermConnAPI
, kingAPI
, readPortsFile
)
where
import RIO.Directory
import Urbit.Prelude
@ -12,7 +19,7 @@ import Urbit.Prelude
import Network.Socket (Socket)
import Prelude (read)
import Urbit.Arvo (Belt)
import Urbit.King.App (HasConfigDir(..))
import Urbit.King.App (HasPierPath(..))
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
@ -43,16 +50,16 @@ data King = King
{-|
Get the filepath of the urbit config directory and the ports file.
-}
portsFilePath :: HasConfigDir e => RIO e (FilePath, FilePath)
portsFilePath :: HasPierPath e => RIO e (FilePath, FilePath)
portsFilePath = do
dir <- view configDirL
dir <- view pierPathL
fil <- pure (dir </> ".king.ports")
pure (dir, fil)
{-|
Write the ports file.
-}
portsFile :: HasConfigDir e => Word -> RAcquire e (FilePath, FilePath)
portsFile :: HasPierPath e => Word -> RAcquire e (FilePath, FilePath)
portsFile por =
mkRAcquire mkFile (removeFile . snd)
where
@ -65,7 +72,7 @@ portsFile por =
{-|
Get the HTTP port for the running Urbit daemon.
-}
readPortsFile :: HasConfigDir e => RIO e (Maybe Word)
readPortsFile :: HasPierPath e => RIO e (Maybe Word)
readPortsFile = do
(_, fil) <- portsFilePath
bs <- readFile fil
@ -86,7 +93,7 @@ kingServer is =
{-|
Start the HTTP server and write to the ports file.
-}
kingAPI :: (HasConfigDir e, HasLogFunc e)
kingAPI :: (HasPierPath e, HasLogFunc e)
=> RAcquire e King
kingAPI = do
(port, sock) <- io $ W.openFreePort

263
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -2,139 +2,192 @@
Code for setting up the RIO environment.
-}
module Urbit.King.App
( App
, runApp
, runAppLogFile
, runAppNoLog
, runPierApp
, HasConfigDir(..)
, HasStderrLogFunc(..)
) where
( KingEnv
, runKingEnvStderr
, runKingEnvLogFile
, runKingEnvNoLog
, kingEnvKillSignal
, killKingActionL
, onKillKingSigL
, PierEnv
, runPierEnv
, killPierActionL
, onKillPierSigL
, HasStderrLogFunc(..)
, HasKingId(..)
, HasProcId(..)
, HasKingEnv(..)
, HasPierEnv(..)
, module Urbit.King.Config
)
where
import Urbit.King.Config
import Urbit.Prelude
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.Directory (createDirectoryIfMissing, getHomeDirectory)
import System.Posix.Internals (c_getpid)
import System.Posix.Types (CPid(..))
import System.Random (randomIO)
import Urbit.King.App.Class (HasStderrLogFunc(..))
--------------------------------------------------------------------------------
class HasConfigDir a where
configDirL ∷ Lens' a FilePath
-- KingEnv ---------------------------------------------------------------------
class HasStderrLogFunc a where
stderrLogFuncL :: Lens' a LogFunc
class HasKingId a where
kingIdL :: Lens' a Word16
--------------------------------------------------------------------------------
class HasProcId a where
procIdL :: Lens' a Int32
data App = App
{ _appLogFunc :: !LogFunc
, _appStderrLogFunc :: !LogFunc
}
class (HasLogFunc a, HasStderrLogFunc a, HasKingId a, HasProcId a)
=> HasKingEnv a
where
kingEnvL :: Lens' a KingEnv
makeLenses ''App
data KingEnv = KingEnv
{ _kingEnvLogFunc :: !LogFunc
, _kingEnvStderrLogFunc :: !LogFunc
, _kingEnvKingId :: !Word16
, _kingEnvProcId :: !Int32
, _kingEnvKillSignal :: !(TMVar ())
}
instance HasLogFunc App where
logFuncL = appLogFunc
makeLenses ''KingEnv
instance HasStderrLogFunc App where
stderrLogFuncL = appStderrLogFunc
instance HasKingEnv KingEnv where
kingEnvL = id
runApp :: RIO App a -> IO a
runApp inner = do
logOptions <- logOptionsHandle stderr True
<&> setLogUseTime True
<&> setLogUseLoc False
instance HasLogFunc KingEnv where
logFuncL = kingEnvLogFunc
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc logFunc) inner
instance HasStderrLogFunc KingEnv where
stderrLogFuncL = kingEnvStderrLogFunc
runAppLogFile :: RIO App a -> IO a
runAppLogFile inner =
withLogFileHandle $ \h -> do
logOptions <- logOptionsHandle h True
<&> setLogUseTime True
<&> setLogUseLoc False
stderrLogOptions <- logOptionsHandle stderr True
<&> setLogUseTime False
<&> setLogUseLoc False
instance HasProcId KingEnv where
procIdL = kingEnvProcId
withLogFunc stderrLogOptions $ \stderrLogFunc ->
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc stderrLogFunc) inner
instance HasKingId KingEnv where
kingIdL = kingEnvKingId
-- Running KingEnvs ------------------------------------------------------------
runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a
runKingEnvStderr verb inner = do
logOptions <-
logOptionsHandle stderr verb <&> setLogUseTime True <&> setLogUseLoc False
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner
runKingEnvLogFile :: Bool -> RIO KingEnv a -> IO a
runKingEnvLogFile verb inner = withLogFileHandle $ \h -> do
logOptions <-
logOptionsHandle h verb <&> setLogUseTime True <&> setLogUseLoc False
stderrLogOptions <-
logOptionsHandle stderr verb <&> setLogUseTime False <&> setLogUseLoc False
withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions
$ \logFunc -> runKingEnv logFunc stderrLogFunc inner
withLogFileHandle :: (Handle -> IO a) -> IO a
withLogFileHandle act = do
home <- getHomeDirectory
let logDir = home </> ".urbit"
createDirectoryIfMissing True logDir
withFile (logDir </> "king.log") AppendMode $ \handle -> do
hSetBuffering handle LineBuffering
act handle
home <- getHomeDirectory
let logDir = home </> ".urbit"
createDirectoryIfMissing True logDir
withFile (logDir </> "king.log") AppendMode $ \handle -> do
hSetBuffering handle LineBuffering
act handle
runAppNoLog :: RIO App a -> IO a
runAppNoLog act =
withFile "/dev/null" AppendMode $ \handle -> do
logOptions <- logOptionsHandle handle True
withLogFunc logOptions $ \logFunc ->
runRIO (App logFunc logFunc) act
runKingEnvNoLog :: RIO KingEnv a -> IO a
runKingEnvNoLog act = withFile "/dev/null" AppendMode $ \handle -> do
logOptions <- logOptionsHandle handle True
withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc act
--------------------------------------------------------------------------------
runKingEnv :: LogFunc -> LogFunc -> RIO KingEnv a -> IO a
runKingEnv logFunc stderr action = do
kid <- randomIO
CPid pid <- c_getpid
kil <- newEmptyTMVarIO
runRIO (KingEnv logFunc stderr kid pid kil) action
-- | A PierApp is like an App, except that it also provides a PierConfig
data PierApp = PierApp
{ _pierAppLogFunc :: !LogFunc
, _pierAppStderrLogFunc :: !LogFunc
, _pierAppPierConfig :: !PierConfig
, _pierAppNetworkConfig :: !NetworkConfig
}
makeLenses ''PierApp
-- KingEnv Utils ---------------------------------------------------------------
instance HasStderrLogFunc PierApp where
stderrLogFuncL = pierAppStderrLogFunc
onKillKingSigL :: HasKingEnv e => Getter e (STM ())
onKillKingSigL = kingEnvL . kingEnvKillSignal . to readTMVar
instance HasLogFunc PierApp where
logFuncL = pierAppLogFunc
killKingActionL :: HasKingEnv e => Getter e (STM ())
killKingActionL =
kingEnvL . kingEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
instance HasPierConfig PierApp where
pierConfigL = pierAppPierConfig
instance HasNetworkConfig PierApp where
networkConfigL = pierAppNetworkConfig
-- PierEnv ---------------------------------------------------------------------
instance HasConfigDir PierApp where
configDirL = pierAppPierConfig . pcPierPath
class (HasKingEnv a, HasPierConfig a, HasNetworkConfig a) => HasPierEnv a where
pierEnvL :: Lens' a PierEnv
runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a
runPierApp pierConfig networkConfig daemon inner =
if daemon
then execStderr
else withLogFileHandle execFile
where
execStderr = do
logOptions <- logOptionsHandle stderr True
<&> setLogUseTime True
<&> setLogUseLoc False
data PierEnv = PierEnv
{ _pierEnvKingEnv :: !KingEnv
, _pierEnvPierConfig :: !PierConfig
, _pierEnvNetworkConfig :: !NetworkConfig
, _pierEnvKillSignal :: !(TMVar ())
}
withLogFunc logOptions $ \logFunc ->
go $ PierApp { _pierAppLogFunc = logFunc
, _pierAppStderrLogFunc = logFunc
, _pierAppPierConfig = pierConfig
, _pierAppNetworkConfig = networkConfig
}
makeLenses ''PierEnv
execFile logHandle = do
logOptions <- logOptionsHandle logHandle True
<&> setLogUseTime True
<&> setLogUseLoc False
logStderrOptions <- logOptionsHandle stderr True
<&> setLogUseTime False
<&> setLogUseLoc False
withLogFunc logStderrOptions $ \logStderr ->
withLogFunc logOptions $ \logFunc ->
go $ PierApp { _pierAppLogFunc = logFunc
, _pierAppStderrLogFunc = logStderr
, _pierAppPierConfig = pierConfig
, _pierAppNetworkConfig = networkConfig
}
go app = runRIO app inner
instance HasKingEnv PierEnv where
kingEnvL = pierEnvKingEnv
instance HasPierEnv PierEnv where
pierEnvL = id
instance HasKingId PierEnv where
kingIdL = kingEnvL . kingEnvKingId
instance HasStderrLogFunc PierEnv where
stderrLogFuncL = kingEnvL . stderrLogFuncL
instance HasLogFunc PierEnv where
logFuncL = kingEnvL . logFuncL
instance HasPierPath PierEnv where
pierPathL = pierEnvPierConfig . pierPathL
instance HasDryRun PierEnv where
dryRunL = pierEnvPierConfig . dryRunL
instance HasPierConfig PierEnv where
pierConfigL = pierEnvPierConfig
instance HasNetworkConfig PierEnv where
networkConfigL = pierEnvNetworkConfig
instance HasProcId PierEnv where
procIdL = kingEnvL . kingEnvProcId
-- PierEnv Utils ---------------------------------------------------------------
onKillPierSigL :: HasPierEnv e => Getter e (STM ())
onKillPierSigL = pierEnvL . pierEnvKillSignal . to readTMVar
killPierActionL :: HasPierEnv e => Getter e (STM ())
killPierActionL =
pierEnvL . pierEnvKillSignal . to (\kil -> void (tryPutTMVar kil ()))
-- Running Pier Envs -----------------------------------------------------------
runPierEnv
:: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
runPierEnv pierConfig networkConfig vKill action = do
app <- ask
let pierEnv = PierEnv { _pierEnvKingEnv = app
, _pierEnvPierConfig = pierConfig
, _pierEnvNetworkConfig = networkConfig
, _pierEnvKillSignal = vKill
}
io (runRIO pierEnv action)

15
pkg/hs/urbit-king/lib/Urbit/King/App/Class.hs Normal file
View File

@ -0,0 +1,15 @@
{-|
Code for setting up the RIO environment.
-}
module Urbit.King.App.Class
( HasStderrLogFunc(..)
)
where
import Urbit.Prelude
-- KingEnv ---------------------------------------------------------------------
class HasStderrLogFunc a where
stderrLogFuncL :: Lens' a LogFunc

83
pkg/hs/urbit-king/lib/Urbit/King/CLI.hs
View File

@ -15,6 +15,12 @@ import System.Environment (getProgName)
--------------------------------------------------------------------------------
data KingOpts = KingOpts
{ koSharedHttpPort :: Maybe Word16
, koSharedHttpsPort :: Maybe Word16
}
deriving (Show)
data Opts = Opts
{ oQuiet :: Bool
, oHashless :: Bool
@ -23,6 +29,9 @@ data Opts = Opts
, oDryFrom :: Maybe Word64
, oVerbose :: Bool
, oAmesPort :: Maybe Word16
, oNoAmes :: Bool
, oNoHttp :: Bool
, oNoHttps :: Bool
, oTrace :: Bool
, oCollectFx :: Bool
, oLocalhost :: Bool
@ -31,6 +40,7 @@ data Opts = Opts
, oHttpPort :: Maybe Word16
, oHttpsPort :: Maybe Word16
, oLoopbackPort :: Maybe Word16
, oSerfExe :: Maybe Text
}
deriving (Show)
@ -93,7 +103,7 @@ data Bug
data Cmd
= CmdNew New Opts
| CmdRun Run Opts Bool
| CmdRun KingOpts [(Run, Opts, Bool)]
| CmdBug Bug
| CmdCon FilePath
deriving (Show)
@ -221,6 +231,24 @@ opts = do
<> help "Ames port"
<> hidden
oNoAmes <-
switch
$ long "no-ames"
<> help "Run with Ames disabled."
<> hidden
oNoHttp <-
switch
$ long "no-http"
<> help "Run with HTTP disabled."
<> hidden
oNoHttps <-
switch
$ long "no-https"
<> help "Run with HTTPS disabled."
<> hidden
oHttpPort <-
optional
$ option auto
@ -245,13 +273,18 @@ opts = do
<> help "Localhost-only HTTP port"
<> hidden
-- Always disable hashboard. Right now, urbit is almost unusable with this
-- flag enabled and it is disabled in vere.
let oHashless = True
-- oHashless <- switch $ short 'S'
-- <> long "hashless"
-- <> help "Disable battery hashing"
-- <> hidden
oSerfExe <-
optional
$ option auto
$ metavar "PATH"
<> long "serf"
<> help "Path to Serf"
<> hidden
oHashless <- switch $ short 'S'
<> long "hashless"
<> help "Disable battery hashing (Ignored for now)"
<> hidden
oQuiet <- switch $ short 'q'
<> long "quiet"
@ -307,15 +340,33 @@ opts = do
newShip :: Parser Cmd
newShip = CmdNew <$> new <*> opts
runOneShip :: Parser (Run, Opts, Bool)
runOneShip = (,,) <$> fmap Run pierPath <*> opts <*> df
where
df = switch (short 'd' <> long "daemon" <> help "Daemon mode" <> hidden)
kingOpts :: Parser KingOpts
kingOpts = do
koSharedHttpPort <-
optional
$ option auto
$ metavar "PORT"
<> long "shared-http-port"
<> help "HTTP port"
<> hidden
koSharedHttpsPort <-
optional
$ option auto
$ metavar "PORT"
<> long "shared-https-port"
<> help "HTTPS port"
<> hidden
pure (KingOpts{..})
runShip :: Parser Cmd
runShip = do
rPierPath <- pierPath
o <- opts
daemon <- switch $ short 'd'
<> long "daemon"
<> help "Daemon mode"
<> hidden
pure (CmdRun (Run{..}) o daemon)
runShip = CmdRun <$> kingOpts <*> some runOneShip
valPill :: Parser Bug
valPill = do

38
pkg/hs/urbit-king/lib/Urbit/King/Config.hs
View File

@ -1,29 +1,40 @@
{-|
Pier Configuration
Pier Configuration
-}
module Urbit.King.Config where
import Urbit.Prelude
import qualified Urbit.Vere.Serf as Serf
{-|
All the configuration data revolving around a ship and the current
execution options.
All the configuration data revolving around a ship and the current
execution options.
-}
data PierConfig = PierConfig
{ _pcPierPath :: FilePath
, _pcDryRun :: Bool
} deriving (Show)
{ _pcPierPath :: FilePath
, _pcDryRun :: Bool
, _pcSerfExe :: Text
, _pcSerfFlags :: [Serf.Flag]
} deriving (Show)
makeLenses ''PierConfig
class HasPierConfig env where
pierConfigL :: Lens' env PierConfig
class HasPierPath a where
pierPathL :: Lens' a FilePath
pierPathL ∷ HasPierConfig a => Lens' a FilePath
pierPathL = pierConfigL . pcPierPath
class HasDryRun a where
dryRunL :: Lens' a Bool
class (HasPierPath a, HasDryRun a) => HasPierConfig a where
pierConfigL :: Lens' a PierConfig
instance HasPierPath PierConfig where
pierPathL = pcPierPath
instance HasDryRun PierConfig where
dryRunL = pcDryRun
dryRunL :: HasPierConfig a => Lens' a Bool
dryRunL = pierConfigL . pcDryRun
-------------------------------------------------------------------------------
@ -36,6 +47,9 @@ data NetMode
data NetworkConfig = NetworkConfig
{ _ncNetMode :: NetMode
, _ncAmesPort :: Maybe Word16
, _ncNoAmes :: Bool
, _ncNoHttp :: Bool
, _ncNoHttps :: Bool
, _ncHttpPort :: Maybe Word16
, _ncHttpsPort :: Maybe Word16
, _ncLocalPort :: Maybe Word16

9
pkg/hs/urbit-king/lib/Urbit/King/EventBrowser.hs
View File

@ -10,14 +10,15 @@ import Urbit.Prelude
import Data.Conduit
import Urbit.Arvo
import Urbit.Time
import Urbit.Noun.Time
import Urbit.Vere.Pier.Types
import Control.Monad.Trans.Maybe (MaybeT(..))
import Urbit.Vere.Log (EventLog)
import Urbit.EventLog.LMDB (EventLog)
import qualified Data.Conduit.Combinators as C
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
--------------------------------------------------------------------------------
@ -39,7 +40,7 @@ run log = do
hSetEcho stdin False
logInfo $ displayShow (Log.identity log)
let cycle = fromIntegral $ lifecycleLen $ Log.identity log
las <- Log.lastEv log
las <- atomically (Log.lastEv log)
loop cycle las las
where
failRead cur =

682
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -1,5 +1,25 @@
{-|
King Haskell Entry Point
{- |
# Signal Handling (SIGTERM, SIGINT)
We handle SIGTERM by causing the main thread to raise a `UserInterrupt`
exception. This is the same behavior as SIGINT (the signal sent upon
`CTRL-C`).
The main thread is therefore responsible for handling this exception
and causing everything to shut down properly.
# Crashing and Shutting Down
Rule number one: The King never crashes.
This rule is asperational at the moment, but it needs to become as
close to truth as possible. Shut down ships in extreme cases, but
never let the king go down.
-}
{-
TODO These some old scribbled notes. They don't belong here
anymore. Do something about it.
# Event Pruning
@ -62,18 +82,18 @@ import Urbit.Arvo
import Urbit.King.Config
import Urbit.Vere.Dawn
import Urbit.Vere.Pier
import Urbit.Vere.Eyre.Multi (multiEyre, MultiEyreApi, MultiEyreConf(..))
import Urbit.Vere.Pier.Types
import Urbit.Vere.Serf
import Urbit.King.App
import Control.Concurrent (myThreadId)
import Control.Exception (AsyncException(UserInterrupt))
import Control.Lens ((&))
import System.Process (system)
import Text.Show.Pretty (pPrint)
import Urbit.King.App (runApp, runAppLogFile, runAppNoLog, runPierApp)
import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..))
import Urbit.Noun.Conversions (cordToUW)
import Urbit.Time (Wen)
import Urbit.Noun.Time (Wen)
import Urbit.Vere.LockFile (lockFile)
import qualified Data.Set as Set
@ -82,18 +102,14 @@ import qualified Network.HTTP.Client as C
import qualified System.Posix.Signals as Sys
import qualified System.ProgressBar as PB
import qualified System.Random as Sys
import qualified Urbit.EventLog.LMDB as Log
import qualified Urbit.King.CLI as CLI
import qualified Urbit.King.EventBrowser as EventBrowser
import qualified Urbit.Ob as Ob
import qualified Urbit.Vere.Log as Log
import qualified Urbit.Vere.Pier as Pier
import qualified Urbit.Vere.Serf as Serf
import qualified Urbit.Vere.Term as Term
--------------------------------------------------------------------------------
zod :: Ship
zod = 0
--------------------------------------------------------------------------------
@ -103,28 +119,33 @@ removeFileIfExists pax = do
when exists $ do
removeFile pax
--------------------------------------------------------------------------------
toSerfFlags :: CLI.Opts -> Serf.Flags
-- Compile CLI Flags to Pier Configuration -------------------------------------
{-
TODO: This is not all of the flags.
Urbit is basically useless with hashboard, so we ignore that flag.
-}
toSerfFlags :: CLI.Opts -> [Serf.Flag]
toSerfFlags CLI.Opts{..} = catMaybes m
where
-- TODO: This is not all the flags.
m = [ from oQuiet Serf.Quiet
, from oTrace Serf.Trace
, from oHashless Serf.Hashless
, from oQuiet Serf.Quiet
, from oVerbose Serf.Verbose
, from (oDryRun || isJust oDryFrom) Serf.DryRun
m = [ setFrom oQuiet Serf.Quiet
, setFrom oTrace Serf.Trace
, setFrom (oHashless || True) Serf.Hashless
, setFrom oQuiet Serf.Quiet
, setFrom oVerbose Serf.Verbose
, setFrom (oDryRun || isJust oDryFrom) Serf.DryRun
]
from True flag = Just flag
from False _ = Nothing
setFrom True flag = Just flag
setFrom False _ = Nothing
toPierConfig :: FilePath -> CLI.Opts -> PierConfig
toPierConfig pierPath CLI.Opts {..} = PierConfig { .. }
toPierConfig pierPath o@(CLI.Opts{..}) = PierConfig { .. }
where
_pcPierPath = pierPath
_pcDryRun = oDryRun || isJust oDryFrom
_pcPierPath = pierPath
_pcDryRun = oDryRun || isJust oDryFrom
_pcSerfExe = fromMaybe "urbit-worker" oSerfExe
_pcSerfFlags = toSerfFlags o
toNetworkConfig :: CLI.Opts -> NetworkConfig
toNetworkConfig CLI.Opts {..} = NetworkConfig { .. }
@ -143,157 +164,187 @@ toNetworkConfig CLI.Opts {..} = NetworkConfig { .. }
_ncHttpPort = oHttpPort
_ncHttpsPort = oHttpsPort
_ncLocalPort = oLoopbackPort
_ncNoAmes = oNoAmes
_ncNoHttp = oNoHttp
_ncNoHttps = oNoHttps
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e, HasStderrLogFunc e
)
=> Bool -> Pill -> Bool -> Serf.Flags -> Ship
-> LegacyBootEvent
-> RIO e ()
tryBootFromPill oExit pill lite flags ship boot = do
mStart <- newEmptyMVar
runOrExitImmediately bootedPier oExit mStart
where
bootedPier = do
view pierPathL >>= lockFile
rio $ logTrace "Starting boot"
sls <- Pier.booted pill lite flags ship boot
rio $ logTrace "Completed boot"
pure sls
logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
logStderr action = do
logFunc <- view stderrLogFuncL
runRIO logFunc action
runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e
)
=> RAcquire e (Serf e, Log.EventLog, SerfState)
-> Bool
-> MVar ()
-> RIO e ()
runOrExitImmediately getPier oExit mStart =
rwith getPier $ if oExit then shutdownImmediately else runPier
where
shutdownImmediately (serf, log, ss) = do
logTrace "Sending shutdown signal"
logTrace $ displayShow ss
logSlogs :: HasStderrLogFunc e => RIO e (TVar (Text -> IO ()))
logSlogs = logStderr $ do
env <- ask
newTVarIO (runRIO env . logOther "serf" . display . T.strip)
-- Why is this here? Do I need to force a snapshot to happen?
io $ threadDelay 500000
tryBootFromPill
:: Bool
-> Pill
-> Bool
-> Ship
-> LegacyBootEvent
-> MultiEyreApi
-> RIO PierEnv ()
tryBootFromPill oExit pill lite ship boot multi = do
mStart <- newEmptyMVar
vSlog <- logSlogs
runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi
where
bootedPier vSlog = do
view pierPathL >>= lockFile
rio $ logDebug "Starting boot"
sls <- Pier.booted vSlog pill lite ship boot
rio $ logDebug "Completed boot"
pure sls
ss <- shutdown serf 0
logTrace $ displayShow ss
logTrace "Shutdown!"
runOrExitImmediately
:: TVar (Text -> IO ())
-> RAcquire PierEnv (Serf, Log.EventLog)
-> Bool
-> MVar ()
-> MultiEyreApi
-> RIO PierEnv ()
runOrExitImmediately vSlog getPier oExit mStart multi = do
rwith getPier (if oExit then shutdownImmediately else runPier)
where
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
shutdownImmediately (serf, log) = do
logDebug "Sending shutdown signal"
Serf.stop serf
logDebug "Shutdown!"
runPier sls = do
runRAcquire $ Pier.pier sls mStart
runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
runPier serfLog = do
runRAcquire (Pier.pier serfLog vSlog mStart multi)
tryPlayShip :: ( HasStderrLogFunc e, HasLogFunc e, HasNetworkConfig e
, HasPierConfig e, HasConfigDir e
)
=> Bool -> Bool -> Maybe Word64 -> Serf.Flags -> MVar () -> RIO e ()
tryPlayShip exitImmediately fullReplay playFrom flags mStart = do
when fullReplay wipeSnapshot
runOrExitImmediately resumeShip exitImmediately mStart
where
wipeSnapshot = do
shipPath <- view pierPathL
logTrace "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
tryPlayShip
:: Bool
-> Bool
-> Maybe Word64
-> MVar ()
-> MultiEyreApi
-> RIO PierEnv ()
tryPlayShip exitImmediately fullReplay playFrom mStart multi = do
when fullReplay wipeSnapshot
vSlog <- logSlogs
runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi
where
wipeSnapshot = do
shipPath <- view pierPathL
logDebug "wipeSnapshot"
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
removeFileIfExists (north shipPath)
removeFileIfExists (south shipPath)
north shipPath = shipPath <> "/.urb/chk/north.bin"
south shipPath = shipPath <> "/.urb/chk/south.bin"
north shipPath = shipPath <> "/.urb/chk/north.bin"
south shipPath = shipPath <> "/.urb/chk/south.bin"
resumeShip = do
view pierPathL >>= lockFile
rio $ logTrace "RESUMING SHIP"
sls <- Pier.resumed playFrom flags
rio $ logTrace "SHIP RESUMED"
pure sls
resumeShip :: TVar (Text -> IO ()) -> RAcquire PierEnv (Serf, Log.EventLog)
resumeShip vSlog = do
view pierPathL >>= lockFile
rio $ logDebug "RESUMING SHIP"
sls <- Pier.resumed vSlog playFrom
rio $ logDebug "SHIP RESUMED"
pure sls
runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
=> RAcquire e a -> m e a
runRAcquire act = rwith act pure
--------------------------------------------------------------------------------
checkEvs :: forall e. HasLogFunc e => FilePath -> Word64 -> Word64 -> RIO e ()
checkEvs :: FilePath -> Word64 -> Word64 -> RIO KingEnv ()
checkEvs pierPath first last = do
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logTrace (displayShow ident)
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logDebug (displayShow ident)
last <- Log.lastEv log <&> \lastReal -> min last lastReal
last <- atomically $ Log.lastEv log <&> \lastReal -> min last lastReal
let evCount = fromIntegral (last - first)
let evCount = fromIntegral (last - first)
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
runConduit $ Log.streamEvents log first
.| showEvents pb first (fromIntegral $ lifecycleLen ident)
where
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
runConduit $ Log.streamEvents log first .| showEvents
pb
first
(fromIntegral $ lifecycleLen ident)
where
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
showEvents :: PB.ProgressBar () -> EventId -> EventId
-> ConduitT ByteString Void (RIO e) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logTrace "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do
(mug, wen, evNoun) <- unpackJob n
fromNounErr evNoun & \case
Left err -> logError (displayShow (eId, err))
Right (_ ∷ Ev) -> pure ()
showEvents pb (succ eId) cycle
showEvents
:: PB.ProgressBar ()
-> EventId
-> EventId
-> ConduitT ByteString Void (RIO KingEnv) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logDebug "Everything checks out."
Just bs -> do
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do
(mug, wen, evNoun) <- unpackJob n
fromNounErr evNoun & \case
Left err -> logError (displayShow (eId, err))
Right (_ :: Ev) -> pure ()
showEvents pb (succ eId) cycle
unpackJob :: Noun -> RIO KingEnv (Mug, Wen, Noun)
unpackJob = io . fromNounExn
unpackJob :: Noun -> RIO e (Mug, Wen, Noun)
unpackJob = io . fromNounExn
--------------------------------------------------------------------------------
collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx = error "TODO"
{-
{-|
This runs the serf at `$top/.tmpdir`, but we disable snapshots,
so this should never actually be created. We just do this to avoid
letting the serf use an existing snapshot.
-}
collectAllFx :: ∀e. HasLogFunc e => FilePath -> RIO e ()
collectAllFx :: FilePath -> RIO KingEnv ()
collectAllFx top = do
logTrace $ display $ pack @Text top
rwith collectedFX $ \() ->
logTrace "Done collecting effects!"
logDebug $ display $ pack @Text top
vSlog <- logSlogs
rwith (collectedFX vSlog) $ \() ->
logDebug "Done collecting effects!"
where
tmpDir :: FilePath
tmpDir = top </> ".tmpdir"
collectedFX :: RAcquire e ()
collectedFX = do
collectedFX :: TVar (Text -> IO ()) -> RAcquire KingEnv ()
collectedFX vSlog = do
lockFile top
log <- Log.existing (top <> "/.urb/log")
serf <- Serf.run (Serf.Config tmpDir serfFlags)
serf <- Pier.runSerf vSlog tmpDir serfFlags
rio $ Serf.collectFX serf log
serfFlags :: Serf.Flags
serfFlags :: [Serf.Flag]
serfFlags = [Serf.Hashless, Serf.DryRun]
-}
--------------------------------------------------------------------------------
replayPartEvs :: ∀e. (HasStderrLogFunc e, HasLogFunc e)
=> FilePath -> Word64 -> RIO e ()
replayPartEvs :: FilePath -> Word64 -> RIO KingEnv ()
replayPartEvs top last = do
logTrace $ display $ pack @Text top
logDebug $ display $ pack @Text top
fetchSnapshot
rwith replayedEvs $ \() ->
logTrace "Done replaying events!"
logDebug "Done replaying events!"
where
fetchSnapshot :: RIO e ()
fetchSnapshot :: RIO KingEnv ()
fetchSnapshot = do
snap <- Pier.getSnapshot top last
case snap of
@ -305,20 +356,28 @@ replayPartEvs top last = do
tmpDir :: FilePath
tmpDir = top </> ".partial-replay" </> show last
replayedEvs :: RAcquire e ()
replayedEvs :: RAcquire KingEnv ()
replayedEvs = do
lockFile top
log <- Log.existing (top <> "/.urb/log")
serf <- Serf.run (Serf.Config tmpDir serfFlags)
let onSlog = print
let onStdr = print
let onDead = error "DIED"
let config = Serf.Config "urbit-worker" tmpDir serfFlags onSlog onStdr onDead
(serf, info) <- io (Serf.start config)
rio $ do
ss <- Serf.replay serf log $ Just last
Serf.snapshot serf ss
eSs <- Serf.execReplay serf log (Just last)
case eSs of
Left bail -> error (show bail)
Right 0 -> io (Serf.snapshot serf)
Right num -> pure ()
io $ threadDelay 500000 -- Copied from runOrExitImmediately
pure ()
serfFlags :: Serf.Flags
serfFlags :: [Serf.Flag]
serfFlags = [Serf.Hashless]
--------------------------------------------------------------------------------
{-|
@ -326,84 +385,98 @@ replayPartEvs top last = do
-}
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
testPill pax showPil showSeq = do
putStrLn "Reading pill file."
logDebug "Reading pill file."
pillBytes <- readFile pax
putStrLn "Cueing pill file."
logDebug "Cueing pill file."
pillNoun <- io $ cueBS pillBytes & either throwIO pure
putStrLn "Parsing pill file."
logDebug "Parsing pill file."
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
putStrLn "Using pill to generate boot sequence."
bootSeq <- generateBootSeq zod pill False (Fake $ Ship 0)
logDebug "Using pill to generate boot sequence."
bootSeq <- genBootSeq (Ship 0) pill False (Fake (Ship 0))
putStrLn "Validate jam/cue and toNoun/fromNoun on pill value"
logDebug "Validate jam/cue and toNoun/fromNoun on pill value"
reJam <- validateNounVal pill
putStrLn "Checking if round-trip matches input file:"
logDebug "Checking if round-trip matches input file:"
unless (reJam == pillBytes) $ do
putStrLn " Our jam does not match the file...\n"
putStrLn " This is surprising, but it is probably okay."
logDebug " Our jam does not match the file...\n"
logDebug " This is surprising, but it is probably okay."
when showPil $ do
putStrLn "\n\n== Pill ==\n"
logDebug "\n\n== Pill ==\n"
io $ pPrint pill
when showSeq $ do
putStrLn "\n\n== Boot Sequence ==\n"
logDebug "\n\n== Boot Sequence ==\n"
io $ pPrint bootSeq
validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
=> a -> RIO e ByteString
validateNounVal inpVal = do
putStrLn " jam"
logDebug " jam"
inpByt <- evaluate $ jamBS $ toNoun inpVal
putStrLn " cue"
logDebug " cue"
outNon <- cueBS inpByt & either throwIO pure
putStrLn " fromNoun"
logDebug " fromNoun"
outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
putStrLn " toNoun"
logDebug " toNoun"
outNon <- evaluate (toNoun outVal)
putStrLn " jam"
logDebug " jam"
outByt <- evaluate $ jamBS outNon
putStrLn "Checking if: x == cue (jam x)"
logDebug "Checking if: x == cue (jam x)"
unless (inpVal == outVal) $
error "Value fails test: x == cue (jam x)"
putStrLn "Checking if: jam x == jam (cue (jam x))"
logDebug "Checking if: jam x == jam (cue (jam x))"
unless (inpByt == outByt) $
error "Value fails test: jam x == jam (cue (jam x))"
pure outByt
--------------------------------------------------------------------------------
pillFrom :: CLI.PillSource -> RIO e Pill
pillFrom :: CLI.PillSource -> RIO KingEnv Pill
pillFrom = \case
CLI.PillSourceFile pillPath -> do
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
io (loadFile pillPath >>= either throwIO pure)
pillFrom (CLI.PillSourceFile pillPath) = do
putStrLn $ "boot: reading pill from " ++ pack pillPath
io (loadFile pillPath >>= either throwIO pure)
CLI.PillSourceURL url -> do
logDebug $ display $ "boot: retrieving pill from " ++ (pack url :: Text)
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
request <- io $ C.parseRequest url
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response
pillFrom (CLI.PillSourceURL url) = do
putStrLn $ "boot: retrieving pill from " ++ pack url
-- Get the jamfile with the list of stars accepting comets right now.
manager <- io $ C.newManager tlsManagerSettings
request <- io $ C.parseRequest url
response <- io $ C.httpLbs (C.setRequestCheckStatus request) manager
let body = toStrict $ C.responseBody response
noun <- cueBS body & either throwIO pure
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
noun <- cueBS body & either throwIO pure
fromNounErr noun & either (throwIO . uncurry ParseErr) pure
newShip :: CLI.New -> CLI.Opts -> RIO KingEnv ()
newShip CLI.New{..} opts = do
{-
TODO XXX HACK
newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
newShip CLI.New{..} opts
| CLI.BootComet <- nBootType = do
Because the "new ship" flow *may* automatically start the ship,
we need to create this, but it's not actually correct.
The right solution is to separate out the "new ship" flow from the
"run ship" flow, and possibly sequence them from the outside if
that's really needed.
-}
multi <- multiEyre (MultiEyreConf Nothing Nothing True)
case nBootType of
CLI.BootComet -> do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
starList <- dawnCometList
@ -413,14 +486,14 @@ newShip CLI.New{..} opts
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed pill seed
bootFromSeed multi pill seed
| CLI.BootFake name <- nBootType = do
CLI.BootFake name -> do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill pill name ship (Fake ship)
runTryBootFromPill multi pill name ship (Fake ship)
| CLI.BootFromKeyfile keyFile <- nBootType = do
CLI.BootFromKeyfile keyFile -> do
text <- readFileUtf8 keyFile
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
@ -433,10 +506,10 @@ newShip CLI.New{..} opts
pill <- pillFrom nPillSource
bootFromSeed pill seed
bootFromSeed multi pill seed
where
shipFrom :: Text -> RIO e Ship
shipFrom :: Text -> RIO KingEnv Ship
shipFrom name = case Ob.parsePatp name of
Left x -> error "Invalid ship name"
Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
@ -446,7 +519,7 @@ newShip CLI.New{..} opts
Just x -> x
Nothing -> "./" <> unpack name
nameFromShip :: Ship -> RIO e Text
nameFromShip :: Ship -> RIO KingEnv Text
nameFromShip s = name
where
nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
@ -454,8 +527,8 @@ newShip CLI.New{..} opts
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure x
bootFromSeed :: Pill -> Seed -> RIO e ()
bootFromSeed pill seed = do
bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO KingEnv ()
bootFromSeed multi pill seed = do
ethReturn <- dawnVent seed
case ethReturn of
@ -463,43 +536,51 @@ newShip CLI.New{..} opts
Right dawn -> do
let ship = sShip $ dSeed dawn
name <- nameFromShip ship
runTryBootFromPill pill name ship (Dawn dawn)
flags = toSerfFlags opts
runTryBootFromPill multi pill name ship (Dawn dawn)
-- Now that we have all the information for running an application with a
-- PierConfig, do so.
runTryBootFromPill pill name ship bootEvent = do
runTryBootFromPill multi pill name ship bootEvent = do
vKill <- view kingEnvKillSignal
let pierConfig = toPierConfig (pierPath name) opts
let networkConfig = toNetworkConfig opts
io $ runPierApp pierConfig networkConfig True $
tryBootFromPill True pill nLite flags ship bootEvent
runPierEnv pierConfig networkConfig vKill $
tryBootFromPill True pill nLite ship bootEvent multi
------ tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO KingEnv a
runShipEnv (CLI.Run pierPath) opts vKill act = do
runPierEnv pierConfig netConfig vKill act
where
pierConfig = toPierConfig pierPath opts
netConfig = toNetworkConfig opts
runShip :: CLI.Run -> CLI.Opts -> Bool -> IO ()
runShip (CLI.Run pierPath) opts daemon = do
tid <- myThreadId
let onTermExit = throwTo tid UserInterrupt
mStart <- newEmptyMVar
runShip
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO PierEnv ()
runShip (CLI.Run pierPath) opts daemon multi = do
mStart <- newEmptyMVar
if daemon
then runPier mStart
else do
-- Wait until the pier has started up, then connect a terminal. If
-- the terminal ever shuts down, ask the ship to go down.
connectionThread <- async $ do
readMVar mStart
finally (runAppNoLog $ connTerm pierPath) onTermExit
finally (runPier mStart) (cancel connectionThread)
finally (connTerm pierPath) $ do
view killPierActionL >>= atomically
-- Run the pier until it finishes, and then kill the terminal.
finally (runPier mStart) $ do
cancel connectionThread
where
runPier mStart =
runPierApp pierConfig networkConfig daemon $
tryPlayShip
(CLI.oExit opts)
(CLI.oFullReplay opts)
(CLI.oDryFrom opts)
(toSerfFlags opts)
mStart
pierConfig = toPierConfig pierPath opts
networkConfig = toNetworkConfig opts
runPier :: MVar () -> RIO PierEnv ()
runPier mStart = do
tryPlayShip
(CLI.oExit opts)
(CLI.oFullReplay opts)
(CLI.oDryFrom opts)
mStart
multi
startBrowser :: HasLogFunc e => FilePath -> RIO e ()
@ -540,33 +621,200 @@ checkComet = do
main :: IO ()
main = do
args <- CLI.parseArgs
hSetBuffering stdout NoBuffering
setupSignalHandlers
runKingEnv args $ case args of
CLI.CmdRun ko ships -> runShips ko ships
CLI.CmdNew n o -> newShip n o
CLI.CmdBug (CLI.CollectAllFX pax ) -> collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax ) -> startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> checkFx pax f l
CLI.CmdBug (CLI.ReplayEvents pax l ) -> replayPartEvs pax l
CLI.CmdBug (CLI.CheckDawn pax ) -> checkDawn pax
CLI.CmdBug CLI.CheckComet -> checkComet
CLI.CmdCon pier -> connTerm pier
where
runKingEnv args =
let verb = verboseLogging args
in if willRunTerminal args
then runKingEnvLogFile verb
else runKingEnvStderr verb
setupSignalHandlers = do
mainTid <- myThreadId
let onKillSig = throwTo mainTid UserInterrupt
for_ [Sys.sigTERM, Sys.sigINT] $ \sig -> do
Sys.installHandler sig (Sys.Catch onKillSig) Nothing
hSetBuffering stdout NoBuffering
verboseLogging :: CLI.Cmd -> Bool
verboseLogging = \case
CLI.CmdRun ko ships -> any CLI.oVerbose (ships <&> \(_, o, _) -> o)
_ -> False
let onTermSig = throwTo mainTid UserInterrupt
willRunTerminal :: CLI.Cmd -> Bool
willRunTerminal = \case
CLI.CmdCon _ -> True
CLI.CmdRun ko [(_,_,daemon)] -> not daemon
CLI.CmdRun ko _ -> False
_ -> False
Sys.installHandler Sys.sigTERM (Sys.Catch onTermSig) Nothing
CLI.parseArgs >>= \case
CLI.CmdRun r o d -> runShip r o d
CLI.CmdNew n o -> runApp $ newShip n o
CLI.CmdBug (CLI.CollectAllFX pax) -> runApp $ collectAllFx pax
CLI.CmdBug (CLI.EventBrowser pax) -> runApp $ startBrowser pax
CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
CLI.CmdBug (CLI.ValidateFX pax f l) -> runApp $ checkFx pax f l
CLI.CmdBug (CLI.ReplayEvents pax l) -> runApp $ replayPartEvs pax l
CLI.CmdBug (CLI.CheckDawn pax) -> runApp $ checkDawn pax
CLI.CmdBug CLI.CheckComet -> runApp $ checkComet
CLI.CmdCon pier -> runAppLogFile $ connTerm pier
{-
Runs a ship but restarts it if it crashes or shuts down on it's own.
Once `waitForKillRequ` returns, the ship will be terminated and this
routine will exit.
TODO Use logging system instead of printing.
-}
runShipRestarting
:: CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO KingEnv ()
runShipRestarting r o multi = do
let pier = pack (CLI.rPierPath r)
loop = runShipRestarting r o multi
onKill <- view onKillKingSigL
vKillPier <- newEmptyTMVarIO
tid <- asyncBound $ runShipEnv r o vKillPier $ runShip r o True multi
let onShipExit = Left <$> waitCatchSTM tid
onKillRequ = Right <$> onKill
atomically (onShipExit <|> onKillRequ) >>= \case
Left exit -> do
case exit of
Left err -> logError $ display (tshow err <> ": " <> pier)
Right () ->
logError $ display ("Ship exited on it's own. Why? " <> pier)
threadDelay 250_000
loop
Right () -> do
logTrace $ display (pier <> " shutdown requested")
race_ (wait tid) $ do
threadDelay 5_000_000
logDebug $ display (pier <> " not down after 5s, killing with fire.")
cancel tid
logTrace $ display ("Ship terminated: " <> pier)
{-
TODO This is messy and shared a lot of logic with `runShipRestarting`.
-}
runShipNoRestart
:: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO KingEnv ()
runShipNoRestart r o d multi = do
vKill <- view kingEnvKillSignal -- killing ship same as killing king
tid <- asyncBound (runShipEnv r o vKill $ runShip r o d multi)
onKill <- view onKillKingSigL
let pier = pack (CLI.rPierPath r)
let onShipExit = Left <$> waitCatchSTM tid
onKillRequ = Right <$> onKill
atomically (onShipExit <|> onKillRequ) >>= \case
Left (Left err) -> do
logError $ display (tshow err <> ": " <> pier)
Left (Right ()) -> do
logError $ display (pier <> " exited on it's own. Why?")
Right () -> do
logTrace $ display (pier <> " shutdown requested")
race_ (wait tid) $ do
threadDelay 5_000_000
logTrace $ display (pier <> " not down after 5s, killing with fire.")
cancel tid
logTrace $ display (pier <> " terminated.")
runShips :: CLI.KingOpts -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
runShips CLI.KingOpts {..} ships = do
let meConf = MultiEyreConf
{ mecHttpPort = fromIntegral <$> koSharedHttpPort
, mecHttpsPort = fromIntegral <$> koSharedHttpsPort
, mecLocalhostOnly = False -- TODO Localhost-only needs to be
-- a king-wide option.
}
{-
TODO Need to rework RIO environment to fix this. Should have a
bunch of nested contexts:
- King has started. King has Id. Logging available.
- In running environment. MultiEyre and global config available.
- In pier environment: pier path and config available.
- In running ship environment: serf state, event queue available.
-}
multi <- multiEyre meConf
go multi ships
where
go :: MultiEyreApi -> [(CLI.Run, CLI.Opts, Bool)] -> RIO KingEnv ()
go me = \case
[] -> pure ()
[rod] -> runSingleShip rod me
ships -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me
-- TODO Duplicated logic.
runSingleShip :: (CLI.Run, CLI.Opts, Bool) -> MultiEyreApi -> RIO KingEnv ()
runSingleShip (r, o, d) multi = do
shipThread <- async (runShipNoRestart r o d multi)
{-
Wait for the ship to go down.
Since `waitCatch` will never throw an exception, the `onException`
block will only happen if this thread is killed with an async
exception. The one we expect is `UserInterrupt` which will be raised
on this thread upon SIGKILL or SIGTERM.
If this thread is killed, we first ask the ship to go down, wait
for the ship to actually go down, and then go down ourselves.
-}
onException (void $ waitCatch shipThread) $ do
logTrace "KING IS GOING DOWN"
atomically =<< view killKingActionL
waitCatch shipThread
pure ()
runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO KingEnv ()
runMultipleShips ships multi = do
shipThreads <- for ships $ \(r, o) -> do
async (runShipRestarting r o multi)
{-
Since `spin` never returns, this will run until the main
thread is killed with an async exception. The one we expect is
`UserInterrupt` which will be raised on this thread upon SIGKILL
or SIGTERM.
Once that happens, we send a shutdown signal which will cause all
ships to be shut down, and then we `wait` for them to finish before
returning.
This is different than the single-ship flow, because ships never
go down on their own in this flow. If they go down, they just bring
themselves back up.
-}
let spin = forever (threadDelay maxBound)
finally spin $ do
logTrace "KING IS GOING DOWN"
view killKingActionL >>= atomically
for_ shipThreads waitCatch
--------------------------------------------------------------------------------
connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
connTerm pier =
Term.runTerminalClient pier
connTerm = Term.runTerminalClient
--------------------------------------------------------------------------------

405
pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs
View File

@ -1,87 +1,123 @@
{-|
Ames IO Driver -- UDP
Ames IO Driver
-}
module Urbit.Vere.Ames (ames) where
module Urbit.Vere.Ames (ames, ames') where
import Urbit.Prelude
import Control.Monad.Extra hiding (mapM_)
import Network.Socket hiding (recvFrom, sendTo)
import Network.Socket.ByteString
import Urbit.Arvo hiding (Fake)
import Network.Socket hiding (recvFrom, sendTo)
import Urbit.Arvo hiding (Fake)
import Urbit.King.Config
import Urbit.Vere.Pier.Types
import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Urbit.Ob as Ob
import qualified Urbit.Time as Time
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
import Urbit.Vere.Ames.UDP (UdpServ(..), fakeUdpServ, realUdpServ)
-- Types -----------------------------------------------------------------------
data AmesDrv = AmesDrv
{ aTurfs :: TVar (Maybe [Turf])
, aGalaxies :: IORef (M.Map Galaxy (Async (), TQueue ByteString))
, aSocket :: TVar (Maybe Socket)
, aListener :: Async ()
, aSendingQueue :: TQueue (SockAddr, ByteString)
, aSendingThread :: Async ()
{ aTurfs :: TVar (Maybe [Turf])
, aUdpServ :: UdpServ
, aResolvr :: ResolvServ
, aRecvTid :: Async ()
}
data NetworkMode = Fake | Localhost | Real | NoNetwork
deriving (Eq, Ord, Show)
-- Utils -----------------------------------------------------------------------
galaxyPort :: NetworkMode -> Galaxy -> PortNumber
galaxyPort Fake (Patp g) = fromIntegral g + 31337
galaxyPort Localhost (Patp g) = fromIntegral g + 13337
galaxyPort Real (Patp g) = fromIntegral g + 13337
galaxyPort NoNetwork _ = fromIntegral 0
listenPort :: NetworkMode -> Ship -> PortNumber
listenPort m s | s < 256 = galaxyPort m (fromIntegral s)
listenPort m _ = 0
listenPort m _ = 0 -- I don't care, just give me any port.
localhost :: HostAddress
localhost = tupleToHostAddress (127,0,0,1)
localhost = tupleToHostAddress (127, 0, 0, 1)
inaddrAny :: HostAddress
inaddrAny = tupleToHostAddress (0,0,0,0)
inaddrAny = tupleToHostAddress (0, 0, 0, 0)
okayFakeAddr :: AmesDest -> Bool
okayFakeAddr = \case
EachYes _ -> True
EachNo (Jammed (AAIpv4 (Ipv4 a) _)) -> a == localhost
EachNo (Jammed (AAVoid v)) -> absurd v
modeAddress :: NetworkMode -> Maybe HostAddress
modeAddress = \case
Fake -> Just localhost
Localhost -> Just localhost
Real -> Just inaddrAny
NoNetwork -> Nothing
localhostSockAddr :: NetworkMode -> AmesDest -> SockAddr
localhostSockAddr mode = \case
EachYes g -> SockAddrInet (galaxyPort mode g) localhost
EachNo (Jammed (AAIpv4 _ p)) -> SockAddrInet (fromIntegral p) localhost
EachNo (Jammed (AAVoid v)) -> absurd v
okFakeAddr :: AmesDest -> Bool
okFakeAddr = \case
EachYes _ -> True
EachNo (Jammed (AAIpv4 (Ipv4 a) _)) -> a == localhost
EachNo (Jammed (AAVoid v )) -> absurd v
localAddr :: NetworkMode -> AmesDest -> SockAddr
localAddr mode = \case
EachYes g -> SockAddrInet (galaxyPort mode g) localhost
EachNo (Jammed (AAIpv4 _ p)) -> SockAddrInet (fromIntegral p) localhost
EachNo (Jammed (AAVoid v )) -> absurd v
bornEv :: KingId -> Ev
bornEv inst =
EvBlip $ BlipEvNewt $ NewtEvBorn (fromIntegral inst, ()) ()
bornEv inst = EvBlip $ BlipEvNewt $ NewtEvBorn (fromIntegral inst, ()) ()
hearEv :: PortNumber -> HostAddress -> ByteString -> Ev
hearEv p a bs =
EvBlip $ BlipEvAmes $ AmesEvHear () dest (MkBytes bs)
where
dest = EachNo $ Jammed $ AAIpv4 (Ipv4 a) (fromIntegral p)
_turfText :: Turf -> Text
_turfText = intercalate "." . reverse . fmap unCord . unTurf
renderGalaxy :: Galaxy -> Text
renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
EvBlip $ BlipEvAmes $ AmesEvHear () dest (MkBytes bs)
where
dest = EachNo $ Jammed $ AAIpv4 (Ipv4 a) (fromIntegral p)
--------------------------------------------------------------------------------
netMode :: HasNetworkConfig e => Bool -> RIO e NetworkMode
netMode isFake = do
netMode <- view (networkConfigL . ncNetMode)
noAmes <- view (networkConfigL . ncNoAmes)
pure $ case (noAmes, isFake, netMode) of
(True, _ , _ ) -> NoNetwork
(_ , _ , NMNone ) -> NoNetwork
(_ , True, _ ) -> Fake
(_ , _ , NMNormal ) -> Real
(_ , _ , NMLocalhost) -> Localhost
udpPort :: HasNetworkConfig e => Bool -> Ship -> RIO e PortNumber
udpPort isFake who = do
mode <- netMode isFake
mPort <- view (networkConfigL . ncAmesPort)
pure $ maybe (listenPort mode who) fromIntegral mPort
udpServ :: (HasLogFunc e, HasNetworkConfig e) => Bool -> Ship -> RIO e UdpServ
udpServ isFake who = do
mode <- netMode isFake
port <- udpPort isFake who
case modeAddress mode of
Nothing -> fakeUdpServ
Just host -> realUdpServ port host
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
pure () -- TODO What can we do?
ames'
:: HasPierEnv e
=> Ship
-> Bool
-> (Text -> RIO e ())
-> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
ames' who isFake stderr = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = ames env who isFake (writeTQueue ventQ) stderr
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
{-|
inst -- Process instance number.
who -- Which ship are we?
@ -93,229 +129,70 @@ renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
TODO verify that the KingIds match on effects.
-}
ames :: forall e. (HasLogFunc e, HasNetworkConfig e)
=> KingId -> Ship -> Bool -> QueueEv
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (EffCb e NewtEf))
ames inst who isFake enqueueEv stderr =
(initialEvents, runAmes)
where
initialEvents :: [Ev]
initialEvents = [bornEv inst]
ames
:: forall e
. (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> e
-> Ship
-> Bool
-> (EvErr -> STM ())
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (NewtEf -> IO ()))
ames env who isFake enqueueEv stderr = (initialEvents, runAmes)
where
king = fromIntegral (env ^. kingIdL)
runAmes :: RAcquire e (EffCb e NewtEf)
runAmes = do
drv <- mkRAcquire start stop
pure (handleEffect drv)
initialEvents :: [Ev]
initialEvents = [bornEv king]
start :: RIO e AmesDrv
start = do
aTurfs <- newTVarIO Nothing
aGalaxies <- newIORef mempty
aSocket <- newTVarIO Nothing
bindSock aSocket
aListener <- async (waitPacket aSocket)
aSendingQueue <- newTQueueIO
aSendingThread <- async (sendingThread aSendingQueue aSocket)
pure $ AmesDrv{..}
runAmes :: RAcquire e (NewtEf -> IO ())
runAmes = do
mode <- rio (netMode isFake)
drv <- mkRAcquire start stop
pure (handleEffect drv mode)
netMode :: RIO e NetworkMode
netMode = do
if isFake
then pure Fake
else view (networkConfigL . ncNetMode) >>= \case
NMNormal -> pure Real
NMLocalhost -> pure Localhost
NMNone -> pure NoNetwork
start :: RIO e AmesDrv
start = do
aTurfs <- newTVarIO Nothing
aUdpServ <- udpServ isFake who
aRecvTid <- queuePacketsThread aUdpServ
aResolvr <- resolvServ aTurfs (usSend aUdpServ) stderr
pure (AmesDrv { .. })
stop :: AmesDrv -> RIO e ()
stop AmesDrv{..} = do
readIORef aGalaxies >>= mapM_ (cancel . fst)
hearFailed _ = pure ()
cancel aSendingThread
cancel aListener
socket <- atomically $ readTVar aSocket
io $ maybeM (pure ()) (close') (pure socket)
queuePacketsThread :: UdpServ -> RIO e (Async ())
queuePacketsThread UdpServ {..} = async $ forever $ atomically $ do
(p, a, b) <- usRecv
enqueueEv (EvErr (hearEv p a b) hearFailed)
bindSock :: TVar (Maybe Socket) -> RIO e ()
bindSock socketVar = getBindAddr >>= doBindSocket
where
getBindAddr = netMode >>= \case
Fake -> pure $ Just localhost
Localhost -> pure $ Just localhost
Real -> pure $ Just inaddrAny
NoNetwork -> pure Nothing
stop :: AmesDrv -> RIO e ()
stop AmesDrv {..} = io $ do
usKill aUdpServ
rsKill aResolvr
cancel aRecvTid
doBindSocket :: Maybe HostAddress -> RIO e ()
doBindSocket Nothing = atomically $ writeTVar socketVar Nothing
doBindSocket (Just bindAddr) = do
mode <- netMode
mPort <- view (networkConfigL . ncAmesPort)
let ourPort = maybe (listenPort mode who) fromIntegral mPort
s <- io $ socket AF_INET Datagram defaultProtocol
handleEffect :: AmesDrv -> NetworkMode -> NewtEf -> IO ()
handleEffect drv@AmesDrv {..} mode = runRIO env . \case
NewtEfTurf (_id, ()) turfs -> do
atomically $ writeTVar aTurfs (Just turfs)
logTrace $ displayShow ("(ames) Binding to port ", ourPort)
let addr = SockAddrInet ourPort bindAddr
() <- io $ bind s addr
NewtEfSend (_id, ()) dest (MkBytes bs) -> do
atomically (readTVar aTurfs) >>= \case
Nothing -> pure ()
Just turfs -> sendPacket drv mode dest bs
atomically $ writeTVar socketVar (Just s)
sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()
sendPacket AmesDrv {..} mode dest byt = do
let to adr = io (usSend aUdpServ adr byt)
waitPacket :: TVar (Maybe Socket) -> RIO e ()
waitPacket socketVar = do
(atomically $ readTVar socketVar) >>= \case
Nothing -> pure ()
Just s -> do
res <- io $ tryIOError $ recvFrom s 4096
case res of
Left exn -> do
-- When we have a socket exception, we need to rebuild the
-- socket.
logTrace $ displayShow ("(ames) Socket exception. Rebinding.")
bindSock socketVar
Right (bs, addr) -> do
logTrace $ displayShow ("(ames) Received packet from ", addr)
case addr of
SockAddrInet p a -> atomically (enqueueEv $ hearEv p a bs)
_ -> pure ()
case (mode, dest) of
(NoNetwork, _ ) -> pure ()
(Fake , _ ) -> when (okFakeAddr dest) $ to (localAddr Fake dest)
(Localhost, _ ) -> to (localAddr Localhost dest)
(Real , ra) -> ra & \case
EachYes gala -> io (rsSend aResolvr gala byt)
EachNo addr -> to (ipv4Addr addr)
waitPacket socketVar
handleEffect :: AmesDrv -> NewtEf -> RIO e ()
handleEffect drv@AmesDrv{..} = \case
NewtEfTurf (_id, ()) turfs -> do
atomically $ writeTVar aTurfs (Just turfs)
NewtEfSend (_id, ()) dest (MkBytes bs) -> do
atomically (readTVar aTurfs) >>= \case
Nothing -> pure ()
Just turfs -> do
mode <- netMode
(sendPacket drv mode dest bs)
sendPacket :: AmesDrv -> NetworkMode -> AmesDest -> ByteString -> RIO e ()
sendPacket AmesDrv{..} NoNetwork dest bs = pure ()
sendPacket AmesDrv{..} Fake dest bs = do
when (okayFakeAddr dest) $ atomically $
writeTQueue aSendingQueue ((localhostSockAddr Fake dest), bs)
-- In localhost only mode, regardless of the actual destination, send it to
-- localhost.
sendPacket AmesDrv{..} Localhost dest bs = atomically $
writeTQueue aSendingQueue ((localhostSockAddr Localhost dest), bs)
sendPacket AmesDrv{..} Real (EachYes galaxy) bs = do
galaxies <- readIORef aGalaxies
queue <- case M.lookup galaxy galaxies of
Just (_, queue) -> pure queue
Nothing -> do
inQueue <- newTQueueIO
thread <- async $ galaxyResolver galaxy aTurfs inQueue aSendingQueue
modifyIORef (aGalaxies) (M.insert galaxy (thread, inQueue))
pure inQueue
atomically $ writeTQueue queue bs
sendPacket AmesDrv{..} Real (EachNo (Jammed (AAIpv4 a p))) bs = do
let addr = SockAddrInet (fromIntegral p) (unIpv4 a)
atomically $ writeTQueue aSendingQueue (addr, bs)
sendPacket AmesDrv{..} Real (EachNo (Jammed (AAVoid v))) bs = do
pure (absurd v)
-- An outbound queue of messages. We can only write to a socket from one
-- thread, so coalesce those writes here.
sendingThread :: TQueue (SockAddr, ByteString)
-> TVar (Maybe Socket)
-> RIO e ()
sendingThread queue socketVar = forever $
do
(dest, bs) <- atomically $ readTQueue queue
logTrace $ displayShow ("(ames) Sending packet to ", dest)
sendAll bs dest
where
sendAll bs dest = do
mybSocket <- atomically $ readTVar socketVar
case mybSocket of
Nothing -> pure ()
Just socket -> do
bytesSent <- io $ sendTo socket bs dest
when (bytesSent /= BS.length bs) $ do
sendAll (drop bytesSent bs) dest
-- Asynchronous thread per galaxy which handles domain resolution, and can
-- block its own queue of ByteStrings to send.
--
-- Maybe perform the resolution asynchronously, injecting into the resolver
-- queue as a message.
--
-- TODO: Figure out how the real haskell time library works.
galaxyResolver :: Galaxy -> TVar (Maybe [Turf]) -> TQueue ByteString
-> TQueue (SockAddr, ByteString)
-> RIO e ()
galaxyResolver galaxy turfVar incoming outgoing =
loop Nothing Time.unixEpoch
where
loop :: Maybe SockAddr -> Time.Wen -> RIO e ()
loop lastGalaxyIP lastLookupTime = do
packet <- atomically $ readTQueue incoming
checkIP lastGalaxyIP lastLookupTime >>= \case
(Nothing, t) -> do
-- We've failed to lookup the IP. Drop the outbound packet
-- because we have no IP for our galaxy, including possible
-- previous IPs.
logDebug $ displayShow
("(ames) Dropping packet; no ip for galaxy ", galaxy)
loop Nothing t
(Just ip, t) -> do
queueSendToGalaxy ip packet
loop (Just ip) t
checkIP :: Maybe SockAddr -> Time.Wen
-> RIO e (Maybe SockAddr, Time.Wen)
checkIP lastIP lastLookupTime = do
current <- io $ Time.now
if (Time.gap current lastLookupTime ^. Time.secs) < 300
then pure (lastIP, lastLookupTime)
else do
toCheck <- fromMaybe [] <$> atomically (readTVar turfVar)
mybIp <- resolveFirstIP lastIP toCheck
timeAfterResolution <- io $ Time.now
pure (mybIp, timeAfterResolution)
resolveFirstIP :: Maybe SockAddr -> [Turf] -> RIO e (Maybe SockAddr)
resolveFirstIP prevIP [] = do
stderr $ "ames: czar at " ++ renderGalaxy galaxy ++ ": not found"
logDebug $ displayShow
("(ames) Failed to lookup IP for ", galaxy)
pure prevIP
resolveFirstIP prevIP (x:xs) = do
hostname <- buildDNS galaxy x
let portstr = show $ galaxyPort Real galaxy
listIPs <- io $ getAddrInfo Nothing (Just hostname) (Just portstr)
case listIPs of
[] -> resolveFirstIP prevIP xs
(y:ys) -> do
let sockaddr = Just $ addrAddress y
when (sockaddr /= prevIP) $
stderr $ "ames: czar " ++ renderGalaxy galaxy ++ ": ip " ++
(tshow $ addrAddress y)
logDebug $ displayShow
("(ames) Looked up ", hostname, portstr, y)
pure sockaddr
buildDNS :: Galaxy -> Turf -> RIO e String
buildDNS (Patp g) turf = do
let nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral g
name <- case stripPrefix "~" nameWithSig of
Nothing -> error "Urbit.ob didn't produce string with ~"
Just x -> pure (unpack x)
pure $ name ++ "." ++ (unpack $ _turfText turf)
queueSendToGalaxy :: SockAddr -> ByteString -> RIO e ()
queueSendToGalaxy inet packet = do
atomically $ writeTQueue outgoing (inet, packet)
ipv4Addr (Jammed (AAVoid v )) = absurd v
ipv4Addr (Jammed (AAIpv4 a p)) = SockAddrInet (fromIntegral p) (unIpv4 a)

217
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/DNS.hs Normal file
View File

@ -0,0 +1,217 @@
{-|
Handles sending packets to galaxies. We need to get their IP addresses
from DNS, which is more complicated.
-- Asynchronous thread per galaxy which handles domain resolution, and can
-- block its own queue of ByteStrings to send.
--
-- Maybe perform the resolution asynchronously, injecting into the resolver
-- queue as a message.
--
-- TODO: Figure out how the real haskell time library works.
-- We've failed to lookup the IP. Drop the outbound packet
-- because we have no IP for our galaxy, including possible
-- previous IPs.
{-
- Sending Packets to Galaxies.
- Each galaxy has it's own DNS resolution thread.
- Initially, no threads are started.
- To send a message to a galaxy,
- Check to see if it already has a resolution thread.
- If it does, pass the packet to that thread.
- If it doesn't, start a new thread and give it the packet.
- Galaxy resolution threads work as follows:
- First, they are given:
- They know which galaxy they are responsible for.
- They have access to the turfs TVar (shared state with Ames driver).
- They can be given packets (to be send to their galaxy).
- They must be given a way to send UDP packets.
- Next, we loop forever
- In the loop we track:
- the last-known IP address.
- the time when we last looked up the IP address.
- We wait to be given a packet.
- We get the IP address.
- If we looked up the IP address in the last 5 minute, use the
cached IP address.
- Just use the one from last time.
- Otherwise,
- Do a DNS lookup.
- Go through the turf list one item at a time.
- Try each one.
- If it resolves to one-or-more IP addresses,
- Use the first one.
- If it resolves to zero IP addresses, move on to the next turf.
- If none of the turfs can be used to resolve the IP address,
then we don't know where the galaxy is.
- Drop the packet.
-}
-}
module Urbit.Vere.Ames.DNS
( NetworkMode(..)
, ResolvServ(..)
, resolvServ
, galaxyPort
, renderGalaxy
)
where
import Urbit.Prelude
import Network.Socket hiding (recvFrom, sendTo)
import Urbit.Arvo hiding (Fake)
import qualified Data.Map as M
import qualified Urbit.Noun.Time as Time
import qualified Urbit.Ob as Ob
-- Types -----------------------------------------------------------------------
data NetworkMode = Fake | Localhost | Real | NoNetwork
deriving (Eq, Ord, Show)
data ResolvServ = ResolvServ
{ rsSend :: Galaxy -> ByteString -> IO ()
, rsKill :: IO ()
}
-- Utils -----------------------------------------------------------------------
galaxyPort :: NetworkMode -> Galaxy -> PortNumber
galaxyPort Fake (Patp g) = fromIntegral g + 31337
galaxyPort Localhost (Patp g) = fromIntegral g + 13337
galaxyPort Real (Patp g) = fromIntegral g + 13337
galaxyPort NoNetwork _ = fromIntegral 0
turfText :: Turf -> Text
turfText = intercalate "." . reverse . fmap unCord . unTurf
renderGalaxy :: Galaxy -> Text
renderGalaxy = Ob.renderPatp . Ob.patp . fromIntegral . unPatp
galaxyHostname :: Galaxy -> Turf -> Text
galaxyHostname g t = galaName g ++ "." ++ turfText t
where
stripSig :: Text -> Text
stripSig inp = fromMaybe inp (stripPrefix "~" inp)
galaName :: Galaxy -> Text
galaName = stripSig . renderGalaxy
resolv :: Galaxy -> [Turf] -> IO (Maybe (Turf, Text, PortNumber, SockAddr))
resolv gal = go
where
go = \case
[] -> pure Nothing
turf : turfs -> do
let host = galaxyHostname gal turf
port = galaxyPort Real gal
getAddrInfo Nothing (Just (unpack host)) (Just (show port)) >>= \case
[] -> go turfs
ip : _ -> pure $ Just (turf, host, port, addrAddress ip)
doResolv
:: HasLogFunc e
=> Galaxy
-> (Time.Wen, Maybe SockAddr)
-> [Turf]
-> (Text -> RIO e ())
-> RIO e (Maybe SockAddr, Time.Wen)
doResolv gal (prevWen, prevIP) turfs stderr = do
current <- io $ Time.now
if (Time.gap current prevWen ^. Time.secs) < 300
then pure (prevIP, prevWen)
else do
tim <- io (Time.now)
io (resolv gal turfs) >>= \case
Nothing -> do
stderr $ "ames: czar at " ++ galStr ++ ": not found"
logDebug $ displayShow ("(ames) Failed to lookup IP for ", gal)
pure (prevIP, tim)
Just (turf, host, port, addr) -> do
when (Just addr /= prevIP) (printCzar addr)
logDebug $ displayShow ("(ames) Looked up ", host, port, turf, addr)
pure (Just addr, tim)
where
galStr = renderGalaxy gal
printCzar addr = stderr $ "ames: czar " ++ galStr ++ ": ip " ++ tshow addr
resolvWorker
:: forall e
. HasLogFunc e
=> Galaxy
-> TVar (Maybe [Turf])
-> TVar (Time.Wen, Maybe SockAddr)
-> STM ByteString
-> (SockAddr -> ByteString -> IO ())
-> (Text -> RIO e ())
-> RIO e (Async ())
resolvWorker gal vTurfs vLast waitMsg send stderr = async (forever go)
where
logDrop =
logDebug $ displayShow ("(ames) Dropping packet; no ip for galaxy ", gal)
go :: RIO e ()
go = do
(packt, turfs, (lastTime, lastAddr)) <- atomically
((,,) <$> waitMsg <*> readTVar vTurfs <*> readTVar vLast)
(newAddr, newTime) <- doResolv gal
(lastTime, lastAddr)
(fromMaybe [] turfs)
stderr
maybe logDrop (\ip -> io (send ip packt)) newAddr
atomically $ writeTVar vLast (newTime, newAddr)
resolvServ
:: HasLogFunc e
=> TVar (Maybe [Turf])
-> (SockAddr -> ByteString -> IO ())
-> (Text -> RIO e ())
-> RIO e ResolvServ
resolvServ vTurfs send stderr = do
vGala <- newTVarIO (mempty :: Map Galaxy (Async (), TQueue ByteString))
vDead <- newTVarIO False
envir <- ask
let spawnWorker :: Galaxy -> IO (Async (), TQueue ByteString)
spawnWorker gal = runRIO envir $ do
que <- newTQueueIO
las <- newTVarIO (Time.unixEpoch, Nothing)
tid <- resolvWorker gal vTurfs las (readTQueue que) send stderr
pure (tid, que)
let getWorker :: Galaxy -> IO (Async (), TQueue ByteString)
getWorker gal = do
(fmap (lookup gal) $ atomically $ readTVar vGala) >>= \case
Just (tid, que) -> do
pure (tid, que)
Nothing -> do
(tid, que) <- spawnWorker gal
atomically $ modifyTVar' vGala (M.insert gal (tid, que))
pure (tid, que)
let doSend :: Galaxy -> ByteString -> IO ()
doSend gal byt = do
dead <- atomically (readTVar vDead)
unless dead $ do
(_, que) <- getWorker gal
atomically (writeTQueue que byt)
let doKill :: IO ()
doKill = do
galas <- atomically $ do
writeTVar vDead True
readTVar vGala
for_ galas (cancel . fst)
pure (ResolvServ doSend doKill)

243
pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs Normal file
View File

@ -0,0 +1,243 @@
{- |
Raw UDP Server used by Ames driver.
1. Opens a UDP socket and makes sure that it stays open.
- If can't open the port, wait and try again repeatedly.
- If there is an error reading or writting from the open socket,
close it and open another.
2. Receives packets from the socket.
- When packets come in from the socket, they go into a bounded queue.
- If the queue is full, the packet is dropped.
- If the socket is closed, wait and try again repeatedly.
- `usRecv` gets the first packet from the queue.
3. Sends packets to the socket.
- Packets sent to `usSend` enter a bounded queue.
- If that queue is full, the packet is dropped.
- Packets are taken off the queue one at a time.
- If the socket is closed (or broken), the packet is dropped.
4. Runs until `usKill` is run, then all threads are killed and the
socket is closed.
-}
module Urbit.Vere.Ames.UDP
( UdpServ(..)
, fakeUdpServ
, realUdpServ
)
where
import Urbit.Prelude
import Network.Socket hiding (recvFrom, sendTo)
import Control.Monad.STM (retry)
import Network.Socket.ByteString (recvFrom, sendTo)
-- Types -----------------------------------------------------------------------
data UdpServ = UdpServ
{ usSend :: SockAddr -> ByteString -> IO ()
, usRecv :: STM (PortNumber, HostAddress, ByteString)
, usKill :: IO ()
}
-- Utils -----------------------------------------------------------------------
{- |
Writes to queue and returns `True` unless the queue is full, then do
nothing and return `False`.
-}
tryWriteTBQueue :: TBQueue x -> x -> STM Bool
tryWriteTBQueue q x = do
isFullTBQueue q >>= \case
True -> pure False
False -> writeTBQueue q x $> True
{- |
Open a UDP socket and bind it to a port
-}
doBind :: PortNumber -> HostAddress -> IO (Either IOError Socket)
doBind por hos = tryIOError $ do
sok <- io $ socket AF_INET Datagram defaultProtocol
() <- io $ bind sok (SockAddrInet por hos)
pure sok
{- |
Open a UDP socket and bind it to a port.
If this fails, wait 250ms and repeat forever.
-}
forceBind :: HasLogFunc e => PortNumber -> HostAddress -> RIO e Socket
forceBind por hos = go
where
go = do
logDebug (display ("AMES: UDP: Opening socket on port " <> tshow por))
io (doBind por hos) >>= \case
Right sk -> do
logDebug (display ("AMES: UDP: Opened socket on port " <> tshow por))
pure sk
Left err -> do
logDebug (display ("AMES: UDP: " <> tshow err))
logDebug ("AMES: UDP: Failed to open UDP socket. Waiting")
threadDelay 250_000
go
{- |
Attempt to send a packet to a socket.
If it fails, return `False`. Otherwise, return `True`.
-}
sendPacket :: HasLogFunc e => ByteString -> SockAddr -> Socket -> RIO e Bool
sendPacket fullBytes adr sok = do
logDebug $ displayShow ("AMES", "UDP", "Sending packet.")
res <- io $ tryIOError $ go fullBytes
case res of
Left err -> do
logError $ displayShow ("AMES", "UDP", "Failed to send packet", err)
pure False
Right () -> do
logDebug $ displayShow ("AMES", "UDP", "Packet sent.")
pure True
where
go byt = do
sent <- sendTo sok byt adr
when (sent /= length byt) $ do
go (drop sent byt)
{- |
Attempt to receive a packet from a socket.
- If an exception is throw, return `Left exn`.
- If it wasn't an IPv4 packet, return `Right Nothing`.
- Otherwise, return `Right (Just packet)`.
-}
recvPacket
:: HasLogFunc e
=> Socket
-> RIO e (Either IOError (Maybe (ByteString, PortNumber, HostAddress)))
recvPacket sok = do
io (tryIOError $ recvFrom sok 4096) <&> \case
Left exn -> Left exn
Right (b, SockAddrInet p a) -> Right (Just (b, p, a))
Right (_, _ ) -> Right Nothing
-- Fake Server for No-Networking Mode ------------------------------------------
{- |
Fake UDP API for no-networking configurations.
-}
fakeUdpServ :: HasLogFunc e => RIO e UdpServ
fakeUdpServ = do
logDebug $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
pure UdpServ { .. }
where
usSend = \_ _ -> pure ()
usRecv = retry
usKill = pure ()
-- Real Server -----------------------------------------------------------------
{- |
Real UDP server. See module-level docs.
-}
realUdpServ
:: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ
realUdpServ por hos = do
logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.")
env <- ask
vSock <- newTVarIO Nothing
vFail <- newEmptyTMVarIO
qSend <- newTBQueueIO 100 -- TODO Tuning
qRecv <- newTBQueueIO 100 -- TODO Tuning
{-
If reading or writing to a socket fails, unbind it and tell the
socket-open thread to close it and open another.
This is careful about edge-cases. In any of these cases, do nothing.
- If vSock isn't set to the socket we used, do nothing.
- If vFail is already set (another thread signaled failure already).
-}
let signalBrokenSocket :: Socket -> RIO e ()
signalBrokenSocket sock = do
logDebug $ displayShow ("AMES", "UDP"
, "Socket broken. Requesting new socket"
)
atomically $ do
mSock <- readTVar vSock
mFail <- tryReadTMVar vFail
when (mSock == Just sock && mFail == Nothing) $ do
putTMVar vFail sock
writeTVar vSock Nothing
enqueueRecvPacket :: PortNumber -> HostAddress -> ByteString -> RIO e ()
enqueueRecvPacket p a b = do
did <- atomically (tryWriteTBQueue qRecv (p, a, b))
when (did == False) $ do
logWarn $ displayShow $ ("AMES", "UDP",)
"Dropping inbound packet because queue is full."
enqueueSendPacket :: SockAddr -> ByteString -> RIO e ()
enqueueSendPacket a b = do
did <- atomically (tryWriteTBQueue qSend (a, b))
when (did == False) $ do
logWarn "AMES: UDP: Dropping outbound packet because queue is full."
tOpen <- async $ forever $ do
sk <- forceBind por hos
atomically (writeTVar vSock (Just sk))
broken <- atomically (takeTMVar vFail)
logWarn "AMES: UDP: Closing broken socket."
io (close broken)
tSend <- async $ forever $ join $ atomically $ do
(adr, byt) <- readTBQueue qSend
readTVar vSock <&> \case
Nothing -> pure ()
Just sk -> do
okay <- sendPacket byt adr sk
unless okay (signalBrokenSocket sk)
tRecv <- async $ forever $ do
atomically (readTVar vSock) >>= \case
Nothing -> threadDelay 100_000
Just sk -> do
recvPacket sk >>= \case
Left exn -> do
logError "AMES: UDP: Failed to receive packet"
signalBrokenSocket sk
Right Nothing -> do
logError "AMES: UDP: Dropping non-ipv4 packet"
pure ()
Right (Just (b, p, a)) -> do
logDebug "AMES: UDP: Received packet."
enqueueRecvPacket p a b
let shutdown = do
logDebug "AMES: UDP: Shutting down. (killing threads)"
cancel tOpen
cancel tSend
cancel tRecv
logDebug "AMES: UDP: Shutting down. (closing socket)"
io $ join $ atomically $ do
res <- readTVar vSock <&> maybe (pure ()) close
writeTVar vSock Nothing
pure res
pure $ UdpServ { usSend = \a b -> runRIO env (enqueueSendPacket a b)
, usRecv = readTBQueue qRecv
, usKill = runRIO env shutdown
}

44
pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs
View File

@ -2,21 +2,33 @@
Behn: Timer Driver
-}
module Urbit.Vere.Behn (behn) where
module Urbit.Vere.Behn (behn, DriverApi(..), behn') where
import Urbit.Arvo hiding (Behn)
import Urbit.Prelude
import Urbit.Vere.Pier.Types
import Urbit.Time (Wen)
import Urbit.Timer (Timer)
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.Noun.Time (Wen)
import Urbit.Timer (Timer)
import qualified Urbit.Time as Time
import qualified Urbit.Timer as Timer
import qualified Urbit.Noun.Time as Time
import qualified Urbit.Timer as Timer
-- Behn Stuff ------------------------------------------------------------------
behn' :: HasPierEnv e => RIO e ([Ev], RAcquire e (DriverApi BehnEf))
behn' = do
env <- ask
pure ([bornEv (fromIntegral (env ^. kingIdL))], runDriver env)
where
runDriver env = do
ventQ :: TQueue EvErr <- newTQueueIO
diOnEffect <- liftAcquire (behn env (writeTQueue ventQ))
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
bornEv :: KingId -> Ev
bornEv king = EvBlip $ BlipEvBehn $ BehnEvBorn (king, ()) ()
@ -25,16 +37,22 @@ wakeEv = EvBlip $ BlipEvBehn $ BehnEvWake () ()
sysTime = view Time.systemTime
behn :: KingId -> QueueEv -> ([Ev], Acquire (EffCb e BehnEf))
behn king enqueueEv =
(initialEvents, runBehn)
where
initialEvents = [bornEv king]
wakeErr :: WorkError -> IO ()
wakeErr _ = pure ()
runBehn :: Acquire (EffCb e BehnEf)
behn
:: HasKingId e
=> e
-> (EvErr -> STM ())
-> Acquire (BehnEf -> IO ())
behn env enqueueEv = runBehn
where
king = fromIntegral (env ^. kingIdL)
runBehn :: Acquire (BehnEf -> IO ())
runBehn = do
tim <- mkAcquire Timer.init Timer.stop
pure (handleEf tim)
pure (runRIO env . handleEf tim)
handleEf :: Timer -> BehnEf -> RIO e ()
handleEf b = io . \case
@ -45,4 +63,4 @@ behn king enqueueEv =
doze :: Timer -> Maybe Wen -> IO ()
doze tim = \case
Nothing -> Timer.stop tim
Just t -> Timer.start tim (sysTime t) $ atomically (enqueueEv wakeEv)
Just t -> Timer.start tim (sysTime t) $ atomically (enqueueEv (EvErr wakeEv wakeErr))

67
pkg/hs/urbit-king/lib/Urbit/Vere/Clay.hs
View File

@ -2,10 +2,14 @@
UNIX Filesystem Driver
-}
module Urbit.Vere.Clay (clay) where
module Urbit.Vere.Clay
( clay
, clay'
)
where
import Urbit.Arvo hiding (Term)
import Urbit.King.Config
import Urbit.King.App
import Urbit.Prelude
import Urbit.Vere.Pier.Types
@ -112,26 +116,52 @@ buildActionListFromDifferences fp snapshot = do
--------------------------------------------------------------------------------
clay :: forall e. (HasPierConfig e, HasLogFunc e)
=> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e SyncEf))
clay king enqueueEv =
_boatFailed :: e -> WorkError -> IO ()
_boatFailed env _ = runRIO env $ do
pure () -- TODO What can we do?
clay'
:: HasPierEnv e
=> RIO e ([Ev], RAcquire e (DriverApi SyncEf))
clay' = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = clay env (writeTQueue ventQ)
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
clay
:: forall e
. (HasPierConfig e, HasLogFunc e, HasKingId e)
=> e
-> (EvErr -> STM ())
-> ([Ev], RAcquire e (SyncEf -> IO ()))
clay env plan =
(initialEvents, runSync)
where
initialEvents = [
EvBlip $ BlipEvBoat $ BoatEvBoat () ()
-- TODO: In the case of -A, we need to read all the data from the
-- specified directory and shove it into an %into event.
]
king = fromIntegral (env ^. kingIdL)
runSync :: RAcquire e (EffCb e SyncEf)
boatEv = EvBlip $ BlipEvBoat $ BoatEvBoat () ()
-- TODO: In the case of -A, we need to read all the data from the
-- specified directory and shove it into an %into event.
initialEvents = [boatEv]
runSync :: RAcquire e (SyncEf -> IO ())
runSync = handleEffect <$> mkRAcquire start stop
start :: RIO e ClayDrv
start = ClayDrv <$> newTVarIO mempty
stop c = pure ()
handleEffect :: ClayDrv -> SyncEf -> RIO e ()
handleEffect cd = \case
handleEffect :: ClayDrv -> SyncEf -> IO ()
handleEffect cd = runRIO env . \case
SyncEfHill _ mountPoints -> do
logDebug $ displayShow ("(clay) known mount points:", mountPoints)
pierPath <- view pierPathL
@ -151,8 +181,15 @@ clay king enqueueEv =
logDebug $ displayShow ("(clay) dirk actions: ", actions)
let !intoList = map (actionsToInto dir) actions
atomically $ enqueueEv $ EvBlip $ BlipEvSync $
SyncEvInto (Some (king, ())) desk False intoList
let syncEv = EvBlip
$ BlipEvSync
$ SyncEvInto (Some (king, ())) desk False intoList
let syncFailed _ = pure ()
atomically $ plan (EvErr syncEv syncFailed)
atomically $ modifyTVar
(cdMountPoints cd)

364
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs Normal file
View File

@ -0,0 +1,364 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre
( eyre
, eyre'
)
where
import Urbit.Prelude hiding (Builder)
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
import Urbit.King.App (HasKingId(..), HasPierEnv(..))
import Urbit.King.Config
import Urbit.Vere.Eyre.Multi
import Urbit.Vere.Eyre.PortsFile
import Urbit.Vere.Eyre.Serv
import Urbit.Vere.Eyre.Service
import Urbit.Vere.Eyre.Wai
import Urbit.Vere.Pier.Types
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.PEM (pemParseBS, pemWriteBS)
import RIO.Prelude (decodeUtf8Lenient)
import System.Random (randomIO)
import Urbit.Vere.Http (convertHeaders, unconvertHeaders)
import qualified Network.HTTP.Types as H
-- Types -----------------------------------------------------------------------
type HasShipEnv e = (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
type ReqId = UD
newtype Drv = Drv (MVar (Maybe Serv))
data SockOpts = SockOpts
{ soLocalhost :: Bool
, soWhich :: ServPort
}
data PortsToTry = PortsToTry
{ pttSec :: SockOpts
, pttIns :: SockOpts
, pttLop :: SockOpts
}
data Serv = Serv
{ sServId :: ServId
, sConfig :: HttpServerConf
, sLop :: ServApi
, sIns :: ServApi
, sSec :: Maybe ServApi
, sPorts :: Ports
, sPortsFile :: FilePath
, sLiveReqs :: TVar LiveReqs
}
-- Utilities for Constructing Events -------------------------------------------
servEv :: HttpServerEv -> Ev
servEv = EvBlip . BlipEvHttpServer
bornEv :: KingId -> Ev
bornEv king = servEv $ HttpServerEvBorn (king, ()) ()
liveEv :: ServId -> Ports -> Ev
liveEv sId Ports {..} = servEv $ HttpServerEvLive (sId, ()) pHttp pHttps
cancelEv :: ServId -> ReqId -> EvErr
cancelEv sId reqId =
EvErr (servEv (HttpServerEvCancelRequest (sId, reqId, 1, ()) ())) cancelFailed
cancelFailed :: WorkError -> IO ()
cancelFailed _ = pure ()
reqEv :: ServId -> ReqId -> WhichServer -> Address -> HttpRequest -> Ev
reqEv sId reqId which addr req = case which of
Loopback -> servEv $ HttpServerEvRequestLocal (sId, reqId, 1, ())
$ HttpServerReq False addr req
_ -> servEv $ HttpServerEvRequest (sId, reqId, 1, ())
$ HttpServerReq (which == Secure) addr req
-- Based on Pier+Config, which ports should each server run? -------------------
httpServerPorts :: HasShipEnv e => Bool -> RIO e PortsToTry
httpServerPorts fak = do
ins <- view (networkConfigL . ncHttpPort . to (fmap fromIntegral))
sec <- view (networkConfigL . ncHttpsPort . to (fmap fromIntegral))
lop <- view (networkConfigL . ncLocalPort . to (fmap fromIntegral))
localMode <- view (networkConfigL . ncNetMode . to (== NMLocalhost))
let local = localMode || fak
let pttSec = case (sec, fak) of
(Just p , _ ) -> SockOpts local (SPChoices $ singleton p)
(Nothing, False) -> SockOpts local (SPChoices (443 :| [8443 .. 8453]))
(Nothing, True ) -> SockOpts local (SPChoices (8443 :| [8444 .. 8453]))
let pttIns = case (ins, fak) of
(Just p , _ ) -> SockOpts local (SPChoices $ singleton p)
(Nothing, False) -> SockOpts local (SPChoices (80 :| [8080 .. 8090]))
(Nothing, True ) -> SockOpts local (SPChoices (8080 :| [8081 .. 8090]))
let pttLop = case (lop, fak) of
(Just p , _) -> SockOpts local (SPChoices $ singleton p)
(Nothing, _) -> SockOpts local SPAnyPort
pure (PortsToTry { .. })
-- Convert Between Urbit and WAI types. ----------------------------------------
parseTlsConfig :: (Key, Cert) -> Maybe TlsConfig
parseTlsConfig (PEM key, PEM certs) = do
let (cerByt, keyByt) = (wainBytes certs, wainBytes key)
pems <- pemParseBS cerByt & either (const Nothing) Just
(cert, chain) <- case pems of
[] -> Nothing
p : ps -> pure (pemWriteBS p, pemWriteBS <$> ps)
pure $ TlsConfig keyByt cert chain
where
wainBytes :: Wain -> ByteString
wainBytes = encodeUtf8 . unWain
parseHttpEvent :: HttpEvent -> [RespAct]
parseHttpEvent = \case
Start h b True -> [RAFull (hSta h) (hHdr h) (fByt $ fromMaybe "" b)]
Start h b False -> [RAHead (hSta h) (hHdr h) (fByt $ fromMaybe "" b)]
Cancel () -> [RADone]
Continue b done -> toList (RABloc . fByt <$> b)
<> if done then [RADone] else []
where
hHdr :: ResponseHeader -> [H.Header]
hHdr = unconvertHeaders . headers
hSta :: ResponseHeader -> H.Status
hSta = toEnum . fromIntegral . statusCode
fByt :: File -> ByteString
fByt = unOcts . unFile
requestEvent :: ServId -> WhichServer -> Word64 -> ReqInfo -> Ev
requestEvent srvId which reqId ReqInfo{..} = reqEv srvId reqUd which riAdr evReq
where
evBod = bodFile riBod
evHdr = convertHeaders riHdr
evUrl = Cord (decodeUtf8Lenient riUrl)
evReq = HttpRequest riMet evUrl evHdr evBod
reqUd = fromIntegral reqId
bodFile :: ByteString -> Maybe File
bodFile "" = Nothing
bodFile bs = Just $ File $ Octs bs
-- Running Servers -------------------------------------------------------------
execRespActs :: HasLogFunc e => Drv -> Ship -> Word64 -> HttpEvent -> RIO e ()
execRespActs (Drv v) who reqId ev = readMVar v >>= \case
Nothing -> logError "Got a response to a request that does not exist."
Just sv -> do
logDebug $ displayShow ev
for_ (parseHttpEvent ev) $ \act -> do
atomically (routeRespAct who (sLiveReqs sv) reqId act)
startServ
:: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
=> MultiEyreApi
-> Ship
-> Bool
-> HttpServerConf
-> (EvErr -> STM ())
-> RIO e Serv
startServ multi who isFake conf plan = do
logDebug (displayShow ("EYRE", "startServ"))
let vLive = meaLive multi
srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
let mTls = hscSecure conf >>= parseTlsConfig
mCre <- mTls & \case
Nothing -> pure Nothing
Just tc -> configCreds tc & \case
Right rs -> pure (Just (tc, rs))
Left err -> do
logError "Couldn't Load TLS Credentials."
pure Nothing
ptt <- httpServerPorts isFake
{-
TODO If configuration requests a redirect, get the HTTPS port (if
configuration specifies a specific port, use that. Otherwise, wait
for the HTTPS server to start and then use the port that it chose).
and run an HTTP server that simply redirects to the HTTPS server.
-}
let secRedi = Nothing
let soHost :: SockOpts -> ServHost
soHost so = if soLocalhost so then SHLocalhost else SHAnyHostOk
noHttp <- view (networkConfigL . ncNoHttp)
noHttps <- view (networkConfigL . ncNoHttps)
let reqEvFailed _ = pure ()
let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
onReq which _ship reqId reqInfo =
plan $ EvErr (requestEvent srvId which reqId reqInfo) reqEvFailed
let onKilReq :: Ship -> Word64 -> STM ()
onKilReq _ship = plan . cancelEv srvId . fromIntegral
logDebug (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
atomically (joinMultiEyre multi who mCre onReq onKilReq)
logDebug $ displayShow ("EYRE", "Starting loopback server")
lop <- serv vLive $ ServConf
{ scHost = soHost (pttLop ptt)
, scPort = soWhich (pttLop ptt)
, scRedi = Nothing
, scFake = False
, scType = STHttp who $ ReqApi
{ rcReq = onReq Loopback
, rcKil = onKilReq
}
}
logDebug $ displayShow ("EYRE", "Starting insecure server")
ins <- serv vLive $ ServConf
{ scHost = soHost (pttIns ptt)
, scPort = soWhich (pttIns ptt)
, scRedi = secRedi
, scFake = noHttp
, scType = STHttp who $ ReqApi
{ rcReq = onReq Insecure
, rcKil = onKilReq
}
}
mSec <- for mTls $ \tls -> do
logDebug "Starting secure server"
serv vLive $ ServConf
{ scHost = soHost (pttSec ptt)
, scPort = soWhich (pttSec ptt)
, scRedi = Nothing
, scFake = noHttps
, scType = STHttps who tls $ ReqApi
{ rcReq = onReq Secure
, rcKil = onKilReq
}
}
pierPath <- view pierPathL
lopPor <- atomically (fmap fromIntegral $ saPor lop)
insPor <- atomically (fmap fromIntegral $ saPor ins)
secPor <- for mSec (fmap fromIntegral . atomically . saPor)
let por = Ports secPor insPor lopPor
fil = pierPath <> "/.http.ports"
logDebug $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
pure (Serv srvId conf lop ins mSec por fil vLive)
-- Eyre Driver -----------------------------------------------------------------
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
pure () -- TODO What should this do?
eyre'
:: HasPierEnv e
=> MultiEyreApi
-> Ship
-> Bool
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
eyre' multi who isFake = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = eyre env multi who (writeTQueue ventQ) isFake
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
{-|
Eyre -- HTTP Server Driver
Inject born events.
Until born events succeeds, ignore effects.
Wait until born event callbacks invoked.
If success, signal success.
If failure, try again several times.
If still failure, bring down ship.
Once born event succeeds:
- Begin normal operation (start accepting requests)
-}
eyre
:: forall e
. (HasPierEnv e)
=> e
-> MultiEyreApi
-> Ship
-> (EvErr -> STM ())
-> Bool
-> ([Ev], RAcquire e (HttpServerEf -> IO ()))
eyre env multi who plan isFake = (initialEvents, runHttpServer)
where
king = fromIntegral (env ^. kingIdL)
initialEvents :: [Ev]
initialEvents = [bornEv king]
runHttpServer :: RAcquire e (HttpServerEf -> IO ())
runHttpServer = handleEf <$> mkRAcquire
(Drv <$> newMVar Nothing)
(\(Drv v) -> stopService v kill >>= fromEither)
kill :: HasLogFunc e => Serv -> RIO e ()
kill Serv{..} = do
atomically (leaveMultiEyre multi who)
atomically (saKil sLop)
atomically (saKil sIns)
for_ sSec (\sec -> atomically (saKil sec))
io (removePortsFile sPortsFile)
restart :: Drv -> HttpServerConf -> RIO e Serv
restart (Drv var) conf = do
logDebug "Restarting http server"
let startAct = startServ multi who isFake conf plan
res <- fromEither =<< restartService var startAct kill
logDebug "Done restating http server"
pure res
liveFailed _ = pure ()
handleEf :: Drv -> HttpServerEf -> IO ()
handleEf drv = runRIO env . \case
HSESetConfig (i, ()) conf -> do
logDebug (displayShow ("EYRE", "%set-config"))
Serv {..} <- restart drv conf
logDebug (displayShow ("EYRE", "%set-config", "Sending %live"))
atomically $ plan (EvErr (liveEv sServId sPorts) liveFailed)
logDebug "Write ports file"
io (writePortsFile sPortsFile sPorts)
HSEResponse (i, req, _seq, ()) ev -> do
logDebug (displayShow ("EYRE", "%response"))
execRespActs drv who (fromIntegral req) ev

131
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs Normal file
View File

@ -0,0 +1,131 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre.Multi
( WhichServer(..)
, MultiEyreConf(..)
, OnMultiReq
, OnMultiKil
, MultiEyreApi(..)
, joinMultiEyre
, leaveMultiEyre
, multiEyre
)
where
import Urbit.Prelude hiding (Builder)
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
import Urbit.Vere.Eyre.Serv
import Urbit.Vere.Eyre.Wai
import Network.TLS (Credential)
-- Types -----------------------------------------------------------------------
data WhichServer = Secure | Insecure | Loopback
deriving (Eq)
data MultiEyreConf = MultiEyreConf
{ mecHttpsPort :: Maybe Port
, mecHttpPort :: Maybe Port
, mecLocalhostOnly :: Bool
}
deriving (Show)
type OnMultiReq = WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
type OnMultiKil = Ship -> Word64 -> STM ()
data MultiEyreApi = MultiEyreApi
{ meaConf :: MultiEyreConf
, meaLive :: TVar LiveReqs
, meaPlan :: TVar (Map Ship OnMultiReq)
, meaCanc :: TVar (Map Ship OnMultiKil)
, meaTlsC :: TVar (Map Ship (TlsConfig, Credential))
, meaKill :: STM ()
}
-- Multi-Tenet HTTP ------------------------------------------------------------
joinMultiEyre
:: MultiEyreApi
-> Ship
-> Maybe (TlsConfig, Credential)
-> OnMultiReq
-> OnMultiKil
-> STM ()
joinMultiEyre api who mTls onReq onKil = do
modifyTVar' (meaPlan api) (insertMap who onReq)
modifyTVar' (meaCanc api) (insertMap who onKil)
for_ mTls $ \creds -> do
modifyTVar' (meaTlsC api) (insertMap who creds)
leaveMultiEyre :: MultiEyreApi -> Ship -> STM ()
leaveMultiEyre MultiEyreApi {..} who = do
modifyTVar' meaCanc (deleteMap who)
modifyTVar' meaPlan (deleteMap who)
modifyTVar' meaTlsC (deleteMap who)
multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
multiEyre conf@MultiEyreConf {..} = do
logDebug (displayShow ("EYRE", "MULTI", conf))
vLive <- io emptyLiveReqs >>= newTVarIO
vPlan <- newTVarIO mempty
vCanc <- newTVarIO (mempty :: Map Ship (Ship -> Word64 -> STM ()))
vTlsC <- newTVarIO mempty
let host = if mecLocalhostOnly then SHLocalhost else SHAnyHostOk
let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
onReq which who reqId reqInfo = do
plan <- readTVar vPlan
lookup who plan & \case
Nothing -> pure ()
Just cb -> cb which who reqId reqInfo
let onKil :: Ship -> Word64 -> STM ()
onKil who reqId = do
canc <- readTVar vCanc
lookup who canc & \case
Nothing -> pure ()
Just cb -> cb who reqId
mIns <- for mecHttpPort $ \por -> do
logDebug (displayShow ("EYRE", "MULTI", "HTTP", por))
serv vLive $ ServConf
{ scHost = host
, scPort = SPChoices $ singleton $ fromIntegral por
, scRedi = Nothing -- TODO
, scFake = False
, scType = STMultiHttp $ ReqApi
{ rcReq = onReq Insecure
, rcKil = onKil
}
}
mSec <- for mecHttpsPort $ \por -> do
logDebug (displayShow ("EYRE", "MULTI", "HTTPS", por))
serv vLive $ ServConf
{ scHost = host
, scPort = SPChoices $ singleton $ fromIntegral por
, scRedi = Nothing
, scFake = False
, scType = STMultiHttps (MTC vTlsC) $ ReqApi
{ rcReq = onReq Secure
, rcKil = onKil
}
}
pure $ MultiEyreApi
{ meaLive = vLive
, meaPlan = vPlan
, meaCanc = vCanc
, meaTlsC = vTlsC
, meaConf = conf
, meaKill = traverse_ saKil (toList mIns <> toList mSec)
}

44
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/PortsFile.hs Normal file
View File

@ -0,0 +1,44 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre.PortsFile
( Ports(..)
, writePortsFile
, removePortsFile
)
where
import Urbit.Prelude
import System.Directory (doesFileExist, removeFile)
import Urbit.Arvo (Port(unPort))
-- Types -----------------------------------------------------------------------
data Ports = Ports
{ pHttps :: Maybe Port
, pHttp :: Port
, pLoop :: Port
}
deriving (Eq, Ord, Show)
-- Creating and Deleting `.http.ports` files. ----------------------------------
portsFileText :: Ports -> Text
portsFileText Ports {..} = unlines $ catMaybes
[ pHttps <&> \p -> (tshow p <> " secure public")
, Just (tshow (unPort pHttp) <> " insecure public")
, Just (tshow (unPort pLoop) <> " insecure loopback")
]
removePortsFile :: FilePath -> IO ()
removePortsFile pax = do
doesFileExist pax >>= \case
True -> removeFile pax
False -> pure ()
writePortsFile :: FilePath -> Ports -> IO ()
writePortsFile f = writeFile f . encodeUtf8 . portsFileText

356
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs Normal file
View File

@ -0,0 +1,356 @@
{-|
Runs a single HTTP (or HTTPS) server for the eyre driver.
A server is given:
- A port, or a range or ports.
- Opens a socket on one of those ports.
- If this fails, try again repeatedly.
- Once a socket is opened, runs an HTTP server on the specified port.
- Once the server is up, calls a callback with the port that was opened.
- Once we have chosen a port, we commit to that port (ignoring the
original range).
- If the socket ever goes down, keep trying to reopen that port forever.
- When the server is shutdown, make sure the socket is closed.
TODO How to detect socket closed during server run?
-}
{-# OPTIONS_GHC -Wno-deprecations #-}
module Urbit.Vere.Eyre.Serv
( ServApi(..)
, TlsConfig(..)
, MultiTlsConfig(..)
, ReqApi(..)
, ServType(..)
, ServPort(..)
, ServHost(..)
, ServConf(..)
, configCreds
, serv
, fakeServ
)
where
import Urbit.Prelude hiding (Builder)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty((:|)))
import Network.TLS (Credential, Credentials(..), ServerHooks(..))
import Network.TLS (credentialLoadX509ChainFromMemory)
import RIO.Prelude (decodeUtf8Lenient)
import qualified Control.Monad.STM as STM
import qualified Data.Char as C
import qualified Network.Socket as Net
import qualified Network.Wai as W
import qualified Network.Wai.Handler.Warp as W
import qualified Network.Wai.Handler.WarpTLS as W
import qualified Urbit.Ob as Ob
import qualified Urbit.Vere.Eyre.Wai as E
-- Internal Types --------------------------------------------------------------
data ServApi = ServApi
{ saKil :: STM ()
, saPor :: STM W.Port
}
data TlsConfig = TlsConfig
{ tcPrKey :: ByteString
, tcCerti :: ByteString
, tcChain :: [ByteString]
}
deriving (Show)
newtype MultiTlsConfig = MTC (TVar (Map Ship (TlsConfig, Credential)))
instance Show MultiTlsConfig where
show = const "MultiTlsConfig"
data ReqApi = ReqApi
{ rcReq :: Ship -> Word64 -> E.ReqInfo -> STM ()
, rcKil :: Ship -> Word64 -> STM ()
}
instance Show ReqApi where
show = const "ReqApi"
data ServType
= STHttp Ship ReqApi
| STHttps Ship TlsConfig ReqApi
| STMultiHttp ReqApi
| STMultiHttps MultiTlsConfig ReqApi
deriving (Show)
data ServPort
= SPAnyPort
| SPChoices (NonEmpty W.Port)
deriving (Show)
data ServHost
= SHLocalhost
| SHAnyHostOk
deriving (Show)
data ServConf = ServConf
{ scType :: ServType
, scHost :: ServHost
, scPort :: ServPort
, scRedi :: Maybe W.Port
, scFake :: Bool
}
deriving (Show)
-- Opening Sockets -------------------------------------------------------------
getBindAddr :: String -> W.Port -> IO Net.SockAddr
getBindAddr hos por =
Net.getAddrInfo Nothing (Just hos) (Just (show por)) >>= \case
[] -> error "this should never happen."
x : _ -> pure (Net.addrAddress x)
bindListenPort :: String -> W.Port -> Net.Socket -> IO Net.PortNumber
bindListenPort hos por sok = do
Net.bind sok =<< getBindAddr hos por
Net.listen sok 1
Net.socketPort sok
tcpSocket :: IO (Either IOError Net.Socket)
tcpSocket =
tryIOError (Net.socket Net.AF_INET Net.Stream Net.defaultProtocol)
tryOpen :: String -> W.Port -> IO (Either IOError (W.Port, Net.Socket))
tryOpen hos por =
tcpSocket >>= \case
Left exn -> pure (Left exn)
Right sok -> tryIOError (bindListenPort hos por sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right por -> pure (Right (fromIntegral por, sok))
openFreePort :: String -> IO (Either IOError (W.Port, Net.Socket))
openFreePort hos = do
tcpSocket >>= \case
Left exn -> pure (Left exn)
Right sok -> tryIOError (doBind sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right ps -> pure (Right ps)
where
doBind sok = do
adr <- Net.inet_addr hos
Net.bind sok (Net.SockAddrInet Net.defaultPort adr)
Net.listen sok 1
port <- Net.socketPort sok
pure (fromIntegral port, sok)
retry :: HasLogFunc e => RIO e (Either IOError a) -> RIO e a
retry act = act >>= \case
Right res -> pure res
Left exn -> do
logDbg ctx ("Failed to open ports. Waiting 5s, then trying again.", exn)
threadDelay 5_000_000
retry act
where
ctx = ["EYRE", "SERV", "retry"]
tryOpenChoices
:: HasLogFunc e
=> String
-> NonEmpty W.Port
-> RIO e (Either IOError (W.Port, Net.Socket))
tryOpenChoices hos = go
where
go (p :| ps) = do
logDebug (displayShow ("EYRE", "Trying to open port.", p))
io (tryOpen hos p) >>= \case
Left err -> do
logError (displayShow ("EYRE", "Failed to open port.", p))
case ps of
[] -> pure (Left err)
q : qs -> go (q :| qs)
Right (p, s) -> do
pure (Right (p, s))
tryOpenAny
:: HasLogFunc e => String -> RIO e (Either IOError (W.Port, Net.Socket))
tryOpenAny hos = do
let ctx = ["EYRE", "SERV", "tryOpenAny"]
logDbg ctx "Asking the OS for any free port."
io (openFreePort hos) >>= \case
Left exn -> pure (Left exn)
Right (p, s) -> do
pure (Right (p, s))
logDbg :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e ()
logDbg ctx msg = logDebug (prefix <> suffix)
where
prefix = display (concat $ fmap (<> ": ") ctx)
suffix = displayShow msg
forceOpenSocket
:: forall e
. HasLogFunc e
=> ServHost
-> ServPort
-> RAcquire e (W.Port, Net.Socket)
forceOpenSocket hos por = mkRAcquire opn kil
where
kil = io . Net.close . snd
opn = do
let ctx = ["EYRE", "SERV", "forceOpenSocket"]
logDbg ctx (hos, por)
(p, s) <- retry $ case por of
SPAnyPort -> tryOpenAny bind
SPChoices ps -> tryOpenChoices bind ps
logDbg ctx ("Opened port.", p)
pure (p, s)
bind = case hos of
SHLocalhost -> "127.0.0.1"
SHAnyHostOk -> "0.0.0.0"
-- Starting WAI ----------------------------------------------------------------
hostShip :: Maybe ByteString -> IO Ship
hostShip Nothing = error "Request must contain HOST header."
hostShip (Just bs) = byteShip (hedLabel bs) & \case
Left err -> error ("Bad host prefix. Must be a ship name: " <> unpack err)
Right sp -> pure sp
where
byteShip = fmap (fromIntegral . Ob.fromPatp) . bytePatp
bytePatp = Ob.parsePatp . decodeUtf8Lenient
hedLabel = fst . break (== fromIntegral (C.ord '.'))
onSniHdr
:: HasLogFunc e => e -> MultiTlsConfig -> Maybe String -> IO Credentials
onSniHdr env (MTC mtls) mHos = do
tabl <- atomically (readTVar mtls)
runRIO env $ logDbg ctx (tabl, mHos)
ship <- hostShip (encodeUtf8 . pack <$> mHos)
runRIO env $ logDbg ctx ship
tcfg <- lookup ship tabl & maybe (notRunning ship) (pure . snd)
runRIO env $ logDbg ctx tcfg
pure (Credentials [tcfg])
where
notRunning ship = error ("Ship not running: ~" <> show ship)
ctx = ["EYRE", "HTTPS", "SNI"]
startServer
:: HasLogFunc e
=> ServType
-> ServHost
-> W.Port
-> Net.Socket
-> Maybe W.Port
-> TVar E.LiveReqs
-> RIO e ()
startServer typ hos por sok red vLive = do
envir <- ask
let host = case hos of
SHLocalhost -> "127.0.0.1"
SHAnyHostOk -> "*"
let opts =
W.defaultSettings
& W.setHost host
& W.setPort (fromIntegral por)
& W.setTimeout (5 * 60)
let runAppl who = E.app envir who vLive
reqShip = hostShip . W.requestHeaderHost
case typ of
STHttp who api -> do
let app = runAppl who (rcReq api who) (rcKil api who)
io (W.runSettingsSocket opts sok app)
STHttps who TlsConfig {..} api -> do
let tls = W.tlsSettingsChainMemory tcCerti tcChain tcPrKey
let app = runAppl who (rcReq api who) (rcKil api who)
io (W.runTLSSocket tls opts sok app)
STMultiHttp api -> do
let app req resp = do
who <- reqShip req
runAppl who (rcReq api who) (rcKil api who) req resp
io (W.runSettingsSocket opts sok app)
STMultiHttps mtls api -> do
TlsConfig {..} <- atomically (getFirstTlsConfig mtls)
let sni = def { onServerNameIndication = onSniHdr envir mtls }
let tlsSing = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey)
let tlsMany = tlsSing { W.tlsServerHooks = sni }
let ctx = ["EYRE", "HTTPS", "REQ"]
let
app = \req resp -> do
runRIO envir $ logDbg ctx "Got request"
who <- reqShip req
runRIO envir $ logDbg ctx ("Parsed HOST", who)
runAppl who (rcReq api who) (rcKil api who) req resp
io (W.runTLSSocket tlsMany opts sok app)
--------------------------------------------------------------------------------
configCreds :: TlsConfig -> Either Text Credential
configCreds TlsConfig {..} =
credentialLoadX509ChainFromMemory tcCerti tcChain tcPrKey & \case
Left str -> Left (pack str)
Right rs -> Right rs
fakeServ :: HasLogFunc e => ServConf -> RIO e ServApi
fakeServ conf = do
let por = fakePort (scPort conf)
logDebug (displayShow ("EYRE", "SERV", "Running Fake Server", por))
pure $ ServApi
{ saKil = pure ()
, saPor = pure por
}
where
fakePort :: ServPort -> W.Port
fakePort SPAnyPort = 55555
fakePort (SPChoices (x :| _)) = x
getFirstTlsConfig :: MultiTlsConfig -> STM TlsConfig
getFirstTlsConfig (MTC var) = do
map <- readTVar var
case toList map of
[] -> STM.retry
x:_ -> pure (fst x)
realServ :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
realServ vLive conf@ServConf {..} = do
logDebug (displayShow ("EYRE", "SERV", "Running Real Server"))
kil <- newEmptyTMVarIO
por <- newEmptyTMVarIO
tid <- async (runServ por)
_ <- async (atomically (takeTMVar kil) >> cancel tid)
pure $ ServApi
{ saKil = void (tryPutTMVar kil ())
, saPor = readTMVar por
}
where
runServ vPort = do
logDebug (displayShow ("EYRE", "SERV", "runServ"))
rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
atomically (putTMVar vPort por)
startServer scType scHost por sok scRedi vLive
serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
serv vLive conf = do
if scFake conf
then fakeServ conf
else realServ vLive conf

67
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Service.hs Normal file
View File

@ -0,0 +1,67 @@
{-|
Eyre: Http Server Driver
-}
module Urbit.Vere.Eyre.Service
( restartService
, stopService
)
where
import Urbit.Prelude
-- Generic Service Stop/Restart -- Using an MVar for Atomicity -----------------
{-|
Restart a running service.
This can probably be made simpler, but it
- Sets the MVar to Nothing if there was an exception while starting
or stopping the service.
- Keeps the MVar lock until the restart process finishes.
-}
restartService
:: forall e s
. HasLogFunc e
=> MVar (Maybe s)
-> RIO e s
-> (s -> RIO e ())
-> RIO e (Either SomeException s)
restartService vServ sstart kkill = do
logDebug "restartService"
modifyMVar vServ $ \case
Nothing -> doStart
Just sv -> doRestart sv
where
doRestart :: s -> RIO e (Maybe s, Either SomeException s)
doRestart serv = do
logDebug "doStart"
try (kkill serv) >>= \case
Left exn -> pure (Nothing, Left exn)
Right () -> doStart
doStart :: RIO e (Maybe s, Either SomeException s)
doStart = do
logDebug "doStart"
try sstart <&> \case
Right s -> (Just s, Right s)
Left exn -> (Nothing, Left exn)
{-|
Stop a running service. Do nothing if it's already stopped.
-}
stopService
:: HasLogFunc e
=> MVar (Maybe s)
-> (s -> RIO e ())
-> RIO e (Either SomeException ())
stopService vServ kkill = do
logDebug "stopService"
modifyMVar vServ $ \case
Nothing -> pure (Nothing, Right ())
Just sv -> do
res <- try (kkill sv)
pure (Nothing, res)

229
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs Normal file
View File

@ -0,0 +1,229 @@
{-|
WAI Application for `eyre` driver.
# Request Lifecycles
- Requests come in, are given an identifier and are passed to a callback.
- When requests timeout, the identifier is passed to anothing callback.
- The server pulls response actions, and passes them to the associated
request.
-}
module Urbit.Vere.Eyre.Wai
( RespAct(..)
, RespApi(..)
, LiveReqs(..)
, ReqInfo(..)
, emptyLiveReqs
, routeRespAct
, rmLiveReq
, newLiveReq
, app
)
where
import Urbit.Prelude hiding (Builder)
import Data.Binary.Builder (Builder, fromByteString)
import Data.Bits (shiftL, (.|.))
import Data.Conduit (ConduitT, Flush(Chunk, Flush), yield)
import Network.Socket (SockAddr(..))
import System.Random (newStdGen, randoms)
import Urbit.Arvo (Address(..), Ipv4(..), Ipv6(..), Method)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
import qualified Network.Wai.Conduit as W
-- Types -----------------------------------------------------------------------
data RespAct
= RAFull H.Status [H.Header] ByteString
| RAHead H.Status [H.Header] ByteString
| RABloc ByteString
| RADone
deriving (Eq, Ord, Show)
data RespApi = RespApi
{ raAct :: RespAct -> STM Bool
, raKil :: STM ()
}
data LiveReqs = LiveReqs
{ reqIdSuply :: [Word64]
, activeReqs :: Map Word64 (Ship, RespApi)
}
data ReqInfo = ReqInfo
{ riAdr :: Address
, riMet :: H.StdMethod
, riUrl :: ByteString
, riHdr :: [H.Header]
, riBod :: ByteString
}
-- Live Requests Table -- All Requests Still Waiting for Responses -------------
emptyLiveReqs :: IO LiveReqs
emptyLiveReqs = io $ do
gen <- newStdGen
pure (LiveReqs (randoms gen) mempty)
routeRespAct :: Ship -> TVar LiveReqs -> Word64 -> RespAct -> STM Bool
routeRespAct who vLiv reqId act =
(lookup reqId . activeReqs <$> readTVar vLiv) >>= \case
Nothing -> pure False
Just (own, tv) -> do
if (who == own)
then raAct tv act
else pure False
rmLiveReq :: TVar LiveReqs -> Word64 -> STM ()
rmLiveReq var reqId = modifyTVar' var
$ \liv -> liv { activeReqs = deleteMap reqId (activeReqs liv) }
allocateReqId :: TVar LiveReqs -> STM Word64
allocateReqId var = do
LiveReqs supply tbl <- readTVar var
let loop :: [Word64] -> (Word64, [Word64])
loop [] = error "impossible"
loop (x:xs) | member x tbl = loop xs
loop (x:xs) | otherwise = (x, xs)
let (fresh, supply') = loop supply
writeTVar var (LiveReqs supply' tbl)
pure fresh
newLiveReq :: Ship -> TVar LiveReqs -> STM (Word64, STM RespAct)
newLiveReq who var = do
tmv <- newTQueue
kil <- newEmptyTMVar
nex <- allocateReqId var
LiveReqs sup tbl <- readTVar var
let waitAct = (<|>) (readTMVar kil $> RADone) (readTQueue tmv)
respApi = RespApi
{ raKil = putTMVar kil ()
, raAct = \act -> tryReadTMVar kil >>= \case
Nothing -> writeTQueue tmv act $> True
Just () -> pure False
}
writeTVar var (LiveReqs sup (insertMap nex (who, respApi) tbl))
pure (nex, waitAct)
-- Random Helpers --------------------------------------------------------------
cookMeth :: W.Request -> Maybe Method
cookMeth = H.parseMethod . W.requestMethod >>> \case
Left _ -> Nothing
Right m -> Just m
reqAddr :: W.Request -> Address
reqAddr = W.remoteHost >>> \case
SockAddrInet _ a -> AIpv4 (Ipv4 a)
SockAddrInet6 _ _ a _ -> AIpv6 (mkIpv6 a)
_ -> error "invalid sock addr"
mkIpv6 :: (Word32, Word32, Word32, Word32) -> Ipv6
mkIpv6 (p, q, r, s) = Ipv6 (pBits .|. qBits .|. rBits .|. sBits)
where
pBits = shiftL (fromIntegral p) 0
qBits = shiftL (fromIntegral q) 32
rBits = shiftL (fromIntegral r) 64
sBits = shiftL (fromIntegral s) 96
reqUrl :: W.Request -> ByteString
reqUrl r = W.rawPathInfo r <> W.rawQueryString r
-- Responses -------------------------------------------------------------------
noHeader :: HasLogFunc e => RIO e a
noHeader = do
logError "Response block with no response header."
error "Bad HttpEvent: Response block with no response header."
dupHead :: HasLogFunc e => RIO e a
dupHead = do
logError "Multiple %head actions on one request"
error "Bad HttpEvent: Multiple header actions per on one request."
{-|
- Immediately yield all of the initial chunks
- Yield the data from %bloc action.
- Close the stream when we hit a %done action.
-}
streamBlocks
:: HasLogFunc e
=> e
-> ByteString
-> STM RespAct
-> ConduitT () (Flush Builder) IO ()
streamBlocks env init getAct = send init >> loop
where
loop = atomically getAct >>= \case
RAHead _ _ _ -> runRIO env dupHead
RAFull _ _ _ -> runRIO env dupHead
RADone -> pure ()
RABloc c -> send c >> loop
send "" = pure ()
send c = do
runRIO env (logTrace (display ("sending chunk " <> tshow c)))
yield $ Chunk $ fromByteString c
yield Flush
sendResponse
:: HasLogFunc e
=> (W.Response -> IO W.ResponseReceived)
-> STM RespAct
-> RIO e W.ResponseReceived
sendResponse cb waitAct = do
env <- ask
atomically waitAct >>= \case
RADone -> io $ cb $ W.responseLBS (H.mkStatus 444 "No Response") [] ""
RAFull s h b -> io $ cb $ W.responseLBS s h $ fromStrict b
RAHead s h b -> io $ cb $ W.responseSource s h $ streamBlocks env b waitAct
RABloc _ -> noHeader
liveReq :: Ship -> TVar LiveReqs -> RAcquire e (Word64, STM RespAct)
liveReq who vLiv = mkRAcquire ins del
where
ins = atomically (newLiveReq who vLiv)
del = atomically . rmLiveReq vLiv . fst
app
:: HasLogFunc e
=> e
-> Ship
-> TVar LiveReqs
-> (Word64 -> ReqInfo -> STM ())
-> (Word64 -> STM ())
-> W.Application
app env who liv inform cancel req respond =
runRIO env $ rwith (liveReq who liv) $ \(reqId, respApi) -> do
bod <- io (toStrict <$> W.strictRequestBody req)
met <- maybe (error "bad method") pure (cookMeth req)
let adr = reqAddr req
hdr = W.requestHeaders req
url = reqUrl req
atomically $ inform reqId $ ReqInfo adr met url hdr bod
try (sendResponse respond respApi) >>= \case
Right rr -> pure rr
Left exn -> do
atomically (cancel reqId)
logError $ display ("Exception during request" <> tshow exn)
throwIO (exn :: SomeException)

77
pkg/hs/urbit-king/lib/Urbit/Vere/Http/Client.hs
View File

@ -7,19 +7,22 @@
module Urbit.Vere.Http.Client where
import Urbit.Arvo (BlipEv(..), Ev(..), HttpClientEf(..),
HttpClientEv(..), HttpClientReq(..),
HttpEvent(..), KingId, ResponseHeader(..))
import Urbit.Prelude hiding (Builder)
import Urbit.Vere.Pier.Types
import Urbit.Prelude hiding (Builder)
import Urbit.Vere.Http
import Urbit.Vere.Pier.Types
import Urbit.King.App
import Urbit.Arvo (BlipEv(..), Ev(..), HttpClientEf(..), HttpClientEv(..),
HttpClientReq(..), HttpEvent(..), KingId, ResponseHeader(..))
import qualified Data.Map as M
import qualified Network.HTTP.Client as H
import qualified Network.HTTP.Client.TLS as TLS
import qualified Network.HTTP.Types as HT
-- Types -----------------------------------------------------------------------
type ReqId = Word
@ -54,14 +57,54 @@ bornEv king =
--------------------------------------------------------------------------------
client :: forall e. HasLogFunc e
=> KingId -> QueueEv -> ([Ev], RAcquire e (EffCb e HttpClientEf))
client kingId enqueueEv = (initialEvents, runHttpClient)
_bornFailed :: e -> WorkError -> IO ()
_bornFailed env _ = runRIO env $ do
pure () -- TODO What to do in this case?
client'
:: HasPierEnv e
=> RIO e ([Ev], RAcquire e (DriverApi HttpClientEf))
client' = do
ventQ :: TQueue EvErr <- newTQueueIO
env <- ask
let (bornEvs, startDriver) = client env (writeTQueue ventQ)
let runDriver = do
diOnEffect <- startDriver
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
pure (bornEvs, runDriver)
{-|
Iris -- HTTP Client Driver
Until born events succeeds, ignore effects.
Wait until born event callbacks invoked.
If success, signal success.
If failure, try again several times.
If still failure, bring down ship.
Once born event succeeds, hold on to effects.
Once all other drivers have booted:
- Execute stashed effects.
- Begin normal operation (start accepting requests)
-}
client
:: forall e
. (HasLogFunc e, HasKingId e)
=> e
-> (EvErr -> STM ())
-> ([Ev], RAcquire e (HttpClientEf -> IO ()))
client env plan = (initialEvents, runHttpClient)
where
kingId = view (kingIdL . to fromIntegral) env
initialEvents :: [Ev]
initialEvents = [bornEv kingId]
runHttpClient :: RAcquire e (EffCb e HttpClientEf)
runHttpClient :: RAcquire e (HttpClientEf -> IO ())
runHttpClient = handleEffect <$> mkRAcquire start stop
start :: RIO e (HttpClientDrv)
@ -75,10 +118,10 @@ client kingId enqueueEv = (initialEvents, runHttpClient)
liveThreads <- atomically $ readTVar hcdLive
mapM_ cancel liveThreads
handleEffect :: HttpClientDrv -> HttpClientEf -> RIO e ()
handleEffect :: HttpClientDrv -> HttpClientEf -> IO ()
handleEffect drv = \case
HCERequest _ id req -> newReq drv id req
HCECancelRequest _ id -> cancelReq drv id
HCERequest _ id req -> runRIO env (newReq drv id req)
HCECancelRequest _ id -> runRIO env (cancelReq drv id)
newReq :: HttpClientDrv -> ReqId -> HttpClientReq -> RIO e ()
newReq drv id req = do
@ -124,8 +167,14 @@ client kingId enqueueEv = (initialEvents, runHttpClient)
planEvent :: ReqId -> HttpEvent -> RIO e ()
planEvent id ev = do
logDebug $ displayShow ("(http client response)", id, (describe ev))
atomically $ enqueueEv $ EvBlip $ BlipEvHttpClient $
HttpClientEvReceive (kingId, ()) (fromIntegral id) ev
let recvEv = EvBlip
$ BlipEvHttpClient
$ HttpClientEvReceive (kingId, ()) (fromIntegral id) ev
let recvFailed _ = pure ()
atomically $ plan (EvErr recvEv recvFailed)
-- show an HttpEvent with byte count instead of raw data
describe :: HttpEvent -> String

635
pkg/hs/urbit-king/lib/Urbit/Vere/Http/Server.hs
View File

@ -1,635 +0,0 @@
{-|
Http Server Driver
TODO Make sure that HTTP sockets get closed on shutdown.
TODO What is this about?
// if we don't explicitly set this field, h2o will send with
// transfer-encoding: chunked
//
if ( 1 == has_len_i ) {
rec_u->res.content_length = ( 0 == gen_u->bod_u ) ?
0 : gen_u->bod_u->len_w;
}
TODO Does this matter, is is using WAI's default behavior ok?
rec_u->res.reason = (status < 200) ? "weird" :
(status < 300) ? "ok" :
(status < 400) ? "moved" :
(status < 500) ? "missing" :
"hosed";
-}
module Urbit.Vere.Http.Server where
import Data.Conduit
import Urbit.Arvo hiding (ServerId, reqBody, reqUrl, secure)
import Urbit.King.Config
import Urbit.Noun
import Urbit.Prelude hiding (Builder)
import Urbit.Vere.Pier.Types
import Data.Binary.Builder (Builder, fromByteString)
import Data.Bits (shiftL, (.|.))
import Data.PEM (pemParseBS, pemWriteBS)
import Network.Socket (SockAddr(..))
import System.Directory (doesFileExist, removeFile)
import System.Random (randomIO)
import Urbit.Vere.Http (convertHeaders, unconvertHeaders)
import qualified Network.HTTP.Types as H
import qualified Network.Socket as Net
import qualified Network.Wai as W
import qualified Network.Wai.Conduit as W
import qualified Network.Wai.Handler.Warp as W
import qualified Network.Wai.Handler.WarpTLS as W
-- Internal Types --------------------------------------------------------------
type HasShipEnv e = (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
type ReqId = UD
type SeqId = UD -- Unused, always 1
{-|
The sequence of actions on a given request *should* be:
[%head .] [%bloc .]* %done
But we will actually accept anything, and mostly do the right
thing. There are two situations where we ignore ignore the data from
some actions.
- If you send something *after* a %done action, it will be ignored.
- If you send a %done before a %head, we will produce "444 No
Response" with an empty response body.
-}
data RespAction
= RAHead ResponseHeader File
| RAFull ResponseHeader File
| RABloc File
| RADone
deriving (Eq, Ord, Show)
data LiveReqs = LiveReqs
{ nextReqId :: ReqId
, activeReqs :: Map ReqId (TQueue RespAction)
}
data Ports = Ports
{ pHttps :: Maybe Port
, pHttp :: Port
, pLoop :: Port
}
deriving (Eq, Ord, Show)
newtype Drv = Drv { unDrv :: MVar (Maybe Serv) }
data Serv = Serv
{ sServId :: ServId
, sConfig :: HttpServerConf
, sLoopTid :: Async ()
, sHttpTid :: Async ()
, sHttpsTid :: Maybe (Async ())
, sLoopSock :: Net.Socket
, sHttpSock :: Net.Socket
, sHttpsSock :: Net.Socket
, sPorts :: Ports
, sPortsFile :: FilePath
, sLiveReqs :: TVar LiveReqs
}
-- RespAction -- Reorganized HttpEvent for Cleaner Processing ------------------
reorgHttpEvent :: HttpEvent -> [RespAction]
reorgHttpEvent = \case
Start head mBlk True -> [RAFull head (fromMaybe "" mBlk)]
Start head mBlk False -> [RAHead head (fromMaybe "" mBlk)]
Cancel () -> [RADone]
Continue mBlk isDone -> toList (RABloc <$> mBlk)
<> if isDone then [RADone] else []
-- Generic Service Stop/Restart -- Using an MVar for Atomicity -----------------
{-|
Restart a running service.
This can probably be made simpler, but it
- Sets the MVar to Nothing if there was an exception whil starting
or stopping the service.
- Keeps the MVar lock until the restart process finishes.
-}
restartService :: ∀e s. HasLogFunc e
=> MVar (Maybe s)
-> RIO e s
-> (s -> RIO e ())
-> RIO e (Either SomeException s)
restartService vServ sstart kkill = do
logDebug "restartService"
modifyMVar vServ $ \case
Nothing -> doStart
Just sv -> doRestart sv
where
doRestart :: s -> RIO e (Maybe s, Either SomeException s)
doRestart serv = do
logDebug "doStart"
try (kkill serv) >>= \case
Left exn -> pure (Nothing, Left exn)
Right () -> doStart
doStart :: RIO e (Maybe s, Either SomeException s)
doStart = do
logDebug "doStart"
try sstart <&> \case
Right s -> (Just s, Right s)
Left exn -> (Nothing, Left exn)
stopService :: HasLogFunc e
=> MVar (Maybe s)
-> (s -> RIO e ())
-> RIO e (Either SomeException ())
stopService vServ kkill = do
logDebug "stopService"
modifyMVar vServ $ \case
Nothing -> pure (Nothing, Right ())
Just sv -> do res <- try (kkill sv)
pure (Nothing, res)
-- Live Requests Table -- All Requests Still Waiting for Responses -------------
emptyLiveReqs :: LiveReqs
emptyLiveReqs = LiveReqs 1 mempty
respondToLiveReq :: TVar LiveReqs -> ReqId -> RespAction -> STM ()
respondToLiveReq var req ev = do
mVar <- lookup req . activeReqs <$> readTVar var
case mVar of
Nothing -> pure ()
Just tv -> writeTQueue tv ev
rmLiveReq :: TVar LiveReqs -> ReqId -> STM ()
rmLiveReq var reqId = do
liv <- readTVar var
writeTVar var (liv { activeReqs = deleteMap reqId (activeReqs liv) })
newLiveReq :: TVar LiveReqs -> STM (ReqId, TQueue RespAction)
newLiveReq var = do
liv <- readTVar var
tmv <- newTQueue
let (nex, act) = (nextReqId liv, activeReqs liv)
writeTVar var (LiveReqs (nex+1) (insertMap nex tmv act))
pure (nex, tmv)
-- Ports File ------------------------------------------------------------------
removePortsFile :: FilePath -> RIO e ()
removePortsFile pax =
io (doesFileExist pax) >>= \case
True -> io $ removeFile pax
False -> pure ()
portsFileText :: Ports -> Text
portsFileText Ports{..} =
unlines $ catMaybes
[ pHttps <&> \p -> (tshow p <> " secure public")
, Just (tshow (unPort pHttp) <> " insecure public")
, Just (tshow (unPort pLoop) <> " insecure loopback")
]
writePortsFile :: FilePath -> Ports -> RIO e ()
writePortsFile f = writeFile f . encodeUtf8 . portsFileText
-- Random Helpers --------------------------------------------------------------
cordBytes :: Cord -> ByteString
cordBytes = encodeUtf8 . unCord
wainBytes :: Wain -> ByteString
wainBytes = encodeUtf8 . unWain
pass :: Monad m => m ()
pass = pure ()
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Nothing act = pure ()
whenJust (Just a) act = act a
cookMeth :: W.Request -> Maybe Method
cookMeth = H.parseMethod . W.requestMethod >>> \case
Left _ -> Nothing
Right m -> Just m
reqIdCord :: ReqId -> Cord
reqIdCord = Cord . tshow
reqBody :: W.Request -> RIO e (Maybe File)
reqBody req = do
bodyLbs <- io $ W.strictRequestBody req
pure $ if length bodyLbs == 0
then Nothing
else Just $ File $ Octs (toStrict bodyLbs)
reqAddr :: W.Request -> Address
reqAddr = W.remoteHost >>> \case
SockAddrInet _ a -> AIpv4 (Ipv4 a)
SockAddrInet6 _ _ a _ -> AIpv6 (mkIpv6 a)
_ -> error "invalid sock addr"
mkIpv6 :: (Word32, Word32, Word32, Word32) -> Ipv6
mkIpv6 (p, q, r, s) = Ipv6 (pBits .|. qBits .|. rBits .|. sBits)
where
pBits = shiftL (fromIntegral p) 0
qBits = shiftL (fromIntegral q) 32
rBits = shiftL (fromIntegral r) 64
sBits = shiftL (fromIntegral s) 96
reqUrl :: W.Request -> Cord
reqUrl r = Cord $ decodeUtf8 $ W.rawPathInfo r <> W.rawQueryString r
-- Utilities for Constructing Events -------------------------------------------
data WhichServer = Secure | Insecure | Loopback
deriving (Eq)
servEv :: HttpServerEv -> Ev
servEv = EvBlip . BlipEvHttpServer
bornEv :: KingId -> Ev
bornEv king =
servEv $ HttpServerEvBorn (king, ()) ()
liveEv :: ServId -> Ports -> Ev
liveEv sId Ports{..} =
servEv $ HttpServerEvLive (sId, ()) pHttp pHttps
cancelEv :: ServId -> ReqId -> Ev
cancelEv sId reqId =
servEv $ HttpServerEvCancelRequest (sId, reqId, 1, ()) ()
reqEv :: ServId -> ReqId -> WhichServer -> Address -> HttpRequest -> Ev
reqEv sId reqId which addr req =
case which of
Loopback ->
servEv $ HttpServerEvRequestLocal (sId, reqId, 1, ())
$ HttpServerReq False addr req
_ ->
servEv $ HttpServerEvRequest (sId, reqId, 1, ())
$ HttpServerReq (which == Secure) addr req
-- Http Server Flows -----------------------------------------------------------
data Resp
= RHead ResponseHeader [File]
| RFull ResponseHeader [File]
| RNone
deriving (Show)
{-|
This accepts all action orderings so that there are no edge-cases
to be handled:
- If %bloc before %head, collect it and wait for %head.
- If %done before %head, ignore all chunks and produce Nothing.
TODO Be strict about this instead. Ignore invalid request streams.
-}
getResp :: TQueue RespAction -> RIO e Resp
getResp tmv = go []
where
go çunks = atomically (readTQueue tmv) >>= \case
RAHead head ç -> pure $ RHead head $ reverse (ç : çunks)
RAFull head ç -> pure $ RFull head $ reverse (ç : çunks)
RABloc ç -> go (ç : çunks)
RADone -> pure RNone
{-|
- Immediatly yield all of the initial chunks
- Yield the data from %bloc action.
- Close the stream when we hit a %done action.
-}
streamBlocks :: HasLogFunc e
=> e -> [File] -> TQueue RespAction
-> ConduitT () (Flush Builder) IO ()
streamBlocks env init tmv =
for_ init yieldÇunk >> go
where
yieldFlush = \x -> yield (Chunk x) >> yield Flush
logDupHead = runRIO env (logError "Multiple %head actions on one request")
yieldÇunk = \case
"" -> runRIO env (logTrace "sending empty chunk")
c -> do runRIO env (logTrace (display ("sending chunk " <> tshow c)))
(yieldFlush . fromByteString . unOcts . unFile) c
go = atomically (readTQueue tmv) >>= \case
RAHead head c -> logDupHead >> yieldÇunk c >> go
RAFull head c -> logDupHead >> yieldÇunk c >> go
RABloc c -> yieldÇunk c >> go
RADone -> pure ()
sendResponse :: HasLogFunc e
=> (W.Response -> IO W.ResponseReceived)
-> TQueue RespAction
-> RIO e W.ResponseReceived
sendResponse cb tmv = do
env <- ask
getResp tmv >>= \case
RNone -> io $ cb $ W.responseLBS (H.mkStatus 444 "No Response") []
$ ""
RFull h f -> io $ cb $ W.responseLBS (hdrStatus h) (hdrHeaders h)
$ fromStrict $ concat $ unOcts . unFile <$> f
RHead h i -> io $ cb $ W.responseSource (hdrStatus h) (hdrHeaders h)
$ streamBlocks env i tmv
where
hdrHeaders :: ResponseHeader -> [H.Header]
hdrHeaders = unconvertHeaders . headers
hdrStatus :: ResponseHeader -> H.Status
hdrStatus = toEnum . fromIntegral . statusCode
liveReq :: TVar LiveReqs -> RAcquire e (ReqId, TQueue RespAction)
liveReq vLiv = mkRAcquire ins del
where
ins = atomically (newLiveReq vLiv)
del = atomically . rmLiveReq vLiv . fst
app :: HasLogFunc e
=> e -> ServId -> TVar LiveReqs -> (Ev -> STM ()) -> WhichServer
-> W.Application
app env sId liv plan which req respond =
runRIO env $
rwith (liveReq liv) $ \(reqId, respVar) -> do
body <- reqBody req
meth <- maybe (error "bad method") pure (cookMeth req)
let addr = reqAddr req
hdrs = convertHeaders $ W.requestHeaders req
evReq = HttpRequest meth (reqUrl req) hdrs body
atomically $ plan (reqEv sId reqId which addr evReq)
try (sendResponse respond respVar) >>= \case
Right rr -> pure rr
Left exn -> do
io $ atomically $ plan (cancelEv sId reqId)
logError $ display ("Exception during request" <> tshow exn)
throwIO (exn :: SomeException)
-- Top-Level Driver Interface --------------------------------------------------
data CantOpenPort = CantOpenPort W.Port
deriving (Eq, Ord, Show, Exception)
data WhichPort
= WPSpecific W.Port
| WPChoices [W.Port]
data SockOpts = SockOpts
{ soLocalhost :: Bool
, soWhich :: WhichPort
}
data PortsToTry = PortsToTry
{ pttSec :: SockOpts
, pttIns :: SockOpts
, pttLop :: SockOpts
}
{-|
Opens a socket on some port, accepting connections from `127.0.0.1`
if fake and `0.0.0.0` if real.
It will attempt to open a socket on each of the supplied ports in
order. If they all fail, it will ask the operating system to give
us an open socket on *any* open port. If that fails, it will throw
an exception.
-}
openPort :: forall e . HasLogFunc e => SockOpts -> RIO e (W.Port, Net.Socket)
openPort SockOpts {..} = case soWhich of
WPSpecific x -> insist (fromIntegral x)
WPChoices xs -> loop (fromIntegral <$> xs)
where
loop :: [W.Port] -> RIO e (W.Port, Net.Socket)
loop = \case
[] -> do
logTrace "Fallback: asking the OS to give us some free port."
ps <- io W.openFreePort
logTrace (display ("Opened port " <> tshow (fst ps)))
pure ps
x : xs -> do
logTrace (display ("Trying to open port " <> tshow x))
io (tryOpen x) >>= \case
Left (err :: IOError) -> do
logWarn (display ("Failed to open port " <> tshow x))
logWarn (display (tshow err))
loop xs
Right ps -> do
logTrace (display ("Opened port " <> tshow (fst ps)))
pure ps
insist :: W.Port -> RIO e (W.Port, Net.Socket)
insist p = do
logTrace (display ("Opening configured port " <> tshow p))
io (tryOpen p) >>= \case
Left (err :: IOError) -> do
logWarn (display ("Failed to open port " <> tshow p))
logWarn (display (tshow err))
throwIO (CantOpenPort p)
Right ps -> do
logTrace (display ("Opened port " <> tshow (fst ps)))
pure ps
bindTo = if soLocalhost then "127.0.0.1" else "0.0.0.0"
getBindAddr :: W.Port -> IO SockAddr
getBindAddr por =
Net.getAddrInfo Nothing (Just bindTo) (Just (show por)) >>= \case
[] -> error "this should never happen."
x : _ -> pure (Net.addrAddress x)
bindListenPort :: W.Port -> Net.Socket -> IO Net.PortNumber
bindListenPort por sok = do
Net.bind sok =<< getBindAddr por
Net.listen sok 1
Net.socketPort sok
-- `inet_addr`, `bind`, and `listen` all throw `IOError` if they fail.
tryOpen :: W.Port -> IO (Either IOError (W.Port, Net.Socket))
tryOpen por = do
sok <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol
try (bindListenPort por sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right por -> pure (Right (fromIntegral por, sok))
httpServerPorts :: HasShipEnv e => Bool -> RIO e PortsToTry
httpServerPorts fak = do
ins <- view (networkConfigL . ncHttpPort . to (fmap fromIntegral))
sec <- view (networkConfigL . ncHttpsPort . to (fmap fromIntegral))
lop <- view (networkConfigL . ncLocalPort . to (fmap fromIntegral))
localMode <- view (networkConfigL . ncNetMode . to (== NMLocalhost))
let local = localMode || fak
let pttSec = case (sec, fak) of
(Just p , _ ) -> SockOpts local (WPSpecific p)
(Nothing, False) -> SockOpts local (WPChoices (443 : [8443 .. 8448]))
(Nothing, True ) -> SockOpts local (WPChoices ([8443 .. 8448]))
let pttIns = case (ins, fak) of
(Just p , _ ) -> SockOpts local (WPSpecific p)
(Nothing, False) -> SockOpts local (WPChoices (80 : [8080 .. 8085]))
(Nothing, True ) -> SockOpts local (WPChoices [8080 .. 8085])
let pttLop = case (lop, fak) of
(Just p , _) -> SockOpts local (WPSpecific p)
(Nothing, _) -> SockOpts local (WPChoices [12321 .. 12326])
pure (PortsToTry { .. })
parseCerts :: ByteString -> Maybe (ByteString, [ByteString])
parseCerts bs = do
pems <- pemParseBS bs & either (const Nothing) Just
case pems of
[] -> Nothing
p:ps -> pure (pemWriteBS p, pemWriteBS <$> ps)
startServ :: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
=> Bool -> HttpServerConf -> (Ev -> STM ())
-> RIO e Serv
startServ isFake conf plan = do
logDebug "startServ"
let tls = do (PEM key, PEM certs) <- hscSecure conf
(cert, chain) <- parseCerts (wainBytes certs)
pure $ W.tlsSettingsChainMemory cert chain $ wainBytes key
sId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
liv <- newTVarIO emptyLiveReqs
ptt <- httpServerPorts isFake
(httpPortInt, httpSock) <- openPort (pttIns ptt)
(httpsPortInt, httpsSock) <- openPort (pttSec ptt)
(loopPortInt, loopSock) <- openPort (pttLop ptt)
let httpPort = Port (fromIntegral httpPortInt)
httpsPort = Port (fromIntegral httpsPortInt)
loopPort = Port (fromIntegral loopPortInt)
let loopOpts = W.defaultSettings & W.setPort (fromIntegral loopPort)
& W.setHost "127.0.0.1"
& W.setTimeout (5 * 60)
httpOpts = W.defaultSettings & W.setHost "*"
& W.setPort (fromIntegral httpPort)
httpsOpts = W.defaultSettings & W.setHost "*"
& W.setPort (fromIntegral httpsPort)
env <- ask
logDebug "Starting loopback server"
loopTid <- async $ io
$ W.runSettingsSocket loopOpts loopSock
$ app env sId liv plan Loopback
logDebug "Starting HTTP server"
httpTid <- async $ io
$ W.runSettingsSocket httpOpts httpSock
$ app env sId liv plan Insecure
logDebug "Starting HTTPS server"
httpsTid <- for tls $ \tlsOpts ->
async $ io
$ W.runTLSSocket tlsOpts httpsOpts httpsSock
$ app env sId liv plan Secure
pierPath <- view pierPathL
let por = Ports (tls <&> const httpsPort) httpPort loopPort
fil = pierPath <> "/.http.ports"
logDebug $ displayShow (sId, por, fil)
logDebug "Finished started HTTP Servers"
pure $ Serv sId conf
loopTid httpTid httpsTid
httpSock httpsSock loopSock
por fil liv
killServ :: HasLogFunc e => Serv -> RIO e ()
killServ Serv{..} = do
cancel sLoopTid
cancel sHttpTid
traverse_ cancel sHttpsTid
io $ Net.close sHttpSock
io $ Net.close sHttpsSock
io $ Net.close sLoopSock
removePortsFile sPortsFile
(void . waitCatch) sLoopTid
(void . waitCatch) sHttpTid
traverse_ (void . waitCatch) sHttpsTid
kill :: HasLogFunc e => Drv -> RIO e ()
kill (Drv v) = stopService v killServ >>= fromEither
respond :: HasLogFunc e
=> Drv -> ReqId -> HttpEvent -> RIO e ()
respond (Drv v) reqId ev = do
readMVar v >>= \case
Nothing -> logWarn "Got a response to a request that does not exist."
Just sv -> do logDebug $ displayShow $ reorgHttpEvent ev
for_ (reorgHttpEvent ev) $
atomically . respondToLiveReq (sLiveReqs sv) reqId
serv :: ∀e. HasShipEnv e
=> KingId -> QueueEv -> Bool
-> ([Ev], RAcquire e (EffCb e HttpServerEf))
serv king plan isFake =
(initialEvents, runHttpServer)
where
initialEvents :: [Ev]
initialEvents = [bornEv king]
runHttpServer :: RAcquire e (EffCb e HttpServerEf)
runHttpServer = handleEf <$> mkRAcquire (Drv <$> newMVar Nothing) kill
restart :: Drv -> HttpServerConf -> RIO e Serv
restart (Drv var) conf = do
logDebug "Restarting http server"
res <- fromEither =<<
restartService var (startServ isFake conf plan) killServ
logDebug "Done restating http server"
pure res
handleEf :: Drv -> HttpServerEf -> RIO e ()
handleEf drv = \case
HSESetConfig (i, ()) conf -> do
-- print (i, king)
-- when (i == fromIntegral king) $ do
logDebug "restarting"
Serv{..} <- restart drv conf
logDebug "Enqueue %live"
atomically $ plan (liveEv sServId sPorts)
logDebug "Write ports file"
writePortsFile sPortsFile sPorts
HSEResponse (i, req, _seq, ()) ev -> do
-- print (i, king)
-- when (i == fromIntegral king) $ do
logDebug "respond"
respond drv (fromIntegral req) ev

40
pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs
View File

@ -55,24 +55,24 @@ wsConn :: (FromNoun i, ToNoun o, Show i, Show o, HasLogFunc e)
-> WS.Connection
-> RIO e ()
wsConn pre inp out wsc = do
logWarn (pre <> "(wcConn) Connected!")
logDebug (pre <> "(wcConn) Connected!")
writer <- withRIOThread $ forever $ do
logWarn (pre <> "(wsConn) Waiting for data.")
logDebug (pre <> "(wsConn) Waiting for data.")
byt <- io $ toStrict <$> WS.receiveData wsc
logWarn (pre <> "Got data")
logDebug (pre <> "Got data")
dat <- cueBSExn byt >>= fromNounExn
logWarn (pre <> "(wsConn) Decoded data, writing to chan")
logDebug (pre <> "(wsConn) Decoded data, writing to chan")
atomically $ writeTBMChan inp dat
reader <- withRIOThread $ forever $ do
logWarn (pre <> "Waiting for data from chan")
logDebug (pre <> "Waiting for data from chan")
atomically (readTBMChan out) >>= \case
Nothing -> do
logWarn (pre <> "(wsConn) Connection closed")
logDebug (pre <> "(wsConn) Connection closed")
error "dead-conn"
Just msg -> do
logWarn (pre <> "(wsConn) Got message! " <> displayShow msg)
logDebug (pre <> "(wsConn) Got message! " <> displayShow msg)
io $ WS.sendBinaryData wsc $ fromStrict $ jamBS $ toNoun msg
let cleanup = do
@ -82,7 +82,7 @@ wsConn pre inp out wsc = do
flip finally cleanup $ do
res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
logWarn $ displayShow (res :: Either SomeException ())
logDebug $ displayShow (res :: Either SomeException ())
--------------------------------------------------------------------------------
@ -111,7 +111,7 @@ wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
-> WS.PendingConnection
-> RIO e ()
wsServApp cb pen = do
logError "NOUNSERV (wsServer) Got connection!"
logDebug "NOUNSERV (wsServer) Got connection!"
wsc <- io $ WS.acceptRequest pen
inp <- io $ newTBMChanIO 5
out <- io $ newTBMChanIO 5
@ -125,10 +125,10 @@ wsServer = do
tid <- async $ do
env <- ask
logError "NOUNSERV (wsServer) Starting server"
logDebug "NOUNSERV (wsServer) Starting server"
io $ WS.runServer "127.0.0.1" 9999
$ runRIO env . wsServApp (writeTBMChan con)
logError "NOUNSERV (wsServer) Server died"
logDebug "NOUNSERV (wsServer) Server died"
atomically $ closeTBMChan con
pure $ Server (readTBMChan con) tid 9999
@ -147,34 +147,34 @@ example = Just (99, (), 44)
testIt :: HasLogFunc e => RIO e ()
testIt = do
logTrace "(testIt) Starting Server"
logDebug "(testIt) Starting Server"
Server{..} <- wsServer @Example @Example
logTrace "(testIt) Connecting"
logDebug "(testIt) Connecting"
Client{..} <- wsClient @Example @Example "/" sData
logTrace "(testIt) Accepting connection"
logDebug "(testIt) Accepting connection"
sConn <- fromJust "accept" =<< atomically sAccept
let
clientSend = do
logTrace "(testIt) Sending from client"
logDebug "(testIt) Sending from client"
atomically (cSend cConn example)
logTrace "(testIt) Waiting for response"
logDebug "(testIt) Waiting for response"
res <- atomically (cRecv sConn)
print ("clientSend", res, example)
unless (res == Just example) $ do
error "Bad data"
logInfo "(testIt) Success"
logDebug "(testIt) Success"
serverSend = do
logTrace "(testIt) Sending from server"
logDebug "(testIt) Sending from server"
atomically (cSend sConn example)
logTrace "(testIt) Waiting for response"
logDebug "(testIt) Waiting for response"
res <- atomically (cRecv cConn)
print ("serverSend", res, example)
unless (res == Just example) $ do
error "Bad data"
logInfo "(testIt) Success"
logDebug "(testIt) Success"
clientSend
clientSend

829
pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs
View File

@ -1,413 +1,553 @@
{-|
Top-Level Pier Management
Top-Level Pier Management
This is the code that starts the IO drivers and deals with
communication between the serf, the log, and the IO drivers.
This is the code that starts the IO drivers and deals with communication
between the serf, the event log, and the IO drivers.
-}
module Urbit.Vere.Pier
( booted, resumed, getSnapshot, pier, runPersist, runCompute, generateBootSeq
) where
( booted
, runSerf
, resumed
, getSnapshot
, pier
, runPersist
, runCompute
, genBootSeq
)
where
import Urbit.Prelude
import RIO.Directory
import System.Random
import Urbit.Arvo
import Urbit.King.Config
import Urbit.Vere.Pier.Types
import Control.Monad.Trans.Maybe
import RIO.Directory
import Urbit.Arvo
import Urbit.King.App
import Urbit.Vere.Pier.Types
import Data.Text (append)
import Control.Monad.STM (retry)
import System.Posix.Files (ownerModes, setFileMode)
import Urbit.King.App (HasConfigDir(..), HasStderrLogFunc(..))
import Urbit.EventLog.LMDB (EventLog)
import Urbit.King.API (TermConn)
import Urbit.Noun.Time (Wen)
import Urbit.TermSize (TermSize(..))
import Urbit.Vere.Ames (ames)
import Urbit.Vere.Behn (behn)
import Urbit.Vere.Clay (clay)
import Urbit.Vere.Http.Client (client)
import Urbit.Vere.Http.Server (serv)
import Urbit.Vere.Log (EventLog)
import Urbit.Vere.Serf (Serf, SerfState(..), doJob, sStderr)
import Urbit.Vere.Eyre.Multi (MultiEyreApi)
import Urbit.Vere.Serf (Serf)
import qualified System.Entropy as Ent
import qualified Urbit.King.API as King
import qualified Urbit.Time as Time
import qualified Urbit.Vere.Log as Log
import qualified Urbit.Vere.Serf as Serf
import qualified Urbit.Vere.Term as Term
import qualified Urbit.Vere.Term.API as Term
import qualified Urbit.Vere.Term.Demux as Term
import qualified Data.Text as T
import qualified System.Entropy as Ent
import qualified Urbit.EventLog.LMDB as Log
import qualified Urbit.King.API as King
import qualified Urbit.Noun.Time as Time
import qualified Urbit.Vere.Ames as Ames
import qualified Urbit.Vere.Behn as Behn
import qualified Urbit.Vere.Clay as Clay
import qualified Urbit.Vere.Eyre as Eyre
import qualified Urbit.Vere.Http.Client as Iris
import qualified Urbit.Vere.Serf as Serf
import qualified Urbit.Vere.Term as Term
import qualified Urbit.Vere.Term.API as Term
import qualified Urbit.Vere.Term.Demux as Term
--------------------------------------------------------------------------------
-- Initialize pier directory. --------------------------------------------------
_ioDrivers = [] :: [IODriver]
data PierDirectoryAlreadyExists = PierDirectoryAlreadyExists
deriving (Show, Exception)
setupPierDirectory :: FilePath -> RIO e ()
setupPierDirectory shipPath = do
for_ ["put", "get", "log", "chk"] $ \seg -> do
let pax = shipPath <> "/.urb/" <> seg
createDirectoryIfMissing True pax
io $ setFileMode pax ownerModes
-- shipPath will already exist because we put a lock file there.
alreadyExists <- doesPathExist (shipPath </> ".urb")
when alreadyExists $ do
throwIO PierDirectoryAlreadyExists
for_ ["put", "get", "log", "chk"] $ \seg -> do
let pax = shipPath </> ".urb" </> seg
createDirectoryIfMissing True pax
io $ setFileMode pax ownerModes
-- Load pill into boot sequence. -----------------------------------------------
genEntropy :: RIO e Word512
genEntropy = fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
genEntropy :: MonadIO m => m Entropy
genEntropy = Entropy . fromIntegral . bytesAtom <$> io (Ent.getEntropy 64)
generateBootSeq :: Ship -> Pill -> Bool -> LegacyBootEvent -> RIO e BootSeq
generateBootSeq ship Pill{..} lite boot = do
ent <- genEntropy
let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
pure $ BootSeq ident pBootFormulas ovums
where
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
preKern ent = [ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
]
postKern = [ EvBlip $ BlipEvTerm $ TermEvBoot (1,()) lite boot ]
isFake = case boot of
Fake _ -> True
_ -> False
genBootSeq :: MonadIO m => Ship -> Pill -> Bool -> LegacyBootEvent -> m BootSeq
genBootSeq ship Pill {..} lite boot = io $ do
ent <- genEntropy
let ovums = preKern ent <> pKernelOvums <> postKern <> pUserspaceOvums
pure $ BootSeq ident pBootFormulas ovums
where
ident = LogIdentity ship isFake (fromIntegral $ length pBootFormulas)
preKern ent =
[ EvBlip $ BlipEvArvo $ ArvoEvWhom () ship
, EvBlip $ BlipEvArvo $ ArvoEvWack () ent
]
postKern = [EvBlip $ BlipEvTerm $ TermEvBoot (1, ()) lite boot]
isFake = case boot of
Fake _ -> True
_ -> False
-- Write a batch of jobs into the event log ------------------------------------
-- Write to the log. -----------------------------------------------------------
-- | Write a batch of jobs to the event log.
writeJobs :: EventLog -> Vector Job -> RIO e ()
writeJobs log !jobs = do
expect <- Log.nextEv log
events <- fmap fromList $ traverse fromJob (zip [expect..] $ toList jobs)
Log.appendEvents log events
where
fromJob :: (EventId, Job) -> RIO e ByteString
fromJob (expectedId, job) = do
unless (expectedId == jobId job) $
error $ show ("bad job id!", expectedId, jobId job)
pure $ jamBS $ jobPayload job
expect <- atomically (Log.nextEv log)
events <- fmap fromList $ traverse fromJob (zip [expect ..] $ toList jobs)
Log.appendEvents log events
where
fromJob :: (EventId, Job) -> RIO e ByteString
fromJob (expectedId, job) = do
unless (expectedId == jobId job) $ error $ show
("bad job id!", expectedId, jobId job)
pure $ jamBS $ jobPayload job
jobPayload :: Job -> Noun
jobPayload (RunNok (LifeCyc _ m n)) = toNoun (m, n)
jobPayload (DoWork (Work _ m d o)) = toNoun (m, d, o)
jobPayload :: Job -> Noun
jobPayload (RunNok (LifeCyc _ m n)) = toNoun (m, n)
jobPayload (DoWork (Work _ m d o )) = toNoun (m, d, o)
-- Acquire a running serf. -----------------------------------------------------
printTank :: (Text -> IO ()) -> Atom -> Tank -> IO ()
printTank f _priority = f . unlines . fmap unTape . wash (WashCfg 0 80) . tankTree
where
tankTree (Tank t) = t
runSerf
:: HasPierEnv e
=> TVar (Text -> IO ())
-> FilePath
-> RAcquire e Serf
runSerf vSlog pax = do
env <- ask
Serf.withSerf (config env)
where
slog txt = atomically (readTVar vSlog) >>= (\f -> f txt)
config env = Serf.Config
{ scSerf = env ^. pierConfigL . pcSerfExe . to unpack
, scPier = pax
, scFlag = env ^. pierConfigL . pcSerfFlags
, scSlog = \(pri, tank) -> printTank slog pri tank
, scStdr = \txt -> slog (txt <> "\r\n")
, scDead = pure () -- TODO: What can be done?
}
-- Boot a new ship. ------------------------------------------------------------
booted :: (HasPierConfig e, HasStderrLogFunc e, HasLogFunc e)
=> Pill -> Bool -> Serf.Flags -> Ship -> LegacyBootEvent
-> RAcquire e (Serf e, EventLog, SerfState)
booted pill lite flags ship boot = do
seq@(BootSeq ident x y) <- rio $ generateBootSeq ship pill lite boot
booted
:: TVar (Text -> IO ())
-> Pill
-> Bool
-> Ship
-> LegacyBootEvent
-> RAcquire PierEnv (Serf, EventLog)
booted vSlog pill lite ship boot = do
rio $ bootNewShip pill lite ship boot
resumed vSlog Nothing
rio $ logTrace "BootSeq Computed"
bootSeqJobs :: Time.Wen -> BootSeq -> [Job]
bootSeqJobs now (BootSeq ident nocks ovums) = zipWith ($) bootSeqFns [1 ..]
where
wen :: EventId -> Time.Wen
wen off = Time.addGap now ((fromIntegral off - 1) ^. from Time.microSecs)
bootSeqFns :: [EventId -> Job]
bootSeqFns = fmap nockJob nocks <> fmap ovumJob ovums
where
nockJob nok eId = RunNok $ LifeCyc eId 0 nok
ovumJob ov eId = DoWork $ Work eId 0 (wen eId) ov
bootNewShip
:: HasPierEnv e
=> Pill
-> Bool
-> Ship
-> LegacyBootEvent
-> RIO e ()
bootNewShip pill lite ship bootEv = do
seq@(BootSeq ident x y) <- genBootSeq ship pill lite bootEv
logDebug "BootSeq Computed"
pierPath <- view pierPathL
liftRIO (setupPierDirectory pierPath)
rio (setupPierDirectory pierPath)
logDebug "Directory setup."
rio $ logTrace "Directory Setup"
let logPath = (pierPath </> ".urb/log")
log <- Log.new (pierPath <> "/.urb/log") ident
rwith (Log.new logPath ident) $ \log -> do
logDebug "Event log onitialized."
jobs <- (\now -> bootSeqJobs now seq) <$> io Time.now
writeJobs log (fromList jobs)
rio $ logTrace "Event Log Initialized"
serf <- Serf.run (Serf.Config pierPath flags)
rio $ logTrace "Serf Started"
rio $ do
(events, serfSt) <- Serf.bootFromSeq serf seq
logTrace "Boot Sequence completed"
Serf.snapshot serf serfSt
logTrace "Snapshot taken"
writeJobs log (fromList events)
logTrace "Events written"
pure (serf, log, serfSt)
logDebug "Finsihed populating event log with boot sequence"
-- Resume an existing ship. ----------------------------------------------------
resumed :: (HasStderrLogFunc e, HasPierConfig e, HasLogFunc e)
=> Maybe Word64 -> Serf.Flags
-> RAcquire e (Serf e, EventLog, SerfState)
resumed event flags = do
rio $ logTrace "Resuming ship"
top <- view pierPathL
tap <- fmap (fromMaybe top) $ rio $ runMaybeT $ do
ev <- MaybeT (pure event)
MaybeT (getSnapshot top ev)
resumed
:: TVar (Text -> IO ())
-> Maybe Word64
-> RAcquire PierEnv (Serf, EventLog)
resumed vSlog replayUntil = do
rio $ logTrace "Resuming ship"
top <- view pierPathL
tap <- fmap (fromMaybe top) $ rio $ runMaybeT $ do
ev <- MaybeT (pure replayUntil)
MaybeT (getSnapshot top ev)
rio $ logTrace $ display @Text ("pier: " <> pack top)
rio $ logTrace $ display @Text ("running serf in: " <> pack tap)
rio $ do
logTrace $ display @Text ("pier: " <> pack top)
logTrace $ display @Text ("running serf in: " <> pack tap)
log <- Log.existing (top <> "/.urb/log")
log <- Log.existing (top </> ".urb/log")
serf <- runSerf vSlog tap
serf <- Serf.run (Serf.Config tap flags)
rio $ do
logDebug "Replaying events"
Serf.execReplay serf log replayUntil >>= \case
Left err -> error (show err)
Right 0 -> do
logDebug "No work during replay so no snapshot"
pure ()
Right _ -> do
logDebug "Taking snapshot"
io (Serf.snapshot serf)
logDebug "SNAPSHOT TAKEN"
serfSt <- rio $ Serf.replay serf log event
pure (serf, log)
rio $ Serf.snapshot serf serfSt
pure (serf, log, serfSt)
getSnapshot :: forall e. FilePath -> Word64 -> RIO e (Maybe FilePath)
-- | Get a fake pier directory for partial snapshots.
getSnapshot :: forall e . FilePath -> Word64 -> RIO e (Maybe FilePath)
getSnapshot top last = do
lastSnapshot <- lastMay <$> listReplays
pure (replayToPath <$> lastSnapshot)
where
replayDir = top </> ".partial-replay"
replayToPath eId = replayDir </> show eId
lastSnapshot <- lastMay <$> listReplays
pure (replayToPath <$> lastSnapshot)
where
replayDir = top </> ".partial-replay"
replayToPath eId = replayDir </> show eId
listReplays :: RIO e [Word64]
listReplays = do
createDirectoryIfMissing True replayDir
snapshotNums <- mapMaybe readMay <$> listDirectory replayDir
pure $ sort (filter (<= fromIntegral last) snapshotNums)
-- Utils for Spawning Worker Threads -------------------------------------------
acquireWorker :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
acquireWorker nam act = mkRAcquire (async act) kill
where
kill tid = do
logDebug ("Killing worker thread: " <> display nam)
cancel tid
acquireWorkerBound :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
where
kill tid = do
logDebug ("Killing worker thread: " <> display nam)
cancel tid
listReplays :: RIO e [Word64]
listReplays = do
createDirectoryIfMissing True replayDir
snapshotNums <- mapMaybe readMay <$> listDirectory replayDir
pure $ sort (filter (<= fromIntegral last) snapshotNums)
-- Run Pier --------------------------------------------------------------------
acquireWorker :: RIO e () -> RAcquire e (Async ())
acquireWorker act = mkRAcquire (async act) cancel
pier
:: (Serf, EventLog)
-> TVar (Text -> IO ())
-> MVar ()
-> MultiEyreApi
-> RAcquire PierEnv ()
pier (serf, log) vSlog startedSig multi = do
let logId = Log.identity log :: LogIdentity
let ship = who logId :: Ship
pier :: ∀e. (HasConfigDir e, HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
=> (Serf e, EventLog, SerfState)
-> MVar ()
-> RAcquire e ()
pier (serf, log, ss) mStart = do
computeQ <- newTQueueIO
persistQ <- newTQueueIO
executeQ <- newTQueueIO
saveM <- newEmptyTMVarIO
shutdownM <- newEmptyTMVarIO
-- TODO Instead of using a TMVar, pull directly from the IO driver
-- event sources.
computeQ :: TMVar RunReq <- newEmptyTMVarIO
kapi ← King.kingAPI
persistQ :: TQueue (Fact, FX) <- newTQueueIO
executeQ :: TQueue FX <- newTQueueIO
saveSig :: TMVar () <- newEmptyTMVarIO
kingApi :: King.King <- King.kingAPI
termApiQ <- atomically $ do
q <- newTQueue
writeTVar (King.kTermConn kapi) (Just $ writeTQueue q)
pure q
termApiQ :: TQueue TermConn <- atomically $ do
q <- newTQueue
writeTVar (King.kTermConn kingApi) (Just $ writeTQueue q)
pure q
let shutdownEvent = putTMVar shutdownM ()
(demux :: Term.Demux, muxed :: Term.Client) <- atomically $ do
res <- Term.mkDemux
pure (res, Term.useDemux res)
inst <- io (KingId . UV . fromIntegral <$> randomIO @Word16)
void $ acquireWorker "TERMSERV Listener" $ forever $ do
logDebug "TERMSERV Waiting for external terminal."
atomically $ do
ext <- Term.connClient <$> readTQueue termApiQ
Term.addDemux ext demux
logDebug "TERMSERV External terminal connected."
-- (sz, local) <- Term.localClient
-- Slogs go to both stderr and to the terminal.
env <- ask
atomically $ writeTVar vSlog $ \txt -> runRIO env $ do
atomically $ Term.trace muxed txt
logOther "serf" (display $ T.strip txt)
-- (waitExternalTerm, termServPort) <- Term.termServer
-- Our call above to set the logging function which echos errors from the
-- Serf doesn't have the appended \r\n because those \r\n s are added in
-- the c serf code. Logging output from our haskell process must manually
-- add them.
let compute = putTMVar computeQ
let execute = writeTQueue executeQ
let persist = writeTQueue persistQ
let sigint = Serf.sendSIGINT serf
(demux, muxed) <- atomically $ do
res <- Term.mkDemux
-- Term.addDemux local res
pure (res, Term.useDemux res)
(bootEvents, startDrivers) <- do
env <- ask
let err = atomically . Term.trace muxed . (<> "\r\n")
let siz = TermSize { tsWide = 80, tsTall = 24 }
let fak = isFake logId
drivers env multi ship fak compute (siz, muxed) err sigint
-- rio $ logInfo $ display $
-- "TERMSERV Terminal Server running on port: " <> tshow termServPort
scrySig <- newEmptyTMVarIO
onKill <- view onKillPierSigL
acquireWorker $ forever $ do
logTrace "TERMSERV Waiting for external terminal."
atomically $ do
ext <- Term.connClient <$> readTQueue termApiQ
Term.addDemux ext demux
logTrace "TERMSERV External terminal connected."
let computeConfig = ComputeConfig { ccOnWork = takeTMVar computeQ
, ccOnKill = onKill
, ccOnSave = takeTMVar saveSig
, ccOnScry = takeTMVar scrySig
, ccPutResult = persist
, ccShowSpinner = Term.spin muxed
, ccHideSpinner = Term.stopSpin muxed
, ccLastEvInLog = Log.lastEv log
}
swapMVar (sStderr serf) (atomically . Term.trace muxed)
tSerf <- acquireWorker "Serf" (runCompute serf computeConfig)
let logId = Log.identity log
let ship = who logId
-- Run all born events and retry them until they succeed.
wackEv <- EvBlip . BlipEvArvo . ArvoEvWack () <$> genEntropy
rio $ for_ (wackEv : bootEvents) $ \ev -> do
okaySig <- newEmptyMVar
-- Our call above to set the logging function which echos errors from the
-- Serf doesn't have the appended \r\n because those \r\n s are added in
-- the c serf code. Logging output from our haskell process must manually
-- add them.
let showErr = atomically . Term.trace muxed . (flip append "\r\n")
let (bootEvents, startDrivers) =
drivers inst ship (isFake logId)
(writeTQueue computeQ)
shutdownEvent
(TermSize{tsWide=80, tsTall=24}, muxed)
showErr
let inject n = atomically $ compute $ RRWork $ EvErr ev $ cb n
io $ atomically $ for_ bootEvents (writeTQueue computeQ)
-- TODO Make sure this dies cleanly.
cb :: Int -> WorkError -> IO ()
cb n | n >= 3 = error ("boot event failed: " <> show ev)
cb n = \case
RunOkay _ -> putMVar okaySig ()
RunSwap _ _ _ _ _ -> putMVar okaySig ()
RunBail _ -> inject (n + 1)
tExe <- startDrivers >>= router (readTQueue executeQ)
tDisk <- runPersist log persistQ (writeTQueue executeQ)
tCpu <- runCompute serf ss
(readTQueue computeQ)
(takeTMVar saveM)
(takeTMVar shutdownM)
(Term.spin muxed)
(Term.stopSpin muxed)
(writeTQueue persistQ)
-- logTrace ("[BOOT EVENT]: " <> display (summarizeEvent ev))
io (inject 0)
tSaveSignal <- saveSignalThread saveM
let slog :: Text -> IO ()
slog txt = do
fn <- atomically (readTVar vSlog)
fn txt
putMVar mStart ()
drivz <- startDrivers
tExec <- acquireWorker "Effects" (router slog (readTQueue executeQ) drivz)
tDisk <- acquireWorkerBound "Persist" (runPersist log persistQ execute)
-- Wait for something to die.
let snapshotEverySecs = 120
let ded = asum [ death "effect thread" tExe
, death "persist thread" tDisk
, death "compute thread" tCpu
]
void $ acquireWorker "Save" $ forever $ do
threadDelay (snapshotEverySecs * 1_000_000)
void $ atomically $ tryPutTMVar saveSig ()
atomically ded >>= \case
Left (txt, exn) -> logError $ displayShow ("Somthing died", txt, exn)
Right tag -> logError $ displayShow ("something simply exited", tag)
-- TODO bullshit scry tester
when False $ do
void $ acquireWorker "bullshit scry tester" $ do
env <- ask
forever $ do
threadDelay 15_000_000
wen <- io Time.now
let kal = \mTermNoun -> runRIO env $ do
logDebug $ displayShow ("scry result: ", mTermNoun)
let nkt = MkKnot $ tshow $ Time.MkDate wen
let pax = Path ["j", "~zod", "life", nkt, "~zod"]
atomically $ putTMVar scrySig (wen, Nothing, pax, kal)
atomically $ (Term.spin muxed) (Just "shutdown")
putMVar startedSig ()
-- Wait for something to die.
let ded = asum
[ death "effects thread" tExec
, death "persist thread" tDisk
, death "compute thread" tSerf
]
atomically ded >>= \case
Left (tag, exn) -> logError $ displayShow (tag, "crashed", exn)
Right "compute thread" -> pure ()
Right tag -> logError $ displayShow (tag, "exited unexpectly")
atomically $ (Term.spin muxed) (Just "shutdown")
death :: Text -> Async () -> STM (Either (Text, SomeException) Text)
death tag tid = do
waitCatchSTM tid <&> \case
Left exn -> Left (tag, exn)
Right () -> Right tag
Left exn -> Left (tag, exn)
Right () -> Right tag
saveSignalThread :: TMVar () -> RAcquire e (Async ())
saveSignalThread tm = mkRAcquire start cancel
where
start = async $ forever $ do
threadDelay (120 * 1000000) -- 120 seconds
atomically $ putTMVar tm ()
-- Start All Drivers -----------------------------------------------------------
data Drivers e = Drivers
{ dAmes :: EffCb e AmesEf
, dBehn :: EffCb e BehnEf
, dHttpClient :: EffCb e HttpClientEf
, dHttpServer :: EffCb e HttpServerEf
, dNewt :: EffCb e NewtEf
, dSync :: EffCb e SyncEf
, dTerm :: EffCb e TermEf
}
data Drivers = Drivers
{ dBehn :: BehnEf -> IO ()
, dIris :: HttpClientEf -> IO ()
, dEyre :: HttpServerEf -> IO ()
, dNewt :: NewtEf -> IO ()
, dSync :: SyncEf -> IO ()
, dTerm :: TermEf -> IO ()
}
drivers :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
=> KingId -> Ship -> Bool -> (Ev -> STM ())
-> STM()
-> (TermSize, Term.Client)
-> (Text -> RIO e ())
-> ([Ev], RAcquire e (Drivers e))
drivers inst who isFake plan shutdownSTM termSys stderr =
(initialEvents, runDrivers)
where
(behnBorn, runBehn) = behn inst plan
(amesBorn, runAmes) = ames inst who isFake plan stderr
(httpBorn, runHttp) = serv inst plan isFake
(clayBorn, runClay) = clay inst plan
(irisBorn, runIris) = client inst plan
(termBorn, runTerm) = Term.term termSys shutdownSTM inst plan
initialEvents = mconcat [behnBorn, clayBorn, amesBorn, httpBorn,
termBorn, irisBorn]
runDrivers = do
dNewt <- runAmes
dBehn <- liftAcquire $ runBehn
dAmes <- pure $ const $ pure ()
dHttpClient <- runIris
dHttpServer <- runHttp
dSync <- runClay
dTerm <- runTerm
pure (Drivers{..})
drivers
:: HasPierEnv e
=> e
-> MultiEyreApi
-> Ship
-> Bool
-> (RunReq -> STM ())
-> (TermSize, Term.Client)
-> (Text -> RIO e ())
-> IO ()
-> RAcquire e ([Ev], RAcquire e Drivers)
drivers env multi who isFake plan termSys stderr serfSIGINT = do
(behnBorn, runBehn) <- rio Behn.behn'
(termBorn, runTerm) <- rio (Term.term' termSys serfSIGINT)
(amesBorn, runAmes) <- rio (Ames.ames' who isFake stderr)
(httpBorn, runEyre) <- rio (Eyre.eyre' multi who isFake)
(clayBorn, runClay) <- rio Clay.clay'
(irisBorn, runIris) <- rio Iris.client'
let initialEvents = mconcat [behnBorn,clayBorn,amesBorn,httpBorn,irisBorn,termBorn]
let runDrivers = do
behn <- runBehn
term <- runTerm
ames <- runAmes
iris <- runIris
eyre <- runEyre
clay <- runClay
-- Sources lower in the list are starved until sources above them
-- have no events to offer.
acquireWorker "Event Prioritization" $ forever $ atomically $ do
let x = diEventSource
let eventSources = [x term, x clay, x behn, x iris, x eyre, x ames]
pullEvent eventSources >>= \case
Nothing -> retry
Just rr -> plan rr
pure $ Drivers
{ dTerm = diOnEffect term
, dBehn = diOnEffect behn
, dNewt = diOnEffect ames
, dIris = diOnEffect iris
, dEyre = diOnEffect eyre
, dSync = diOnEffect clay
}
pure (initialEvents, runDrivers)
where
pullEvent :: [STM (Maybe a)] -> STM (Maybe a)
pullEvent [] = pure Nothing
pullEvent (d:ds) = d >>= \case
Just r -> pure (Just r)
Nothing -> pullEvent ds
-- Route Effects to Drivers ----------------------------------------------------
router :: HasLogFunc e => STM FX -> Drivers e -> RAcquire e (Async ())
router waitFx Drivers{..} =
mkRAcquire start cancel
where
start = async $ forever $ do
fx <- atomically waitFx
for_ fx $ \ef -> do
logEffect ef
case ef of
GoodParse (EfVega _ _) -> error "TODO"
GoodParse (EfExit _ _) -> error "TODO"
GoodParse (EfVane (VEAmes ef)) -> dAmes ef
GoodParse (EfVane (VEBehn ef)) -> dBehn ef
GoodParse (EfVane (VEBoat ef)) -> dSync ef
GoodParse (EfVane (VEClay ef)) -> dSync ef
GoodParse (EfVane (VEHttpClient ef)) -> dHttpClient ef
GoodParse (EfVane (VEHttpServer ef)) -> dHttpServer ef
GoodParse (EfVane (VENewt ef)) -> dNewt ef
GoodParse (EfVane (VESync ef)) -> dSync ef
GoodParse (EfVane (VETerm ef)) -> dTerm ef
FailParse n -> logError
$ display
$ pack @Text (ppShow n)
router :: HasPierEnv e => (Text -> IO ()) -> STM FX -> Drivers -> RIO e ()
router slog waitFx Drivers {..} = do
kill <- view killPierActionL
let exit = io (slog "<<<shutdown>>>\r\n") >> atomically kill
let vega = io (slog "<<<reset>>>\r\n")
forever $ do
fx <- atomically waitFx
for_ fx $ \ef -> do
logEffect ef
case ef of
GoodParse (EfVega _ _ ) -> vega
GoodParse (EfExit _ _ ) -> exit
GoodParse (EfVane (VEBehn ef)) -> io (dBehn ef)
GoodParse (EfVane (VEBoat ef)) -> io (dSync ef)
GoodParse (EfVane (VEClay ef)) -> io (dSync ef)
GoodParse (EfVane (VEHttpClient ef)) -> io (dIris ef)
GoodParse (EfVane (VEHttpServer ef)) -> io (dEyre ef)
GoodParse (EfVane (VENewt ef)) -> io (dNewt ef)
GoodParse (EfVane (VESync ef)) -> io (dSync ef)
GoodParse (EfVane (VETerm ef)) -> io (dTerm ef)
FailParse n -> logError $ display $ pack @Text (ppShow n)
-- Compute Thread --------------------------------------------------------------
data ComputeRequest
= CREvent Ev
| CRSave ()
| CRShutdown ()
deriving (Eq, Show)
-- Compute (Serf) Thread -------------------------------------------------------
logEvent :: HasLogFunc e => Ev -> RIO e ()
logEvent ev =
logDebug $ display $ "[EVENT]\n" <> pretty
where
pretty :: Text
pretty = pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow ev
logEvent ev = do
logTrace $ "<- " <> display (summarizeEvent ev)
logDebug $ "[EVENT]\n" <> display pretty
where
pretty :: Text
pretty = pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow ev
logEffect :: HasLogFunc e => Lenient Ef -> RIO e ()
logEffect ef =
logDebug $ display $ "[EFFECT]\n" <> pretty ef
where
pretty :: Lenient Ef -> Text
pretty = \case
GoodParse e -> pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow e
FailParse n -> pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow n
logEffect ef = do
logTrace $ " -> " <> display (summarizeEffect ef)
logDebug $ display $ "[EFFECT]\n" <> pretty ef
where
pretty :: Lenient Ef -> Text
pretty = \case
GoodParse e -> pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow e
FailParse n -> pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow n
runCompute :: ∀e. HasLogFunc e
=> Serf e
-> SerfState
-> STM Ev
-> STM ()
-> STM ()
-> (Maybe Text -> STM ())
-> STM ()
-> ((Job, FX) -> STM ())
-> RAcquire e (Async ())
runCompute serf ss getEvent getSaveSignal getShutdownSignal
showSpinner hideSpinner putResult =
mkRAcquire (async (go ss)) cancel
where
go :: SerfState -> RIO e ()
go ss = do
cr <- atomically $
CRShutdown <$> getShutdownSignal <|>
CRSave <$> getSaveSignal <|>
CREvent <$> getEvent
case cr of
CREvent ev -> do
logEvent ev
wen <- io Time.now
eId <- pure (ssNextEv ss)
mug <- pure (ssLastMug ss)
data ComputeConfig = ComputeConfig
{ ccOnWork :: STM RunReq
, ccOnKill :: STM ()
, ccOnSave :: STM ()
, ccOnScry :: STM (Wen, Gang, Path, Maybe (Term, Noun) -> IO ())
, ccPutResult :: (Fact, FX) -> STM ()
, ccShowSpinner :: Maybe Text -> STM ()
, ccHideSpinner :: STM ()
, ccLastEvInLog :: STM EventId
}
atomically $ showSpinner (getSpinnerNameForEvent ev)
(job', ss', fx) <- doJob serf $ DoWork $ Work eId mug wen ev
atomically $ hideSpinner
atomically (putResult (job', fx))
go ss'
CRSave () -> do
logDebug $ "Taking periodic snapshot"
Serf.snapshot serf ss
go ss
CRShutdown () -> do
-- When shutting down, we first request a snapshot, and then we
-- just exit this recursive processing, which will cause the serf
-- to exit from its RAcquire.
logDebug $ "Shutting down compute system..."
Serf.snapshot serf ss
pure ()
runCompute :: forall e . HasKingEnv e => Serf.Serf -> ComputeConfig -> RIO e ()
runCompute serf ComputeConfig {..} = do
logDebug "runCompute"
let onRR = asum [ ccOnKill <&> Serf.RRKill
, ccOnSave <&> Serf.RRSave
, ccOnWork
, ccOnScry <&> \(w,g,p,k) -> Serf.RRScry w g p k
]
vEvProcessing :: TMVar Ev <- newEmptyTMVarIO
void $ async $ forever (atomically (takeTMVar vEvProcessing) >>= logEvent)
let onSpin :: Maybe Ev -> STM ()
onSpin = \case
Nothing -> ccHideSpinner
Just ev -> do
ccShowSpinner (getSpinnerNameForEvent ev)
putTMVar vEvProcessing ev
let maxBatchSize = 10
io (Serf.run serf maxBatchSize ccLastEvInLog onRR ccPutResult onSpin)
-- Persist Thread --------------------------------------------------------------
-- Event-Log Persistence Thread ------------------------------------------------
data PersistExn = BadEventId EventId EventId
deriving Show
@ -418,43 +558,36 @@ instance Exception PersistExn where
, "\tExpected " <> show expected <> " but got " <> show got
]
runPersist :: ∀e. (HasPierConfig e, HasLogFunc e)
=> EventLog
-> TQueue (Job, FX)
-> (FX -> STM ())
-> RAcquire e (Async ())
runPersist log inpQ out =
mkRAcquire runThread cancel
where
runThread :: RIO e (Async ())
runThread = asyncBound $ do
dryRun <- view dryRunL
forever $ do
writs <- atomically getBatchFromQueue
unless dryRun $ do
events <- validateJobsAndGetBytes (toNullable writs)
Log.appendEvents log events
atomically $ for_ writs $ \(_,fx) -> out fx
runPersist
:: forall e
. HasPierEnv e
=> EventLog
-> TQueue (Fact, FX)
-> (FX -> STM ())
-> RIO e ()
runPersist log inpQ out = do
dryRun <- view dryRunL
forever $ do
writs <- atomically getBatchFromQueue
events <- validateFactsAndGetBytes (fst <$> toNullable writs)
unless dryRun (Log.appendEvents log events)
atomically $ for_ writs $ \(_, fx) -> do
out fx
validateJobsAndGetBytes :: [(Job, FX)] -> RIO e (Vector ByteString)
validateJobsAndGetBytes writs = do
expect <- Log.nextEv log
fmap fromList
$ for (zip [expect..] writs)
$ \(expectedId, (j, fx)) -> do
unless (expectedId == jobId j) $
throwIO (BadEventId expectedId (jobId j))
case j of
RunNok _ ->
error "This shouldn't happen here!"
DoWork (Work eId mug wen ev) ->
pure $ jamBS $ toNoun (mug, wen, ev)
where
validateFactsAndGetBytes :: [Fact] -> RIO e (Vector ByteString)
validateFactsAndGetBytes facts = do
expect <- atomically (Log.nextEv log)
lis <- for (zip [expect ..] facts) $ \(expectedId, Fact eve mug wen non) ->
do
unless (expectedId == eve) $ do
throwIO (BadEventId expectedId eve)
pure $ jamBS $ toNoun (mug, wen, non)
pure (fromList lis)
getBatchFromQueue :: STM (NonNull [(Job, FX)])
getBatchFromQueue =
readTQueue inpQ >>= go . singleton
where
go acc =
tryReadTQueue inpQ >>= \case
Nothing -> pure (reverse acc)
Just item -> go (item <| acc)
getBatchFromQueue :: STM (NonNull [(Fact, FX)])
getBatchFromQueue = readTQueue inpQ >>= go . singleton
where
go acc = tryReadTQueue inpQ >>= \case
Nothing -> pure (reverse acc)
Just item -> go (item <| acc)

83
pkg/hs/urbit-king/lib/Urbit/Vere/Pier/Types.hs
View File

@ -3,12 +3,27 @@
TODO Most of these could probably find better homes.
-}
module Urbit.Vere.Pier.Types where
module Urbit.Vere.Pier.Types
( module Urbit.Vere.Serf.Types
, LogIdentity(..)
, Pill(..)
, Job(..)
, LifeCyc(..)
, BootSeq(..)
, Work(..)
, jobId
, jobMug
, DriverApi(..)
)
where
import Urbit.Prelude hiding (Term)
import Urbit.Arvo
import Urbit.Time
import Urbit.Noun.Time
import Urbit.Vere.Serf.Types
import Urbit.EventLog.LMDB (LogIdentity(..))
-- Avoid touching Nock values. -------------------------------------------------
@ -29,25 +44,16 @@ instance Show Nock where
--------------------------------------------------------------------------------
type EventId = Word64
data Pill = Pill
{ pBootFormulas :: [Nock]
, pKernelOvums :: [Ev]
, pUserspaceOvums :: [Ev]
}
deriving (Eq, Show)
data LogIdentity = LogIdentity
{ who :: Ship
, isFake :: Bool
, lifecycleLen :: Word
} deriving (Eq, Ord, Show)
{ pBootFormulas :: [Nock]
, pKernelOvums :: [Ev]
, pUserspaceOvums :: [Ev]
}
deriving (Eq, Show)
data BootSeq = BootSeq LogIdentity [Nock] [Ev]
deriving (Eq, Show)
deriveNoun ''LogIdentity
deriveNoun ''Pill
@ -60,40 +66,25 @@ data LifeCyc = LifeCyc EventId Mug Nock
deriving (Eq, Show)
data Job
= DoWork Work
| RunNok LifeCyc
deriving (Eq, Show)
= DoWork Work
| RunNok LifeCyc
deriving (Eq, Show)
jobId :: Job -> EventId
jobId (RunNok (LifeCyc eId _ _)) = eId
jobId (DoWork (Work eId _ _ _)) = eId
jobId (DoWork (Work eId _ _ _ )) = eId
jobMug :: Job -> Mug
jobMug (RunNok (LifeCyc _ mug _)) = mug
jobMug (DoWork (Work _ mug _ _)) = mug
jobMug (DoWork (Work _ mug _ _ )) = mug
--------------------------------------------------------------------------------
-- API To IO Drivers -----------------------------------------------------------
data Order
= OBoot Word -- lifecycle length
| OExit Word8
| OSave EventId
| OWork Job
deriving (Eq, Show)
deriveToNoun ''Order
type QueueEv = Ev -> STM ()
type EffCb e a = a -> RIO e ()
type Perform = Ef -> IO ()
data IODriver = IODriver
{ bornEvent :: IO Ev
, startDriver :: (Ev -> STM ()) -> IO (Async (), Perform)
}
data DriverApi ef = DriverApi
{ diEventSource :: STM (Maybe RunReq)
, diOnEffect :: ef -> IO ()
}
-- Instances -------------------------------------------------------------------
@ -102,17 +93,17 @@ instance ToNoun Work where
toNoun (Work eid m d o) = toNoun (eid, Jammed (m, d, o))
instance FromNoun Work where
parseNoun n = named "Work" $ do
(eid, Jammed (m, d, o)) <- parseNoun n
pure (Work eid m d o)
parseNoun n = named "Work" $ do
(eid, Jammed (m, d, o)) <- parseNoun n
pure (Work eid m d o)
instance ToNoun LifeCyc where
toNoun (LifeCyc eid m n) = toNoun (eid, Jammed (m, n))
instance FromNoun LifeCyc where
parseNoun n = named "LifeCyc" $ do
(eid, Jammed (m, n)) <- parseNoun n
pure (LifeCyc eid m n)
(eid, Jammed (m, n)) <- parseNoun n
pure (LifeCyc eid m n)
-- | No FromNoun instance, because it depends on context (lifecycle length)
instance ToNoun Job where

613
pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs
View File

@ -1,547 +1,162 @@
{-|
Serf Interface
TODO: `recvLen` is not big-endian safe.
High-Level Serf Interface
-}
module Urbit.Vere.Serf ( Serf, sStderr, SerfState(..), doJob
, run, shutdown, kill
, replay, bootFromSeq, snapshot
, collectFX
, Config(..), Flags, Flag(..)
) where
module Urbit.Vere.Serf
( withSerf
, execReplay
, collectFX
, module X
)
where
import Urbit.Prelude
import Data.Conduit
import System.Process
import System.ProgressBar
import Urbit.Arvo
import Urbit.Vere.Pier.Types
import Urbit.Vere.Serf.IPC
import Data.Bits (setBit)
import Data.ByteString (hGet)
import Data.ByteString.Unsafe (unsafeUseAsCString)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, poke)
import System.Exit (ExitCode)
import Urbit.King.App (HasStderrLogFunc(..))
import Control.Monad.Trans.Resource (runResourceT)
import Urbit.Arvo (FX)
import Urbit.King.App.Class (HasStderrLogFunc(..))
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Conduit.Combinators as CC
import qualified Data.Text as T
import qualified System.IO as IO
import qualified System.IO.Error as IO
import qualified Urbit.Ob as Ob
import qualified Urbit.Time as Time
import qualified Urbit.Vere.Log as Log
import qualified System.ProgressBar as PB
import qualified Urbit.EventLog.LMDB as Log
-- Serf Config -----------------------------------------------------------------
type Flags = [Flag]
data Flag
= DebugRam
| DebugCpu
| CheckCorrupt
| CheckFatal
| Verbose
| DryRun
| Quiet
| Hashless
| Trace
deriving (Eq, Ord, Show, Enum, Bounded)
compileFlags :: [Flag] -> Word
compileFlags = foldl' (\acc flag -> setBit acc (fromEnum flag)) 0
data Config = Config FilePath [Flag]
deriving (Show)
serf :: HasLogFunc e => Text -> RIO e ()
serf msg = logInfo $ display ("SERF: " <> msg)
-- Types -----------------------------------------------------------------------
data SerfState = SerfState
{ ssNextEv :: EventId
, ssLastMug :: Mug
}
deriving (Eq, Ord, Show)
ssLastEv :: SerfState -> EventId
ssLastEv = pred . ssNextEv
data Serf e = Serf
{ sendHandle :: Handle
, recvHandle :: Handle
, process :: ProcessHandle
, sStderr :: MVar (Text -> RIO e ())
}
data ShipId = ShipId Ship Bool
deriving (Eq, Ord, Show)
data Plea
= PPlay EventId Mug
| PWork Work
| PDone EventId Mug FX
| PStdr EventId Cord
| PSlog EventId Word32 Tank
deriving (Eq, Show)
type ReplacementEv = Job
type WorkResult = (SerfState, FX)
type SerfResp = Either ReplacementEv WorkResult
data SerfExn
= BadComputeId EventId WorkResult
| BadReplacementId EventId ReplacementEv
| UnexpectedPlay EventId (EventId, Mug)
| BadPleaAtom Atom
| BadPleaNoun Noun [Text] Text
| ReplacedEventDuringReplay EventId ReplacementEv
| ReplacedEventDuringBoot EventId ReplacementEv
| EffectsDuringBoot EventId FX
| SerfConnectionClosed
| UnexpectedPleaOnNewShip Plea
| InvalidInitialPlea Plea
deriving (Show)
-- Instances -------------------------------------------------------------------
instance Exception SerfExn
deriveNoun ''ShipId
deriveNoun ''Plea
-- Utils -----------------------------------------------------------------------
printTank :: HasLogFunc e
=> MVar (Text -> RIO e ()) -> Word32 -> Tank
-> RIO e ()
printTank log _pri = printErr log . unlines . fmap unTape . wash (WashCfg 0 80)
guardExn :: (Exception e, MonadIO m) => Bool -> e -> m ()
guardExn ok = io . unless ok . throwIO
fromRightExn :: (Exception e, MonadIO m) => Either a b -> (a -> e) -> m b
fromRightExn (Left m) exn = throwIO (exn m)
fromRightExn (Right x) _ = pure x
printErr :: MVar (Text -> RIO e ()) -> Text -> RIO e ()
printErr m txt = do
f <- readMVar m
f txt
-- Process Management ----------------------------------------------------------
run :: HasLogFunc e => Config -> RAcquire e (Serf e)
run config = mkRAcquire (startUp config) tearDown
startUp :: HasLogFunc e => Config -> RIO e (Serf e)
startUp conf@(Config pierPath flags) = do
logTrace "STARTING SERF"
logTrace (displayShow conf)
(i, o, e, p) <- io $ do
(Just i, Just o, Just e, p) <- createProcess pSpec
pure (i, o, e, p)
stderr <- newMVar serf
async (readStdErr e stderr)
pure (Serf i o p stderr)
where
diskKey = ""
config = show (compileFlags flags)
args = [pierPath, diskKey, config]
pSpec = (proc "urbit-worker" args)
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
readStdErr :: ∀e. HasLogFunc e => Handle -> MVar (Text -> RIO e ()) -> RIO e ()
readStdErr h print =
untilEOFExn $ do
raw <- io $ IO.hGetLine h
let ln = T.strip (pack raw)
printErr print ln
serf ("[stderr] " <> ln)
where
eofMsg = "[Serf.readStdErr] serf stderr closed"
untilEOFExn :: RIO e () -> RIO e ()
untilEOFExn act = loop
where
loop :: RIO e ()
loop = do
env <- ask
res <- io $ IO.tryIOError $ runRIO env act
case res of
Left exn | IO.isEOFError exn -> logDebug eofMsg
Left exn -> io (IO.ioError exn)
Right () -> loop
tearDown :: HasLogFunc e => Serf e -> RIO e ()
tearDown serf = do
io $ terminateProcess (process serf)
void $ waitForExit serf
-- race_ waitThenKill (shutdownAndWait serf 0)
where
-- killedMsg =
-- "[Serf.tearDown]: Serf didn't die when asked, killing it"
-- waitThenKill = do
-- threadDelay 1000000
-- debug killedMsg
-- terminateProcess (process serf)
waitForExit :: HasLogFunc e => Serf e -> RIO e ExitCode
waitForExit = io . waitForProcess . process
kill :: HasLogFunc e => Serf e -> RIO e ExitCode
kill serf = io (terminateProcess $ process serf) >> waitForExit serf
_shutdownAndWait :: HasLogFunc e => Serf e -> Word8 -> RIO e ExitCode
_shutdownAndWait serf code = do
shutdown serf code
waitForExit serf
-- Basic Send and Receive Operations -------------------------------------------
withWord64AsByteString :: Word64 -> (ByteString -> RIO e a) -> RIO e a
withWord64AsByteString w k = do
env <- ask
io $ alloca $ \wp -> do
poke wp w
bs <- BS.unsafePackCStringLen (castPtr wp, 8)
runRIO env (k bs)
sendLen :: HasLogFunc e => Serf e -> Int -> RIO e ()
sendLen s i = do
w <- evaluate (fromIntegral i :: Word64)
withWord64AsByteString (fromIntegral i) (hPut (sendHandle s))
sendOrder :: HasLogFunc e => Serf e -> Order -> RIO e ()
sendOrder w o = do
-- logDebug $ display ("(sendOrder) " <> tshow o)
sendBytes w $ jamBS $ toNoun o
-- logDebug "(sendOrder) Done"
sendBytes :: HasLogFunc e => Serf e -> ByteString -> RIO e ()
sendBytes s bs = handle ioErr $ do
sendLen s (length bs)
hPut (sendHandle s) bs
hFlush (sendHandle s)
where
ioErr :: IOError -> RIO e ()
ioErr _ = throwIO SerfConnectionClosed
recvLen :: (MonadIO m, HasLogFunc e) => Serf e -> m Word64
recvLen w = io $ do
bs <- hGet (recvHandle w) 8
case length bs of
8 -> unsafeUseAsCString bs (peek . castPtr)
_ -> throwIO SerfConnectionClosed
recvBytes :: HasLogFunc e => Serf e -> Word64 -> RIO e ByteString
recvBytes serf =
io . hGet (recvHandle serf) . fromIntegral
recvAtom :: HasLogFunc e => Serf e -> RIO e Atom
recvAtom w = do
len <- recvLen w
bytesAtom <$> recvBytes w len
cordText :: Cord -> Text
cordText = T.strip . unCord
import qualified Urbit.Vere.Serf.IPC as X (Config (..), EvErr (..), Flag (..),
RunReq (..), Serf, WorkError (..),
run, sendSIGINT, snapshot, start,
stop)
--------------------------------------------------------------------------------
snapshot :: HasLogFunc e => Serf e -> SerfState -> RIO e ()
snapshot serf ss = do
logTrace $ display ("Taking snapshot at event " <> tshow (ssLastEv ss))
sendOrder serf $ OSave $ ssLastEv ss
parseLogRow :: MonadIO m => ByteString -> m (Mug, Noun)
parseLogRow = cueBSExn >=> fromNounExn
shutdown :: HasLogFunc e => Serf e -> Word8 -> RIO e ()
shutdown serf code = sendOrder serf (OExit code)
withSerf :: HasLogFunc e => Config -> RAcquire e Serf
withSerf config = mkRAcquire startup kill
where
startup = do
(serf, st) <- io $ start config
logDebug (displayShow ("serf state", st))
pure serf
kill serf = do
void $ rio $ stop serf
{-|
TODO Find a cleaner way to handle `PStdr` Pleas.
-}
recvPlea :: HasLogFunc e => Serf e -> RIO e Plea
recvPlea w = do
logDebug "(recvPlea) Waiting"
a <- recvAtom w
logDebug "(recvPlea) Got atom"
n <- fromRightExn (cue a) (const $ BadPleaAtom a)
p <- fromRightExn (fromNounErr n) (\(p,m) -> BadPleaNoun n p m)
execReplay
:: forall e
. (HasLogFunc e, HasStderrLogFunc e)
=> Serf
-> Log.EventLog
-> Maybe Word64
-> RIO e (Either PlayBail Word)
execReplay serf log last = do
lastEventInSnap <- io (serfLastEventBlocking serf)
if lastEventInSnap == 0 then doBoot else doReplay
where
doBoot :: RIO e (Either PlayBail Word)
doBoot = do
logDebug "Beginning boot sequence"
case p of PStdr e msg -> do printErr (sStderr w) (cordText msg)
recvPlea w
PSlog _ pri t -> do printTank (sStderr w) pri t
recvPlea w
_ -> do logTrace "recvPlea got something else"
pure p
let bootSeqLen = lifecycleLen (Log.identity log)
{-|
Waits for initial plea, and then sends boot IPC if necessary.
-}
handshake :: HasLogFunc e => Serf e -> LogIdentity -> RIO e SerfState
handshake serf ident = do
logTrace "Serf Handshake"
evs <- runConduit $ Log.streamEvents log 1
.| CC.take (fromIntegral bootSeqLen)
.| CC.mapM (fmap snd . parseLogRow)
.| CC.sinkList
ss@SerfState{..} <- recvPlea serf >>= \case
PPlay e m -> pure $ SerfState e m
x -> throwIO (InvalidInitialPlea x)
let numEvs = fromIntegral (length evs)
logTrace $ display ("Handshake result: " <> tshow ss)
when (numEvs /= bootSeqLen) $ do
throwIO (MissingBootEventsInEventLog numEvs bootSeqLen)
when (ssNextEv == 1) $ do
let ev = OBoot (lifecycleLen ident)
logTrace $ display ("No snapshot. Sending boot event: " <> tshow ev)
sendOrder serf ev
logDebug $ display ("Sending " <> tshow numEvs <> " boot events to serf")
logTrace "Finished handshake"
io (boot serf evs) >>= \case
Just err -> do
logDebug "Error on replay, exiting"
pure (Left err)
Nothing -> do
logDebug "Finished boot events, moving on to more events from log."
doReplay <&> \case
Left err -> Left err
Right num -> Right (num + numEvs)
pure ss
sendWork :: ∀e. HasLogFunc e => Serf e -> Job -> RIO e SerfResp
sendWork w job =
do
sendOrder w (OWork job)
res <- loop
logTrace ("[sendWork] Got response")
pure res
where
eId = jobId job
produce :: WorkResult -> RIO e SerfResp
produce (ss@SerfState{..}, o) = do
guardExn (ssNextEv == (1+eId)) (BadComputeId eId (ss, o))
pure $ Right (ss, o)
replace :: ReplacementEv -> RIO e SerfResp
replace job = do
guardExn (jobId job == eId) (BadReplacementId eId job)
pure (Left job)
loop :: RIO e SerfResp
loop = recvPlea w >>= \case
PPlay e m -> throwIO (UnexpectedPlay eId (e, m))
PDone i m o -> produce (SerfState (i+1) m, o)
PWork work -> replace (DoWork work)
PStdr _ cord -> printErr (sStderr w) (cordText cord) >> loop
PSlog _ pri t -> printTank (sStderr w) pri t >> loop
--------------------------------------------------------------------------------
doJob :: HasLogFunc e => Serf e -> Job -> RIO e (Job, SerfState, FX)
doJob serf job = do
sendWork serf job >>= \case
Left replaced -> doJob serf replaced
Right (ss, fx) -> pure (job, ss, fx)
bootJob :: HasLogFunc e => Serf e -> Job -> RIO e (Job, SerfState)
bootJob serf job = do
doJob serf job >>= \case
(job, ss, _) -> pure (job, ss)
-- (job, ss, fx) -> throwIO (EffectsDuringBoot (jobId job) fx)
replayJob :: HasLogFunc e => Serf e -> Job -> RIO e SerfState
replayJob serf job = do
sendWork serf job >>= \case
Left replace -> throwIO (ReplacedEventDuringReplay (jobId job) replace)
Right (ss, _) -> pure ss
--------------------------------------------------------------------------------
updateProgressBar :: HasLogFunc e
=> Int -> Text -> Maybe (ProgressBar ())
-> RIO e (Maybe (ProgressBar ()))
updateProgressBar count startMsg = \case
Nothing -> do
-- We only construct the progress bar on the first time that we
-- process an event so that we don't display an empty progress
-- bar when the snapshot is caught up to the log.
let style = defStyle { stylePrefix = msg (fromStrict startMsg) }
pb <- newProgressBar style 10 (Progress 0 count ())
pure (Just pb)
Just pb -> do
incProgress pb 1
pure (Just pb)
--------------------------------------------------------------------------------
type BootSeqFn = EventId -> Mug -> Time.Wen -> Job
data BootExn = ShipAlreadyBooted
deriving stock (Eq, Ord, Show)
deriving anyclass (Exception)
logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
logStderr action = do
logFunc <- view stderrLogFuncL
runRIO logFunc action
bootFromSeq :: ∀e. (HasStderrLogFunc e, HasLogFunc e)
=> Serf e -> BootSeq -> RIO e ([Job], SerfState)
bootFromSeq serf (BootSeq ident nocks ovums) = do
handshake serf ident >>= \case
ss@(SerfState 1 (Mug 0)) -> loop [] ss Nothing bootSeqFns
_ -> throwIO ShipAlreadyBooted
where
loop :: [Job] -> SerfState -> Maybe (ProgressBar ()) -> [BootSeqFn]
-> RIO e ([Job], SerfState)
loop acc ss pb = \case
[] -> do
pb <- logStderr (updateProgressBar 0 bootMsg pb)
pure (reverse acc, ss)
x:xs -> do
wen <- io Time.now
job <- pure $ x (ssNextEv ss) (ssLastMug ss) wen
pb <- logStderr (updateProgressBar (1 + length xs) bootMsg pb)
(job, ss) <- bootJob serf job
loop (job:acc) ss pb xs
bootSeqFns :: [BootSeqFn]
bootSeqFns = fmap muckNock nocks <> fmap muckOvum ovums
where
muckNock nok eId mug _ = RunNok $ LifeCyc eId mug nok
muckOvum ov eId mug wen = DoWork $ Work eId mug wen ov
bootMsg = "Booting " ++ (fakeStr (isFake ident)) ++
(Ob.renderPatp (Ob.patp (fromIntegral (who ident))))
fakeStr True = "fake "
fakeStr False = ""
{-|
The ship is booted, but it is behind. shove events to the worker
until it is caught up.
-}
replayJobs :: (HasStderrLogFunc e, HasLogFunc e)
=> Serf e -> Int -> SerfState -> ConduitT Job Void (RIO e) SerfState
replayJobs serf lastEv = go Nothing
where
go pb ss = do
await >>= \case
Nothing -> pure ss
Just job -> do
pb <- lift $ logStderr (updatePb ss pb)
played <- lift $ replayJob serf job
go pb played
updatePb ss = do
let start = lastEv - fromIntegral (ssNextEv ss)
let msg = pack ( "Replaying events #" ++ (show (ssNextEv ss))
<> " to #" ++ (show lastEv)
)
updateProgressBar start msg
replay :: (HasStderrLogFunc e, HasLogFunc e)
=> Serf e -> Log.EventLog -> Maybe Word64 -> RIO e SerfState
replay serf log last = do
doReplay :: RIO e (Either PlayBail Word)
doReplay = do
logTrace "Beginning event log replay"
lastEventInSnap <- io (serfLastEventBlocking serf)
last & \case
Nothing -> pure ()
Just lt -> logTrace $ display $
"User requested to replay up to event #" <> tshow lt
ss <- handshake serf (Log.identity log)
logLastEv :: Word64 <- fromIntegral <$> Log.lastEv log
let serfNextEv = ssNextEv ss
lastEventInSnap = serfNextEv - 1
logLastEv :: Word64 <- atomically $ fromIntegral <$> Log.lastEv log
logTrace $ display $ "Last event in event log is #" <> tshow logLastEv
let replayUpTo = fromMaybe logLastEv last
let replayUpTo = min (fromMaybe logLastEv last) logLastEv
let numEvs :: Int = fromIntegral replayUpTo - fromIntegral lastEventInSnap
when (numEvs < 0) $ do
throwIO (SnapshotAheadOfLog logLastEv lastEventInSnap)
incProgress <- logStderr (trackProgress (fromIntegral numEvs))
logTrace $ display $ "Replaying up to event #" <> tshow replayUpTo
logTrace $ display $ "Will replay " <> tshow numEvs <> " in total."
runConduit $ Log.streamEvents log serfNextEv
.| CC.take (fromIntegral numEvs)
.| toJobs (Log.identity log) serfNextEv
.| replayJobs serf (fromIntegral replayUpTo) ss
env <- ask
toJobs :: HasLogFunc e
=> LogIdentity -> EventId -> ConduitT ByteString Job (RIO e) ()
toJobs ident eId =
await >>= \case
Nothing -> lift $ logTrace "[toJobs] no more jobs"
Just at -> do yield =<< lift (fromAtom at)
lift $ logTrace $ display ("[toJobs] " <> tshow eId)
toJobs ident (eId+1)
where
isNock = eId <= fromIntegral (lifecycleLen ident)
res <- runResourceT
$ runConduit
$ Log.streamEvents log (lastEventInSnap + 1)
.| CC.take (fromIntegral numEvs)
.| CC.mapM (fmap snd . parseLogRow)
.| replay 5 incProgress serf
fromAtom :: ByteString -> RIO e Job
fromAtom bs | isNock = do
noun <- cueBSExn bs
(mug, nok) <- fromNounExn noun
pure $ RunNok (LifeCyc eId mug nok)
fromAtom bs = do
noun <- cueBSExn bs
(mug, wen, ovm) <- fromNounExn noun
pure $ DoWork (Work eId mug wen ovm)
res & \case
Nothing -> pure (Right $ fromIntegral numEvs)
Just er -> pure (Left er)
logStderr :: HasStderrLogFunc e => RIO LogFunc a -> RIO e a
logStderr action = do
logFunc <- view stderrLogFuncL
runRIO logFunc action
trackProgress
:: HasLogFunc e
=> Word64
-> RIO e (Int -> IO ())
trackProgress = \case
0 -> pure $ const $ pure ()
num -> do
let style = PB.defStyle { PB.stylePostfix = PB.exact }
let refresh = 10
let init = PB.Progress 0 (fromIntegral num) ()
bar <- PB.newProgressBar style refresh init
env <- ask
let incr = PB.incProgress bar
pure (runRIO env . incr)
-- Collect Effects for Parsing -------------------------------------------------
-- Collect FX ------------------------------------------------------------------
collectFX :: HasLogFunc e => Serf e -> Log.EventLog -> RIO e ()
collectFX :: HasLogFunc e => Serf -> Log.EventLog -> RIO e ()
collectFX serf log = do
ss <- handshake serf (Log.identity log)
lastEv <- io (serfLastEventBlocking serf)
runResourceT
$ runConduit
$ Log.streamEvents log (lastEv + 1)
.| CC.mapM (parseLogRow >=> fromNounExn . snd)
.| swim serf
.| persistFX log
runConduit $ Log.streamEvents log (ssNextEv ss)
.| toJobs (Log.identity log) (ssNextEv ss)
.| doCollectFX serf ss
.| persistFX log
persistFX :: Log.EventLog -> ConduitT (EventId, FX) Void (RIO e) ()
persistFX log = loop
where
loop = await >>= \case
Nothing -> pure ()
Just (eId, fx) -> do
lift $ Log.writeEffectsRow log eId (jamBS $ toNoun fx)
loop
doCollectFX :: ∀e. HasLogFunc e
=> Serf e -> SerfState -> ConduitT Job (EventId, FX) (RIO e) ()
doCollectFX serf = go
where
go :: SerfState -> ConduitT Job (EventId, FX) (RIO e) ()
go ss = await >>= \case
Nothing -> pure ()
Just jb -> do
-- jb <- pure $ replaceMug jb (ssLastMug ss)
(_, ss, fx) <- lift $ doJob serf jb
when (0 == (jobId jb `mod` 10_000)) $ do
lift $ logTrace $ displayShow (jobId jb)
yield (jobId jb, fx)
go ss
_replaceMug :: Job -> Mug -> Job
_replaceMug jb mug =
case jb of
DoWork (Work eId _ w o) -> DoWork (Work eId mug w o)
RunNok (LifeCyc eId _ n) -> RunNok (LifeCyc eId mug n)
persistFX :: MonadIO m => Log.EventLog -> ConduitT (EventId, FX) Void m ()
persistFX log = CC.mapM_ $ \(eId, fx) -> do
Log.writeEffectsRow log eId $ jamBS $ toNoun fx

689
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs Normal file
View File

@ -0,0 +1,689 @@
{-|
Low-Level IPC flows for interacting with the serf process.
- Serf process can be started and shutdown with `start` and `stop`.
- You can ask the serf what it's last event was with
`serfLastEventBlocking`.
- A running serf can be asked to compact it's heap or take a snapshot.
- You can scry into a running serf.
- A running serf can be asked to execute a boot sequence, replay from
existing events, and run a ship with `boot`, `replay`, and `run`.
The `run` and `replay` flows will do batching of events to keep the
IPC pipe full.
```
|%
:: +writ: from king to serf
::
+$ gang (unit (set ship))
+$ writ
$% $: %live
$% [%exit cod=@]
[%save eve=@]
[%pack eve=@]
== ==
[%peek now=date lyc=gang pat=path]
[%play eve=@ lit=(list ?((pair date ovum) *))]
[%work job=(pair date ovum)]
==
:: +plea: from serf to king
::
+$ plea
$% [%live ~]
[%ripe [pro=@ hon=@ nok=@] eve=@ mug=@]
[%slog pri=@ ?(cord tank)]
[%peek dat=(unit (cask))]
$: %play
$% [%done mug=@]
[%bail eve=@ mug=@ dud=goof]
== ==
$: %work
$% [%done eve=@ mug=@ fec=(list ovum)]
[%swap eve=@ mug=@ job=(pair date ovum) fec=(list ovum)]
[%bail lud=(list goof)]
== ==
==
```
-}
module Urbit.Vere.Serf.IPC
( Serf
, start
, stop
, serfLastEventBlocking
, snapshot
, compact
, scry
, boot
, replay
, run
, swim
, sendSIGINT
, module Urbit.Vere.Serf.Types
)
where
import Urbit.Prelude hiding ((<|))
import Data.Bits
import Data.Conduit
import System.Process
import Urbit.Vere.Serf.Types
import Control.Monad.STM (retry)
import Control.Monad.Trans.Resource (MonadResource, allocate, runResourceT)
import Data.Sequence (Seq((:<|), (:|>)))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, poke)
import RIO.Prelude (decodeUtf8Lenient)
import System.Posix.Signals (sigINT, sigKILL, signalProcess)
import Urbit.Arvo (Ev, FX)
import Urbit.Noun.Time (Wen)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified System.IO.Error as IO
import qualified Urbit.Noun.Time as Time
-- Serf API --------------------------------------------------------------------
data Serf = Serf
{ serfSend :: Handle
, serfRecv :: Handle
, serfProc :: ProcessHandle
, serfSlog :: Slog -> IO ()
, serfLock :: MVar (Maybe SerfState)
}
-- Internal Protocol Types -----------------------------------------------------
data Live
= LExit Atom -- exit status code
| LSave EventId
| LPack EventId
deriving (Show)
data Play
= PDone Mug
| PBail PlayBail
deriving (Show)
data Work
= WDone EventId Mug FX
| WSwap EventId Mug (Wen, Noun) FX
| WBail [Goof]
deriving (Show)
data Writ
= WLive Live
| WPeek Wen Gang Path
| WPlay EventId [Noun]
| WWork Wen Ev
deriving (Show)
data Plea
= PLive ()
| PRipe SerfInfo
| PSlog Slog
| PPeek (Maybe (Term, Noun))
| PPlay Play
| PWork Work
deriving (Show)
deriveNoun ''Live
deriveNoun ''Play
deriveNoun ''Work
deriveNoun ''Writ
deriveNoun ''Plea
-- Access Current Serf State ---------------------------------------------------
serfLastEventBlocking :: Serf -> IO EventId
serfLastEventBlocking Serf{serfLock} = readMVar serfLock >>= \case
Nothing -> throwIO SerfNotRunning
Just ss -> pure (ssLast ss)
-- Low Level IPC Functions -----------------------------------------------------
fromRightExn :: (Exception e, MonadIO m) => Either a b -> (a -> e) -> m b
fromRightExn (Left m) exn = throwIO (exn m)
fromRightExn (Right x) _ = pure x
-- TODO Support Big Endian
sendLen :: Serf -> Int -> IO ()
sendLen s i = do
w <- evaluate (fromIntegral i :: Word64)
withWord64AsByteString w (hPut (serfSend s))
where
withWord64AsByteString :: Word64 -> (ByteString -> IO a) -> IO a
withWord64AsByteString w k = alloca $ \wp -> do
poke wp w
bs <- BS.unsafePackCStringLen (castPtr wp, 8)
k bs
sendBytes :: Serf -> ByteString -> IO ()
sendBytes s bs = handle onIOError $ do
sendLen s (length bs)
hPut (serfSend s) bs
hFlush (serfSend s)
where
onIOError :: IOError -> IO ()
onIOError = const (throwIO SerfConnectionClosed)
recvBytes :: Serf -> Word64 -> IO ByteString
recvBytes serf = BS.hGet (serfRecv serf) . fromIntegral
recvLen :: Serf -> IO Word64
recvLen w = do
bs <- BS.hGet (serfRecv w) 8
case length bs of
8 -> BS.unsafeUseAsCString bs (peek @Word64 . castPtr)
_ -> throwIO SerfConnectionClosed
recvResp :: Serf -> IO ByteString
recvResp serf = do
len <- recvLen serf
recvBytes serf len
-- Send Writ / Recv Plea -------------------------------------------------------
sendWrit :: Serf -> Writ -> IO ()
sendWrit s = sendBytes s . jamBS . toNoun
recvPlea :: Serf -> IO Plea
recvPlea w = do
b <- recvResp w
n <- fromRightExn (cueBS b) (const $ BadPleaAtom $ bytesAtom b)
p <- fromRightExn (fromNounErr @Plea n) (\(p, m) -> BadPleaNoun n p m)
pure p
recvPleaHandlingSlog :: Serf -> IO Plea
recvPleaHandlingSlog serf = loop
where
loop = recvPlea serf >>= \case
PSlog info -> serfSlog serf info >> loop
other -> pure other
-- Higher-Level IPC Functions --------------------------------------------------
recvRipe :: Serf -> IO SerfInfo
recvRipe serf = recvPleaHandlingSlog serf >>= \case
PRipe ripe -> pure ripe
plea -> throwIO (UnexpectedPlea (toNoun plea) "expecting %play")
recvPlay :: Serf -> IO Play
recvPlay serf = recvPleaHandlingSlog serf >>= \case
PPlay play -> pure play
plea -> throwIO (UnexpectedPlea (toNoun plea) "expecting %play")
recvLive :: Serf -> IO ()
recvLive serf = recvPleaHandlingSlog serf >>= \case
PLive () -> pure ()
plea -> throwIO (UnexpectedPlea (toNoun plea) "expecting %live")
recvWork :: Serf -> IO Work
recvWork serf = do
recvPleaHandlingSlog serf >>= \case
PWork work -> pure work
plea -> throwIO (UnexpectedPlea (toNoun plea) "expecting %work")
recvPeek :: Serf -> IO (Maybe (Term, Noun))
recvPeek serf = do
recvPleaHandlingSlog serf >>= \case
PPeek peek -> pure peek
plea -> throwIO (UnexpectedPlea (toNoun plea) "expecting %peek")
-- Request-Response Points -- These don't touch the lock -----------------------
sendSnapshotRequest :: Serf -> EventId -> IO ()
sendSnapshotRequest serf eve = do
sendWrit serf (WLive $ LSave eve)
recvLive serf
sendCompactionRequest :: Serf -> EventId -> IO ()
sendCompactionRequest serf eve = do
sendWrit serf (WLive $ LPack eve)
recvLive serf
sendScryRequest :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
sendScryRequest serf w g p = do
sendWrit serf (WPeek w g p)
recvPeek serf
sendShutdownRequest :: Serf -> Atom -> IO ()
sendShutdownRequest serf exitCode = do
sendWrit serf (WLive $ LExit exitCode)
pure ()
-- Starting the Serf -----------------------------------------------------------
compileFlags :: [Flag] -> Word
compileFlags = foldl' (\acc flag -> setBit acc (fromEnum flag)) 0
readStdErr :: Handle -> (Text -> IO ()) -> IO () -> IO ()
readStdErr h onLine onClose = loop
where
loop = do
IO.tryIOError (BS.hGetLine h >>= onLine . decodeUtf8Lenient) >>= \case
Left exn -> onClose
Right () -> loop
start :: Config -> IO (Serf, SerfInfo)
start (Config exePax pierPath flags onSlog onStdr onDead) = do
(Just i, Just o, Just e, p) <- createProcess pSpec
void $ async (readStdErr e onStdr onDead)
vLock <- newEmptyMVar
let serf = Serf i o p onSlog vLock
info <- recvRipe serf
putMVar vLock (Just $ siStat info)
pure (serf, info)
where
diskKey = ""
config = show (compileFlags flags)
args = [pierPath, diskKey, config]
pSpec = (proc exePax args) { std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
-- Taking the SerfState Lock ---------------------------------------------------
takeLock :: MonadIO m => Serf -> m SerfState
takeLock serf = io $ do
takeMVar (serfLock serf) >>= \case
Nothing -> putMVar (serfLock serf) Nothing >> throwIO SerfNotRunning
Just ss -> pure ss
serfLockTaken
:: MonadResource m => Serf -> m (IORef (Maybe SerfState), SerfState)
serfLockTaken serf = snd <$> allocate take release
where
take = (,) <$> newIORef Nothing <*> takeLock serf
release (rv, _) = do
mRes <- readIORef rv
when (mRes == Nothing) (forcefullyKillSerf serf)
putMVar (serfLock serf) mRes
withSerfLock
:: MonadResource m => Serf -> (SerfState -> m (SerfState, a)) -> m a
withSerfLock serf act = do
(vState , initialState) <- serfLockTaken serf
(newState, result ) <- act initialState
writeIORef vState (Just newState)
pure result
withSerfLockIO :: Serf -> (SerfState -> IO (SerfState, a)) -> IO a
withSerfLockIO s a = runResourceT (withSerfLock s (io . a))
-- SIGINT ----------------------------------------------------------------------
sendSIGINT :: Serf -> IO ()
sendSIGINT serf = do
getPid (serfProc serf) >>= \case
Nothing -> pure ()
Just pid -> do
io $ signalProcess sigINT pid
-- Killing the Serf ------------------------------------------------------------
{-|
Ask the serf to shutdown. If it takes more than 2s, kill it with
SIGKILL.
-}
stop :: HasLogFunc e => Serf -> RIO e ()
stop serf = do
race_ niceKill (wait2sec >> forceKill)
where
wait2sec = threadDelay 2_000_000
niceKill = do
logTrace "Asking serf to shut down"
io (gracefullyKillSerf serf)
logTrace "Serf went down when asked."
forceKill = do
logTrace "Serf taking too long to go down, kill with fire (SIGTERM)."
io (forcefullyKillSerf serf)
logTrace "Serf process killed with SIGTERM."
{-|
Kill the serf by taking the lock, then asking for it to exit.
-}
gracefullyKillSerf :: Serf -> IO ()
gracefullyKillSerf serf@Serf{..} = do
finalState <- takeMVar serfLock
sendShutdownRequest serf 0
waitForProcess serfProc
pure ()
{-|
Kill the serf by sending it a SIGKILL.
-}
forcefullyKillSerf :: Serf -> IO ()
forcefullyKillSerf serf = do
getPid (serfProc serf) >>= \case
Nothing -> pure ()
Just pid -> do
io $ signalProcess sigKILL pid
io $ void $ waitForProcess (serfProc serf)
-- Flows for Interacting with the Serf -----------------------------------------
{-|
Ask the serf to write a snapshot to disk.
-}
snapshot :: Serf -> IO ()
snapshot serf = withSerfLockIO serf $ \ss -> do
sendSnapshotRequest serf (ssLast ss)
pure (ss, ())
{-|
Ask the serf to de-duplicate and de-fragment it's heap.
-}
compact :: Serf -> IO ()
compact serf = withSerfLockIO serf $ \ss -> do
sendCompactionRequest serf (ssLast ss)
pure (ss, ())
{-|
Peek into the serf state.
-}
scry :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
scry serf w g p = withSerfLockIO serf $ \ss -> do
(ss,) <$> sendScryRequest serf w g p
{-|
Given a list of boot events, send them to to the serf in a single
%play message. They must all be sent in a single %play event so that
the serf can determine the length of the boot sequence.
-}
boot :: Serf -> [Noun] -> IO (Maybe PlayBail)
boot serf@Serf {..} seq = do
withSerfLockIO serf $ \ss -> do
sendWrit serf (WPlay 1 seq)
recvPlay serf >>= \case
PBail bail -> pure (ss, Just bail)
PDone mug -> pure (SerfState (fromIntegral $ length seq) mug, Nothing)
{-|
Given a stream of nouns (from the event log), feed them into the serf
in batches of size `batchSize`.
- On `%bail` response, return early.
- On IPC errors, kill the serf and rethrow.
- On success, return `Nothing`.
-}
replay
:: forall m
. (MonadResource m, MonadUnliftIO m, MonadIO m)
=> Int
-> (Int -> IO ())
-> Serf
-> ConduitT Noun Void m (Maybe PlayBail)
replay batchSize cb serf = do
withSerfLock serf $ \ss -> do
(r, ss') <- loop ss
pure (ss', r)
where
loop :: SerfState -> ConduitT Noun Void m (Maybe PlayBail, SerfState)
loop ss@(SerfState lastEve lastMug) = do
awaitBatch batchSize >>= \case
[] -> pure (Nothing, SerfState lastEve lastMug)
evs -> do
let nexEve = lastEve + 1
let newEve = lastEve + fromIntegral (length evs)
io $ sendWrit serf (WPlay nexEve evs)
io (recvPlay serf) >>= \case
PBail bail -> pure (Just bail, SerfState lastEve lastMug)
PDone newMug -> do
io (cb $ length evs)
loop (SerfState newEve newMug)
{-|
TODO If this is slow, use a mutable vector instead of reversing a list.
-}
awaitBatch :: Monad m => Int -> ConduitT i o m [i]
awaitBatch = go []
where
go acc 0 = pure (reverse acc)
go acc n = await >>= \case
Nothing -> pure (reverse acc)
Just x -> go (x:acc) (n-1)
-- Special Replay for Collecting FX --------------------------------------------
{-|
This does event-log replay using the running IPC flow so that we
can collect effects.
We don't tolerate replacement events or bails since we are actually
replaying the log, so we just throw exceptions in those cases.
-}
swim
:: forall m
. (MonadIO m, MonadUnliftIO m, MonadResource m)
=> Serf
-> ConduitT (Wen, Ev) (EventId, FX) m ()
swim serf = do
withSerfLock serf $ \SerfState {..} -> do
(, ()) <$> loop ssHash ssLast
where
loop
:: Mug
-> EventId
-> ConduitT (Wen, Ev) (EventId, FX) m SerfState
loop mug eve = await >>= \case
Nothing -> do
pure (SerfState eve mug)
Just (wen, evn) -> do
io (sendWrit serf (WWork wen evn))
io (recvWork serf) >>= \case
WBail goofs -> do
throwIO (BailDuringReplay eve goofs)
WSwap eid hash (wen, noun) fx -> do
throwIO (SwapDuringReplay eid hash (wen, noun) fx)
WDone eid hash fx -> do
yield (eid, fx)
loop hash eid
-- Running Ship Flow -----------------------------------------------------------
{-|
TODO Don't take snapshot until event log has processed current event.
-}
run
:: Serf
-> Int
-> STM EventId
-> STM RunReq
-> ((Fact, FX) -> STM ())
-> (Maybe Ev -> STM ())
-> IO ()
run serf maxBatchSize getLastEvInLog onInput sendOn spin = topLoop
where
topLoop :: IO ()
topLoop = atomically onInput >>= \case
RRWork workErr -> doWork workErr
RRSave () -> doSave
RRKill () -> doKill
RRPack () -> doPack
RRScry w g p k -> doScry w g p k
doPack :: IO ()
doPack = compact serf >> topLoop
waitForLog :: IO ()
waitForLog = do
serfLast <- serfLastEventBlocking serf
atomically $ do
logLast <- getLastEvInLog
when (logLast < serfLast) retry
doSave :: IO ()
doSave = waitForLog >> snapshot serf >> topLoop
doKill :: IO ()
doKill = waitForLog >> snapshot serf >> pure ()
doScry :: Wen -> Gang -> Path -> (Maybe (Term, Noun) -> IO ()) -> IO ()
doScry w g p k = (scry serf w g p >>= k) >> topLoop
doWork :: EvErr -> IO ()
doWork firstWorkErr = do
que <- newTBMQueueIO 1
() <- atomically (writeTBMQueue que firstWorkErr)
tWork <- async (processWork serf maxBatchSize que onWorkResp spin)
flip onException (cancel tWork) $ do
nexSt <- workLoop que
wait tWork
nexSt
workLoop :: TBMQueue EvErr -> IO (IO ())
workLoop que = atomically onInput >>= \case
RRKill () -> atomically (closeTBMQueue que) >> pure doKill
RRSave () -> atomically (closeTBMQueue que) >> pure doSave
RRPack () -> atomically (closeTBMQueue que) >> pure doPack
RRScry w g p k -> atomically (closeTBMQueue que) >> pure (doScry w g p k)
RRWork workErr -> atomically (writeTBMQueue que workErr) >> workLoop que
onWorkResp :: Wen -> EvErr -> Work -> IO ()
onWorkResp wen (EvErr evn err) = \case
WDone eid hash fx -> do
io $ err (RunOkay eid)
atomically $ sendOn ((Fact eid hash wen (toNoun evn)), fx)
WSwap eid hash (wen, noun) fx -> do
io $ err (RunSwap eid hash wen noun fx)
atomically $ sendOn (Fact eid hash wen noun, fx)
WBail goofs -> do
io $ err (RunBail goofs)
{-|
Given:
- A stream of incoming requests
- A sequence of in-flight requests that haven't been responded to
- A maximum number of in-flight requests.
Wait until the number of in-fligh requests is smaller than the maximum,
and then take the next item from the stream of requests.
-}
pullFromQueueBounded :: Int -> TVar (Seq a) -> TBMQueue b -> STM (Maybe b)
pullFromQueueBounded maxSize vInFlight queue = do
inFlight <- length <$> readTVar vInFlight
if inFlight >= maxSize
then retry
else readTBMQueue queue
{-|
Given
- `maxSize`: The maximum number of jobs to send to the serf before
getting a response.
- `q`: A bounded queue (which can be closed)
- `onResp`: a callback to call for each response from the serf.
- `spin`: a callback to tell the terminal driver which event is
currently being processed.
Pull jobs from the queue and send them to the serf (eagerly, up to
`maxSize`) and call the callback with each response from the serf.
When the queue is closed, wait for the serf to respond to all pending
work, and then return.
Whenever the serf is idle, call `spin Nothing` and whenever the serf
is working on an event, call `spin (Just ev)`.
-}
processWork
:: Serf
-> Int
-> TBMQueue EvErr
-> (Wen -> EvErr -> Work -> IO ())
-> (Maybe Ev -> STM ())
-> IO ()
processWork serf maxSize q onResp spin = do
vDoneFlag <- newTVarIO False
vInFlightQueue <- newTVarIO empty
recvThread <- async (recvLoop serf vDoneFlag vInFlightQueue spin)
flip onException (print "KILLING: processWork" >> cancel recvThread) $ do
loop vInFlightQueue vDoneFlag
wait recvThread
where
loop :: TVar (Seq (Ev, Work -> IO ())) -> TVar Bool -> IO ()
loop vInFlight vDone = do
atomically (pullFromQueueBounded maxSize vInFlight q) >>= \case
Nothing -> do
atomically (writeTVar vDone True)
Just evErr@(EvErr ev _) -> do
now <- Time.now
let cb = onResp now evErr
atomically $ modifyTVar' vInFlight (:|> (ev, cb))
sendWrit serf (WWork now ev)
loop vInFlight vDone
{-|
Given:
- `vDone`: A flag that no more work will be sent to the serf.
- `vWork`: A list of work requests that have been sent to the serf,
haven't been responded to yet.
If the serf has responded to all work requests, and no more work is
going to be sent to the serf, then return.
If we are going to send more work to the serf, but the queue is empty,
then wait.
If work requests have been sent to the serf, take the first one,
wait for a response from the serf, call the associated callback,
and repeat the whole process.
-}
recvLoop
:: Serf
-> TVar Bool
-> TVar (Seq (Ev, Work -> IO ()))
-> (Maybe Ev -> STM ())
-> IO ()
recvLoop serf vDone vWork spin = do
withSerfLockIO serf \SerfState {..} -> do
loop ssLast ssHash
where
loop eve mug = do
atomically $ do
whenM (null <$> readTVar vWork) $ do
spin Nothing
atomically takeCallback >>= \case
Nothing -> pure (SerfState eve mug, ())
Just (curEve, cb) -> do
atomically (spin (Just curEve))
recvWork serf >>= \case
work@(WDone eid hash _) -> cb work >> loop eid hash
work@(WSwap eid hash _ _) -> cb work >> loop eid hash
work@(WBail _) -> cb work >> loop eve mug
takeCallback :: STM (Maybe (Ev, Work -> IO ()))
takeCallback = do
((,) <$> readTVar vDone <*> readTVar vWork) >>= \case
(False, Empty ) -> retry
(True , Empty ) -> pure Nothing
(_ , (e, x) :<| xs) -> writeTVar vWork xs $> Just (e, x)
(_ , _ ) -> error "impossible"

120
pkg/hs/urbit-king/lib/Urbit/Vere/Serf/Types.hs Normal file
View File

@ -0,0 +1,120 @@
module Urbit.Vere.Serf.Types where
import Urbit.Prelude
import Urbit.Arvo (Ev, FX)
import Urbit.Noun.Time (Wen)
-- Types -----------------------------------------------------------------------
type EventId = Word64
type PlayBail = (EventId, Mug, Goof)
type Slog = (Atom, Tank)
data SerfState = SerfState
{ ssLast :: EventId
, ssHash :: Mug
}
deriving (Show, Eq)
data RipeInfo = RipeInfo
{ riProt :: Atom
, riHoon :: Atom
, riNock :: Atom
}
deriving (Show)
data SerfInfo = SerfInfo
{ siRipe :: RipeInfo
, siStat :: SerfState
}
deriving (Show)
data Fact = Fact
{ factEve :: EventId
, factMug :: Mug
, factWen :: Wen
, factNon :: Noun
}
data Flag
= DebugRam
| DebugCpu
| CheckCorrupt
| CheckFatal
| Verbose
| DryRun
| Quiet
| Hashless
| Trace
deriving (Eq, Ord, Show, Enum, Bounded)
data Config = Config
{ scSerf :: FilePath -- Where is the urbit-worker executable?
, scPier :: FilePath -- Where is the pier directory?
, scFlag :: [Flag] -- Serf execution flags.
, scSlog :: Slog -> IO () -- What to do with slogs?
, scStdr :: Text -> IO () -- What to do with lines from stderr?
, scDead :: IO () -- What to do when the serf process goes down?
}
-- Serf Commands ---------------------------------------------------------------
type Gang = Maybe (HoonSet Ship)
type Goof = (Term, [Tank])
data EvErr = EvErr Ev (WorkError -> IO ())
{-|
Two types of serf failures.
- `RunSwap`: Event processing failed, but the serf replaced it with
another event which succeeded.
- `RunBail`: Event processing failed and all attempt to replace it
with a failure-notice event also caused crashes. We are really fucked.
-}
data WorkError -- TODO Rename type and constructors
= RunSwap EventId Mug Wen Noun FX -- TODO Maybe provide less info here?
| RunBail [Goof]
| RunOkay EventId
{-
- RRWork: Ask the serf to do work, will output (Fact, FX) if work
succeeded and call callback on failure.
- RRSave: Wait for the serf to finish all pending work
-}
data RunReq
= RRWork EvErr
| RRSave ()
| RRKill ()
| RRPack ()
| RRScry Wen Gang Path (Maybe (Term, Noun) -> IO ())
-- Exceptions ------------------------------------------------------------------
data SerfExn
= UnexpectedPlea Noun Text
| BadPleaAtom Atom
| BadPleaNoun Noun [Text] Text
| SerfConnectionClosed
| SerfHasShutdown
| BailDuringReplay EventId [Goof]
| SwapDuringReplay EventId Mug (Wen, Noun) FX
| SerfNotRunning
| MissingBootEventsInEventLog Word Word
| SnapshotAheadOfLog EventId EventId
deriving (Show, Exception)
-- Instances -------------------------------------------------------------------
deriveNoun ''RipeInfo
deriveNoun ''SerfInfo
deriveNoun ''SerfState

155
pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
View File

@ -8,6 +8,7 @@ module Urbit.Vere.Term
, runTerminalClient
, connClient
, term
, term'
) where
import Data.Char
@ -18,20 +19,20 @@ import RIO.FilePath
import System.Posix.IO
import System.Posix.Terminal
import Urbit.Arvo hiding (Term)
import Urbit.King.Config
import Urbit.King.App
import Urbit.Noun.Time
import Urbit.Prelude hiding (getCurrentTime)
import Urbit.Time
import Urbit.Vere.Pier.Types
import Data.List ((!!))
import RIO.Directory (createDirectoryIfMissing)
import Urbit.King.API (readPortsFile)
import Urbit.King.App (HasConfigDir(..))
import Urbit.TermSize (TermSize(TermSize))
import Urbit.Vere.Term.API (Client(Client))
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.UTF8 as BS
import qualified System.Console.ANSI as ANSI
import qualified Urbit.TermSize as T
import qualified Urbit.Vere.NounServ as Serv
import qualified Urbit.Vere.Term.API as Term
@ -76,20 +77,6 @@ initialHail = EvBlip $ BlipEvTerm $ TermEvHail (UD 1, ()) ()
-- Version one of this is punting on the ops_u.dem flag: whether we're running
-- in daemon mode.
spinners :: [Text]
spinners = ["|", "/", "-", "\\"]
leftBracket :: Text
leftBracket = "«"
rightBracket :: Text
rightBracket = "»"
_spin_cool_us = 500000
_spin_warm_us = 50000
_spin_rate_us = 250000
_spin_idle_us = 500000
--------------------------------------------------------------------------------
rioAllocaBytes :: (MonadIO m, MonadUnliftIO m)
@ -140,7 +127,7 @@ connectToRemote port local = mkRAcquire start stop
data HackConfigDir = HCD { _hcdPax :: FilePath }
makeLenses ''HackConfigDir
instance HasConfigDir HackConfigDir where configDirL = hcdPax
instance HasPierPath HackConfigDir where pierPathL = hcdPax
runTerminalClient :: ∀e. HasLogFunc e => FilePath -> RIO e ()
runTerminalClient pier = runRAcquire $ do
@ -155,6 +142,33 @@ runTerminalClient pier = runRAcquire $ do
runRAcquire :: RAcquire e () -> RIO e ()
runRAcquire act = rwith act $ const $ pure ()
-- Spinner ---------------------------------------------------------------------
-- Call an STM action after delay of `first` microseconds and then every
-- `rest` microseconds after that.
repeatedly :: Int -> Int -> STM () -> IO ()
repeatedly first rest action = do
threadDelay first
forever $ do
atomically action
threadDelay rest
spinners :: [Text]
spinners = ["|", "/", "-", "\\"]
leftBracket, rightBracket :: Text
leftBracket = "«"
rightBracket = "»"
_spin_cool_us = 500000
_spin_warm_us = 50000
_spin_rate_us = 250000
_spin_idle_us = 500000
-- Client ----------------------------------------------------------------------
{-|
Initializes the generalized input/output parts of the terminal.
-}
@ -165,10 +179,9 @@ localClient doneSignal = fst <$> mkRAcquire start stop
where
start :: HasLogFunc e => RIO e ((TermSize, Client), Private)
start = do
tsWriteQueue <- newTQueueIO
spinnerMVar <- newEmptyTMVarIO
pWriterThread <-
asyncBound (writeTerminal tsWriteQueue spinnerMVar)
tsWriteQueue <- newTQueueIO :: RIO e (TQueue [Term.Ev])
spinnerMVar <- newEmptyTMVarIO :: RIO e (TMVar ())
pWriterThread <- asyncBound (writeTerminal tsWriteQueue spinnerMVar)
pPreviousConfiguration <- io $ getTerminalAttributes stdInput
@ -228,17 +241,6 @@ localClient doneSignal = fst <$> mkRAcquire start stop
, ProcessOutput
]
-- An async which will put into an mvar after a delay. Used to spin the
-- spinner in writeTerminal.
spinnerHeartBeat :: Int -> Int -> TMVar () -> RIO e ()
spinnerHeartBeat first rest mvar = do
threadDelay first
loop
where
loop = do
atomically $ putTMVar mvar ()
threadDelay rest
loop
-- Writes data to the terminal. Both the terminal reading, normal logging,
-- and effect handling can all emit bytes which go to the terminal.
@ -248,9 +250,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
loop (LineState "" 0 Nothing Nothing True 0 currentTime)
where
writeBlank :: LineState -> RIO e LineState
writeBlank ls = do
putStr "\r\n"
pure ls
writeBlank ls = putStr "\r\n" $> ls
writeTrace :: LineState -> Text -> RIO e LineState
writeTrace ls p = do
@ -268,6 +268,8 @@ localClient doneSignal = fst <$> mkRAcquire start stop
-}
doSpin :: LineState -> Maybe Text -> RIO e LineState
doSpin ls@LineState{..} mTxt = do
maybe (pure ()) cancel lsSpinTimer
current <- io $ now
delay <- pure $ case mTxt of
Nothing -> 0
@ -276,7 +278,10 @@ localClient doneSignal = fst <$> mkRAcquire start stop
then _spin_warm_us
else _spin_cool_us
spinTimer <- async $ spinnerHeartBeat delay _spin_rate_us spinner
spinTimer <- io $ async
$ repeatedly delay _spin_rate_us
$ void
$ tryPutTMVar spinner ()
pure $ ls { lsSpinTimer = Just spinTimer
, lsSpinCause = mTxt
@ -293,7 +298,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
-- If we ever actually ran the spinner display callback, we need
-- to force a redisplay of the command prompt.
ls <- if not lsSpinFirstRender
ls <- if not lsSpinFirstRender || True
then termRefreshLine ls
else pure ls
@ -308,16 +313,16 @@ localClient doneSignal = fst <$> mkRAcquire start stop
Term.Spinr (Just txt) -> doSpin ls (unCord <$> txt)
Term.Spinr Nothing -> unspin ls
-- TODO What does this do?
spin :: LineState -> RIO e LineState
spin ls@LineState{..} = do
let spinner = (spinners !! lsSpinFrame) ++ case lsSpinCause of
Nothing -> ""
Just str -> leftBracket ++ str ++ rightBracket
putStr spinner
termSpinnerMoveLeft (length spinner)
putStr (spinner <> pack (ANSI.cursorBackwardCode (length spinner)))
let newFrame = (lsSpinFrame + 1) `mod` (length spinners)
let newFrame = (lsSpinFrame + 1) `mod` length spinners
pure $ ls { lsSpinFirstRender = False
, lsSpinFrame = newFrame
@ -358,8 +363,8 @@ localClient doneSignal = fst <$> mkRAcquire start stop
-- Moves the cursor left without any mutation of the LineState. Used only
-- in cursor spinning.
termSpinnerMoveLeft :: Int → RIO e ()
termSpinnerMoveLeft = T.cursorLeft
_termSpinnerMoveLeft :: Int → RIO e ()
_termSpinnerMoveLeft = T.cursorLeft
-- Displays and sets the current line
termShowLine :: LineState -> Text -> RIO e LineState
@ -491,28 +496,55 @@ localClient doneSignal = fst <$> mkRAcquire start stop
-- logDebug $ displayShow ("terminalBelt", b)
atomically $ writeTQueue rq b
--------------------------------------------------------------------------------
{-|
Terminal Driver
Until blew/hail events succeeds, ignore effects.
Wait until blew/hail event callbacks invoked.
If success, signal success.
If failure, try again several times.
If still failure, bring down ship.
Don't wait for other drivers to boot
Begin normal operation (start accepting requests)
-}
term'
:: HasPierEnv e
=> (TermSize, Client)
-> IO ()
-> RIO e ([Ev], RAcquire e (DriverApi TermEf))
term' (tsize, client) serfSIGINT = do
let TermSize wi hi = tsize
initEv = [initialBlew wi hi, initialHail]
pure (initEv, runDriver)
where
runDriver = do
env <- ask
ventQ :: TQueue EvErr <- newTQueueIO
diOnEffect <- term env (tsize, client) (writeTQueue ventQ) serfSIGINT
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
pure (DriverApi {..})
{-|
Terminal Driver
-}
term :: forall e. (HasPierConfig e, HasLogFunc e)
=> (TermSize, Client)
-> (STM ())
-> KingId
-> QueueEv
-> ([Ev], RAcquire e (EffCb e TermEf))
term (tsize, Client{..}) shutdownSTM king enqueueEv =
(initialEvents, runTerm)
term :: forall e. (HasPierEnv e)
=> e
-> (TermSize, Client)
-> (EvErr -> STM ())
-> IO ()
-> RAcquire e (TermEf -> IO ())
term env (tsize, Client{..}) plan serfSIGINT = runTerm
where
TermSize wi hi = tsize
initialEvents = [initialBlew wi hi, initialHail]
runTerm :: RAcquire e (EffCb e TermEf)
runTerm :: RAcquire e (TermEf -> IO ())
runTerm = do
tim <- mkRAcquire (async readLoop) cancel
pure handleEffect
pure (runRIO env . handleEffect)
{-
Because our terminals are always `Demux`ed, we don't have to
@ -523,14 +555,17 @@ term (tsize, Client{..}) shutdownSTM king enqueueEv =
atomically take >>= \case
Nothing -> pure ()
Just b -> do
let blip = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
atomically $ enqueueEv $ blip
when (b == Ctl (Cord "c")) $ do
io serfSIGINT
let beltEv = EvBlip $ BlipEvTerm $ TermEvBelt (UD 1, ()) $ b
let beltFailed _ = pure ()
atomically $ plan (EvErr beltEv beltFailed)
handleEffect :: TermEf -> RIO e ()
handleEffect = \case
TermEfInit _ _ -> pure ()
TermEfMass _ _ -> pure ()
TermEfLogo _ _ -> atomically shutdownSTM
TermEfLogo _ _ -> atomically =<< view killPierActionL
TermEfBlit _ blits -> do
let (termBlits, fsWrites) = partition isTerminalBlit blits
atomically $ give [Term.Blits termBlits]

5
pkg/hs/urbit-king/package.yaml
View File

@ -72,6 +72,7 @@ dependencies:
- primitive
- process
- QuickCheck
- racquire
- random
- regex-tdfa
- regex-tdfa-text
@ -91,6 +92,7 @@ dependencies:
- text
- these
- time
- tls
- transformers
- unix
- unliftio
@ -98,7 +100,10 @@ dependencies:
- unordered-containers
- urbit-atom
- urbit-azimuth
- urbit-eventlog-lmdb
- urbit-hob
- urbit-noun
- urbit-noun-core
- urbit-termsize
- utf8-string
- vector

86
pkg/hs/urbit-king/test/AmesTests.hs
View File

@ -8,22 +8,27 @@ import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.Arvo
import Urbit.EventLog.LMDB
import Urbit.King.Config
import Urbit.Noun
import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Time
import Urbit.Vere.Ames
import Urbit.Vere.Log
import Urbit.Vere.Pier.Types
import Control.Concurrent (runInBoundThread)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import Network.Socket (tupleToHostAddress)
import Urbit.King.App (HasKingId(..))
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
--------------------------------------------------------------------------------
type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e)
-- Utils -----------------------------------------------------------------------
pid :: KingId
@ -38,6 +43,7 @@ sendEf g w bs = NewtEfSend (0, ()) (EachYes g) bs
data NetworkTestApp = NetworkTestApp
{ _ntaLogFunc :: !LogFunc
, _ntaNetworkConfig :: !NetworkConfig
, _ntaKingId :: !Word16
}
makeLenses ''NetworkTestApp
@ -48,67 +54,81 @@ instance HasLogFunc NetworkTestApp where
instance HasNetworkConfig NetworkTestApp where
networkConfigL = ntaNetworkConfig
instance HasKingId NetworkTestApp where
kingIdL = ntaKingId
runNetworkApp :: RIO NetworkTestApp a -> IO a
runNetworkApp = runRIO NetworkTestApp
{ _ntaLogFunc = mkLogFunc l
, _ntaNetworkConfig = NetworkConfig NMNormal Nothing Nothing Nothing Nothing
{ _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ())
, _ntaKingId = 34
, _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal
, _ncAmesPort = Nothing
, _ncNoAmes = False
, _ncNoHttp = False
, _ncNoHttps = False
, _ncHttpPort = Nothing
, _ncHttpsPort = Nothing
, _ncLocalPort = Nothing
}
}
where
l _ _ _ _ = pure ()
runGala :: forall e. (HasLogFunc e, HasNetworkConfig e)
=> Word8 -> RAcquire e (TQueue Ev, EffCb e NewtEf)
runGala point =
do
q <- newTQueueIO
runGala
:: forall e
. HasAmes e
=> Word8
-> RAcquire e (TQueue EvErr, NewtEf -> IO ())
runGala point = do
env <- ask
que <- newTQueueIO
let (_, runAmes) =
ames pid (fromIntegral point) True (writeTQueue q) noStderr
cb ← runAmes
rio $ cb turfEf
pure (q, cb)
ames env (fromIntegral point) True (writeTQueue que) noStderr
cb <- runAmes
io (cb turfEf)
pure (que, cb)
where
noStderr _ = pure ()
waitForPacket :: TQueue Ev -> Bytes -> IO Bool
waitForPacket :: TQueue EvErr -> Bytes -> IO Bool
waitForPacket q val = go
where
go =
atomically (readTQueue q) >>= \case
EvBlip (BlipEvNewt (NewtEvBorn (_, ()) ())) -> go
EvBlip (BlipEvAmes (AmesEvHear () _ bs)) -> pure (bs == val)
_ -> pure False
where
go = atomically (readTQueue q) >>= \case
EvErr (EvBlip (BlipEvNewt (NewtEvBorn (_, ()) ()))) _ -> go
EvErr (EvBlip (BlipEvAmes (AmesEvHear () _ bs))) _ -> pure (bs == val)
_ -> pure False
runRAcquire :: RAcquire e a -> RIO e a
runRAcquire acq = rwith acq pure
sendThread :: EffCb e NewtEf -> (Galaxy, Bytes) -> RAcquire e ()
sendThread :: (NewtEf -> IO ()) -> (Galaxy, Bytes) -> RAcquire e ()
sendThread cb (to, val) = void $ mkRAcquire start cancel
where
start = async $ forever $ do threadDelay 1_000
wen <- io $ now
cb (sendEf to wen val)
io $ cb (sendEf to wen val)
threadDelay 10_000
zodSelfMsg :: Property
zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where
runTest :: (HasLogFunc e, HasNetworkConfig e) => Bytes -> RIO e Bool
runTest val = runRAcquire $ do
(zodQ, zod) <- runGala 0
() <- sendThread zod (0, val)
liftIO (waitForPacket zodQ val)
where
runTest
:: (HasLogFunc e, HasNetworkConfig e, HasKingId e) => Bytes -> RIO e Bool
runTest val = runRAcquire $ do
env <- ask
(zodQ, zod) <- runGala 0
() <- sendThread zod (0, val)
liftIO (waitForPacket zodQ val)
twoTalk :: Property
twoTalk = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where
runTest :: (HasLogFunc e, HasNetworkConfig e)
runTest :: (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> (Word8, Word8, Bytes) -> RIO e Bool
runTest (aliceShip, bobShip, val) =
if aliceShip == bobShip
then pure True
else go aliceShip bobShip val
go :: (HasLogFunc e, HasNetworkConfig e)
go :: (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> Word8 -> Word8 -> Bytes -> RIO e Bool
go aliceShip bobShip val = runRAcquire $ do
(aliceQ, alice) <- runGala aliceShip

6
pkg/hs/urbit-king/test/ArvoTests.hs
View File

@ -10,9 +10,9 @@ import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.Arvo
import Urbit.EventLog.LMDB
import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Time
import Urbit.Vere.Log
import Urbit.Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
@ -20,7 +20,7 @@ import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import Network.Socket (tupleToHostAddress)
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
-- Utils -----------------------------------------------------------------------

23
pkg/hs/urbit-king/test/BehnTests.hs
View File

@ -9,37 +9,36 @@ import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.Arvo
import Urbit.EventLog.LMDB
import Urbit.Noun
import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Time
import Urbit.Vere.Behn
import Urbit.Vere.Log
import Urbit.Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import Network.Socket (tupleToHostAddress)
import Urbit.King.App (runApp)
import Urbit.King.App (runKingEnvNoLog, HasKingId(..))
import qualified Urbit.Time as Time
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
import qualified Urbit.Noun.Time as Time
--------------------------------------------------------------------------------
king :: KingId
king = KingId 0
-- TODO Timers always fire immediatly. Something is wrong!
timerFires :: Property
timerFires = forAll arbitrary (ioProperty . runApp . runTest)
timerFires = forAll arbitrary (ioProperty . runKingEnvNoLog . runTest)
where
runTest :: () -> RIO e Bool
runTest :: HasKingId e => () -> RIO e Bool
runTest () = do
envr <- ask
king <- fromIntegral <$> view kingIdL
q <- newTQueueIO
rwith (liftAcquire $ snd $ behn king (writeTQueue q)) $ \cb -> do
cb (BehnEfDoze (king, ()) (Just (2^20)))
rwith (liftAcquire $ behn envr (writeTQueue q)) $ \cb -> do
io $ cb (BehnEfDoze (king, ()) (Just (2^20)))
t <- atomically $ readTQueue q
pure True

4
pkg/hs/urbit-king/test/DeriveNounTests.hs
View File

@ -7,15 +7,15 @@ import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.EventLog.LMDB
import Urbit.Prelude
import Urbit.Vere.Log
import Urbit.Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
-- Sum Types -------------------------------------------------------------------

23
pkg/hs/urbit-king/test/LogTests.hs
View File

@ -7,16 +7,16 @@ import Test.QuickCheck hiding ((.&.))
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Tasty.TH
import Urbit.EventLog.LMDB
import Urbit.Prelude
import Urbit.Vere.Log
import Urbit.Vere.Pier.Types
import Control.Concurrent (runInBoundThread, threadDelay)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
import Urbit.King.App (App, runApp)
import Urbit.King.App (KingEnv, runKingEnvNoLog)
import qualified Urbit.Vere.Log as Log
import qualified Urbit.EventLog.LMDB as Log
-- Utils -----------------------------------------------------------------------
@ -42,13 +42,13 @@ data Db = Db LogIdentity [ByteString] (Map Word64 ByteString)
addEvents :: Db -> [ByteString] -> Db
addEvents (Db id evs efs) new = Db id (evs <> new) efs
readDb :: EventLog -> RIO App Db
readDb :: EventLog -> RIO KingEnv Db
readDb log = do
events <- runConduit (streamEvents log 1 .| consume)
effects <- runConduit (streamEffectsRows log 0 .| consume)
pure $ Db (Log.identity log) events (mapFromList effects)
withDb :: FilePath -> Db -> (EventLog -> RIO App a) -> RIO App a
withDb :: FilePath -> Db -> (EventLog -> RIO KingEnv a) -> RIO KingEnv a
withDb dir (Db dId dEvs dFx) act = do
rwith (Log.new dir dId) $ \log -> do
Log.appendEvents log (fromList dEvs)
@ -58,10 +58,13 @@ withDb dir (Db dId dEvs dFx) act = do
--------------------------------------------------------------------------------
runApp :: RIO KingEnv a -> IO a
runApp = runKingEnvNoLog
tryReadIdentity :: Property
tryReadIdentity = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: LogIdentity -> RIO App Bool
runTest :: LogIdentity -> RIO KingEnv Bool
runTest ident = do
env <- ask
io $ runInBoundThread $ runRIO env $
@ -77,7 +80,7 @@ tryReadIdentity = forAll arbitrary (ioProperty . runApp . runTest)
tryReadDatabase :: Property
tryReadDatabase = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: Db -> RIO App Bool
runTest :: Db -> RIO KingEnv Bool
runTest db = do
env <- ask
io $ runInBoundThread $ runRIO env $
@ -89,7 +92,7 @@ tryReadDatabase = forAll arbitrary (ioProperty . runApp . runTest)
tryReadDatabaseFuzz :: Property
tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: Db -> RIO App Bool
runTest :: Db -> RIO KingEnv Bool
runTest db = do
env <- ask
io $ runInBoundThread $ runRIO env $
@ -106,7 +109,7 @@ tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runApp . runTest)
tryAppend :: Property
tryAppend = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: ([ByteString], Db) -> RIO App Bool
runTest :: ([ByteString], Db) -> RIO KingEnv Bool
runTest (extra, db) = do
env <- ask
io $ runInBoundThread $ runRIO env $
@ -123,7 +126,7 @@ tryAppend = forAll arbitrary (ioProperty . runApp . runTest)
tryAppendHuge :: Property
tryAppendHuge = forAll arbitrary (ioProperty . runApp . runTest)
where
runTest :: ([ByteString], Db) -> RIO App Bool
runTest :: ([ByteString], Db) -> RIO KingEnv Bool
runTest (extra, db) = do
env <- ask
io $ runInBoundThread $ runRIO env $ do

3
pkg/hs/urbit-noun-core/.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work
*.cabal
test/gold/*.writ

21
pkg/hs/urbit-noun-core/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

0
pkg/hs/urbit-king/lib/Urbit/Noun/Convert.hs → pkg/hs/urbit-noun-core/lib/Urbit/Noun/Convert.hs
View File

0
pkg/hs/urbit-king/lib/Urbit/Noun/Core.hs → pkg/hs/urbit-noun-core/lib/Urbit/Noun/Core.hs
View File

0
pkg/hs/urbit-king/lib/Urbit/Noun/Cue.hs → pkg/hs/urbit-noun-core/lib/Urbit/Noun/Cue.hs
View File

0
pkg/hs/urbit-king/lib/Urbit/Noun/Jam.hs → pkg/hs/urbit-noun-core/lib/Urbit/Noun/Jam.hs
View File

0
pkg/hs/urbit-king/lib/Urbit/Noun/TH.hs → pkg/hs/urbit-noun-core/lib/Urbit/Noun/TH.hs
View File

71
pkg/hs/urbit-noun-core/package.yaml Normal file
View File

@ -0,0 +1,71 @@
name: urbit-noun-core
version: 0.10.4
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- QuickCheck
- ghc-prim
- hashable
- urbit-atom
- classy-prelude
- bytestring
- hashtables
- vector
- integer-gmp
- template-haskell
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

3
pkg/hs/urbit-noun/.gitignore vendored Normal file
View File

@ -0,0 +1,3 @@
.stack-work
*.cabal
test/gold/*.writ

21
pkg/hs/urbit-noun/LICENSE Normal file
View File

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2016 urbit
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

0
pkg/hs/urbit-king/lib/Urbit/Noun.hs → pkg/hs/urbit-noun/lib/Urbit/Noun.hs
View File

1
pkg/hs/urbit-king/lib/Urbit/Noun/Conversions.hs → pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs
View File

@ -713,6 +713,7 @@ instance (FromNoun a, FromNoun b) => FromNoun (Each a b) where
1 -> named "|" (EachNo <$> parseNoun v)
n -> fail ("Each has invalid head-atom: " <> show n)
-- Tuple Conversions -----------------------------------------------------------
instance ToNoun () where

26
pkg/hs/urbit-king/lib/Urbit/Noun/Tank.hs → pkg/hs/urbit-noun/lib/Urbit/Noun/Tank.hs
View File

@ -7,18 +7,32 @@ module Urbit.Noun.Tank where
import ClassyPrelude
import Urbit.Noun.Conversions
import Urbit.Noun.TH
import Urbit.Noun.Convert
import Urbit.Noun.Core
--------------------------------------------------------------------------------
type Tang = [Tank]
data Tank
data TankTree
= Leaf Tape
| Plum Plum
| Palm (Tape, Tape, Tape, Tape) [Tank]
| Rose (Tape, Tape, Tape) [Tank]
| Palm (Tape, Tape, Tape, Tape) [TankTree]
| Rose (Tape, Tape, Tape) [TankTree]
deriving (Eq, Ord, Show)
newtype Tank = Tank { tankTree :: TankTree }
deriving newtype (Eq, Ord, Show)
instance ToNoun Tank where
toNoun (Tank t) = toNoun t
instance FromNoun Tank where
parseNoun n@(Atom _) = do
Cord txt <- parseNoun n
pure $ Tank $ Leaf $ Tape txt
parseNoun n = Tank <$> parseNoun n
data WideFmt = WideFmt { delimit :: Cord, enclose :: Maybe (Cord, Cord) }
deriving (Eq, Ord, Show)
@ -39,7 +53,7 @@ data PlumTree
deriveNoun ''WideFmt
deriveNoun ''TallFmt
deriveNoun ''PlumFmt
deriveNoun ''Tank
deriveNoun ''TankTree
deriveNoun ''PlumTree
--------------------------------------------------------------------------------
@ -51,7 +65,7 @@ data WashCfg = WashCfg
--------------------------------------------------------------------------------
wash :: WashCfg -> Tank -> Wall
wash :: WashCfg -> TankTree -> Wall
wash _cfg t = [ram t]
-- win :: WashCfg -> Tank -> Wall
@ -60,7 +74,7 @@ wash _cfg t = [ram t]
flat :: Plum -> Tape
flat = Tape . tshow
ram :: Tank -> Tape
ram :: TankTree -> Tape
ram = \case
Leaf tape -> tape
Plum plum -> flat plum

48
pkg/hs/urbit-king/lib/Urbit/Time.hs → pkg/hs/urbit-noun/lib/Urbit/Noun/Time.hs
View File

@ -2,16 +2,21 @@
TODO This is slow.
-}
module Urbit.Time where
module Urbit.Noun.Time where
import Control.Lens
import Prelude
import Data.Bits (shiftL, shiftR)
import Data.Time.Clock (DiffTime, UTCTime)
import Data.Bits (shiftL, shiftR, (.&.))
import Data.List (intercalate)
import Data.Time.Calendar (toGregorian)
import Data.Time.Clock (DiffTime, UTCTime(..))
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Time.Clock.System (SystemTime(..), getSystemTime)
import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
import Data.Time.LocalTime (TimeOfDay(..), timeToTimeOfDay)
import Data.Word (Word64)
import Text.Printf (printf)
import Urbit.Noun (FromNoun, ToNoun)
@ -26,12 +31,47 @@ newtype Unix = Unix { _sinceUnixEpoch :: Gap }
newtype Wen = Wen { _sinceUrbitEpoch :: Gap }
deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun)
newtype Date = MkDate { _dateWen :: Wen }
deriving newtype (Eq, Ord, Num, ToNoun, FromNoun)
-- Lenses ----------------------------------------------------------------------
-- Record Lenses ---------------------------------------------------------------
makeLenses ''Gap
makeLenses ''Unix
makeLenses ''Wen
makeLenses ''Date
-- Instances -------------------------------------------------------------------
instance Show Date where
show (MkDate wen) = if fs == 0
then printf "~%i.%u.%u..%02u.%02u.%02u" y m d h min s
else printf "~%i.%u.%u..%02u.%02u.%02u..%s" y m d h min s (showGap fs)
where
utc = wen ^. systemTime . to systemToUTCTime
(y, m, d) = toGregorian (utctDay utc)
TimeOfDay h min (floor -> s::Int) = timeToTimeOfDay (utctDayTime utc)
fs = (wen ^. wenFracto . to (fromIntegral @Integer @Word64))
wenFracto :: Lens' Wen Integer
wenFracto = sinceUrbitEpoch . fractoSecs
showGap :: Word64 -> String
showGap gap = intercalate "." (printf "%04x" <$> bs)
where
bs = reverse $ dropWhile (== 0) [b4, b3, b2, b1]
b4 = takeBits 16 gap
b3 = takeBits 16 (shiftR gap 16)
b2 = takeBits 16 (shiftR gap 32)
b1 = takeBits 16 (shiftR gap 48)
takeBits :: Int -> Word64 -> Word64
takeBits wid wor = wor .&. (shiftL 1 wid - 1)
-- Conversion Lenses -----------------------------------------------------------
diffTime :: Iso' Gap DiffTime
diffTime = iso fromGap toGap

0
pkg/hs/urbit-king/lib/Urbit/Noun/Tree.hs → pkg/hs/urbit-noun/lib/Urbit/Noun/Tree.hs
View File

73
pkg/hs/urbit-noun/package.yaml Normal file
View File

@ -0,0 +1,73 @@
name: urbit-noun
version: 0.10.4
license: MIT
license-file: LICENSE
library:
source-dirs: lib
ghc-options:
- -fwarn-incomplete-patterns
- -fwarn-unused-binds
- -fwarn-unused-imports
- -Werror
- -O2
dependencies:
- base
- classy-prelude
- ghc-prim
- largeword
- lens
- murmur3
- regex-tdfa
- regex-tdfa-text
- rio
- text
- time
- urbit-atom
- urbit-noun-core
default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass
- DeriveDataTypeable
- DeriveFoldable
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- EmptyCase
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- FunctionalDependencies
- GADTs
- GeneralizedNewtypeDeriving
- LambdaCase
- MagicHash
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- NumericUnderscores
- OverloadedStrings
- PackageImports
- PartialTypeSignatures
- PatternSynonyms
- QuasiQuotes
- Rank2Types
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TemplateHaskell
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UnboxedTuples
- UnicodeSyntax
- ViewPatterns

2
pkg/urbit/Makefile
View File

@ -2,7 +2,7 @@ include config.mk
jets = jets/tree.c $(wildcard jets/*/*.c)
noun = $(wildcard noun/*.c)
vere = $(wildcard vere/*.c)
vere = $(wildcard vere/*.c) $(wildcard vere/*/*.c)
daemon = $(wildcard daemon/*.c)
worker = $(wildcard worker/*.c)
tests = $(wildcard tests/*.c)

2
pkg/urbit/configure vendored
View File

@ -6,7 +6,7 @@ URBIT_VERSION="0.10.5"
deps=" \
curl gmp sigsegv argon2 ed25519 ent h2o scrypt sni uv murmur3 secp256k1 \
softfloat3 ncurses ssl crypto z lmdb ge-additions aes_siv \
softfloat3 ssl crypto z lmdb ge-additions aes_siv \
"
headers=" \

24
pkg/urbit/daemon/main.c
View File

@ -9,9 +9,7 @@
#include <uv.h>
#include <sigsegv.h>
#include <stdlib.h>
#include <ncurses/curses.h>
#include <termios.h>
#include <ncurses/term.h>
#include <dirent.h>
#include <openssl/conf.h>
#include <openssl/engine.h>
@ -20,6 +18,7 @@
#include <h2o.h>
#include <curl/curl.h>
#include <argon2.h>
#include <lmdb.h>
#define U3_GLOBAL
#define C3_GLOBAL
@ -96,7 +95,7 @@ _main_getopt(c3_i argc, c3_c** argv)
u3_Host.ops_u.kno_w = DefaultKernel;
while ( -1 != (ch_i=getopt(argc, argv,
"G:J:B:K:A:H:I:w:u:e:F:k:p:LljacdgqstvxPDRS")) )
"G:J:B:K:A:H:I:w:u:e:F:k:n:p:r:LljacdgqstvxPDRS")) )
{
switch ( ch_i ) {
case 'J': {
@ -155,6 +154,10 @@ _main_getopt(c3_i argc, c3_c** argv)
u3_Host.ops_u.key_c = strdup(optarg);
break;
}
case 'n': {
u3_Host.ops_u.til_c = strdup(optarg);
break;
}
case 'p': {
if ( c3n == _main_readw(optarg, 65536, &arg_w) ) {
return c3n;
@ -165,6 +168,10 @@ _main_getopt(c3_i argc, c3_c** argv)
u3_Host.ops_u.rep = c3y;
return c3y;
}
case 'r': {
u3_Host.ops_u.roc_c = strdup(optarg);
break;
}
case 'L': { u3_Host.ops_u.net = c3n; break; }
case 'l': { u3_Host.ops_u.lit = c3y; break; }
case 'j': { u3_Host.ops_u.tra = c3y; break; }
@ -442,7 +449,6 @@ report(void)
(libsigsegv_version >> 8) & 0xff,
libsigsegv_version & 0xff);
printf("openssl: %s\n", SSLeay_version(SSLEAY_VERSION));
printf("curses: %s\n", curses_version());
printf("libuv: %s\n", uv_version_string());
printf("libh2o: %d.%d.%d\n",
H2O_LIBRARY_VERSION_MAJOR,
@ -477,9 +483,7 @@ _stop_signal(c3_i int_i)
{
// if we have a pier, unmap the event log before dumping core
//
if ( 0 != u3K.len_w ) {
u3_pier_db_shutdown(u3_pier_stub());
}
u3_pier_halt();
}
/*
@ -596,12 +600,6 @@ main(c3_i argc,
u3_Host.wrk_c = c3_malloc(worker_exe_len);
snprintf(u3_Host.wrk_c, worker_exe_len, "%s-worker", argv[0]);
// Set TERMINFO_DIRS environment variable
c3_i terminfo_len = 1 + strlen(argv[0]) + strlen("-terminfo");
c3_c terminfo_dir[terminfo_len];
snprintf(terminfo_dir, terminfo_len, "%s-terminfo", argv[0]);
setenv("TERMINFO_DIRS", terminfo_dir, 1);
if ( c3y == u3_Host.ops_u.dem ) {
_fork_into_background_process();
}

2
pkg/urbit/include/c/defs.h
View File

@ -41,7 +41,7 @@
/* Stub.
*/
# define c3_stub (assert(!"stub"), 0)
# define c3_stub c3_assert(!"stub")
/* Size in words.
*/

4
pkg/urbit/include/c/motes.h
View File

@ -365,6 +365,7 @@
# define c3__dumb c3_s4('d','u','m','b')
# define c3__dump c3_s4('d','u','m','p')
# define c3__dust c3_s4('d','u','s','t')
# define c3__e c3_s1('e')
# define c3__earl c3_s4('e','a','r','l')
# define c3__east c3_s4('e','a','s','t')
# define c3__echo c3_s4('e','c','h','o')
@ -928,6 +929,7 @@
# define c3__revo c3_s4('r','e','v','o')
# define c3__rin c3_s3('r','i','n')
# define c3__ring c3_s4('r','i','n','g')
# define c3__ripe c3_s4('r','i','p','e')
# define c3__rite c3_s4('r','i','t','e')
# define c3__rock c3_s4('r','o','c','k')
# define c3__roll c3_s4('r','o','l','l')
@ -1062,6 +1064,7 @@
# define c3__sunt c3_s4('s','u','n','t')
# define c3__sure c3_s4('s','u','r','e')
# define c3__susp c3_s4('s','u','s','p')
# define c3__swap c3_s4('s','w','a','p')
# define c3__sym c3_s3('s','y','m')
# define c3__sync c3_s4('s','y','n','c')
# define c3__sys c3_s3('s','y','s')
@ -1206,6 +1209,7 @@
# define c3__wack c3_s4('w','a','c','k')
# define c3__wail c3_s4('w','a','i','l')
# define c3__wake c3_s4('w','a','k','e')
# define c3__walk c3_s4('w','a','l','k')
# define c3__wamp c3_s4('w','a','m','p')
# define c3__want c3_s4('w','a','n','t')
# define c3__warm c3_s4('w','a','r','m')

5
pkg/urbit/include/noun/aliases.h
View File

@ -84,6 +84,11 @@
# define u3nt(a, b, c) u3i_trel(a, b, c)
# define u3nq(a, b, c, d) u3i_qual(a, b, c, d)
/* u3nl(), u3_none-terminated varargs list
*/
# define u3nl u3i_list
/* u3du(), u3ud(): noun/cell test.
*/
# define u3du(som) (u3r_du(som))

83
pkg/urbit/include/noun/imprison.h
View File

@ -1,60 +1,67 @@
/* include/n/i.h
/* include/noun/imprison.h
**
** This file is in the public domain.
*/
/* General constructors.
*/
/* u3i_words():
**
** Copy [a] words from [b] into an atom.
*/
u3_noun
u3i_words(c3_w a_w,
const c3_w* b_w);
/* u3i_bytes():
**
** Copy `a` bytes from `b` to an LSB first atom.
/* u3i_bytes(): Copy [a] bytes from [b] to an LSB first atom.
*/
u3_noun
u3i_bytes(c3_w a_w,
const c3_y* b_y);
/* u3i_mp():
**
** Copy the GMP integer `a` into an atom, and clear it.
/* u3i_words(): Copy [a] words from [b] into an atom.
*/
u3_noun
u3i_words(c3_w a_w,
const c3_w* b_w);
/* u3i_chubs(): Copy [a] chubs from [b] into an atom.
*/
u3_atom
u3i_chubs(c3_w a_w,
const c3_d* b_d);
/* u3i_mp(): Copy the GMP integer [a] into an atom, and clear it.
*/
u3_noun
u3i_mp(mpz_t a_mp);
/* u3i_vint():
**
** Create `a + 1`.
/* u3i_vint(): increment [a].
*/
u3_noun
u3i_vint(u3_noun a);
/* u3i_cell():
**
** Produce the cell `[a b]`.
/* u3i_cell(): Produce the cell `[a b]`.
*/
u3_noun
u3i_cell(u3_noun a, u3_noun b);
/* u3i_trel():
**
** Produce the triple `[a b c]`.
/* u3i_trel(): Produce the triple `[a b c]`.
*/
u3_noun
u3i_trel(u3_noun a, u3_noun b, u3_noun c);
/* u3i_qual():
**
** Produce the cell `[a b c d]`.
/* u3i_qual(): Produce the cell `[a b c d]`.
*/
u3_noun
u3i_qual(u3_noun a, u3_noun b, u3_noun c, u3_noun d);
/* u3i_string(): Produce an LSB-first atom from the C string [a].
*/
u3_noun
u3i_string(const c3_c* a_c);
/* u3i_tape(): from a C string, to a list of bytes.
*/
u3_atom
u3i_tape(const c3_c* txt_c);
/* u3i_list(): list from `u3_none`-terminated varargs.
*/
u3_noun
u3i_list(u3_weak som, ...);
/* u3i_edit():
**
** Mutate `big` at axis `axe` with new value `som`
@ -63,13 +70,6 @@
u3_noun
u3i_edit(u3_noun big, u3_noun axe, u3_noun som);
/* u3i_string():
**
** Produce an LSB-first atom from the C string `a`.
*/
u3_noun
u3i_string(const c3_c* a_c);
/* u3i_molt():
**
** Mutate `som` with a 0-terminated list of axis, noun pairs.
@ -77,18 +77,3 @@
*/
u3_noun
u3i_molt(u3_noun som, ...);
/* u3i_chubs():
**
** Construct `a` double-words from `b`, LSD first, as an atom.
*/
u3_atom
u3i_chubs(c3_w a_w,
const c3_d* b_d);
/* u3i_tape(): from a C string, to a list of bytes.
*/
u3_atom
u3i_tape(const c3_c* txt_c);

15
pkg/urbit/include/noun/retrieve.h
View File

@ -404,6 +404,21 @@
c3_d* c_d,
u3_atom d);
/* u3r_safe_byte(): validate and retrieve byte.
*/
c3_o
u3r_safe_byte(u3_noun dat, c3_y* out_y);
/* u3r_safe_word(): validate and retrieve word.
*/
c3_o
u3r_safe_word(u3_noun dat, c3_w* out_w);
/* u3r_safe_chub(): validate and retrieve chub.
*/
c3_o
u3r_safe_chub(u3_noun dat, c3_d* out_d);
/* u3r_string(): `a`, a text atom, as malloced C string.
*/
c3_c*

5
pkg/urbit/include/noun/vortex.h
View File

@ -34,6 +34,11 @@
/** Functions.
**/
/* u3v_life(): execute initial lifecycle, producing Arvo core.
*/
u3_noun
u3v_life(u3_noun eve);
/* u3v_boot(): evaluate boot sequence, making a kernel
*/
c3_o

56
pkg/urbit/include/vere/db/lmdb.h Normal file
View File

@ -0,0 +1,56 @@
/* include/vere/db/lmdb-impl.h
*/
#include <lmdb.h>
/* lmdb api wrapper
*/
/* c3_lmdb_init(): open lmdb at [pax_c], mmap up to [siz_i].
*/
MDB_env*
c3_lmdb_init(const c3_c* pax_c, size_t siz_i);
/* c3_lmdb_exit(): close lmdb.
*/
void
c3_lmdb_exit(MDB_env* env_u);
/* c3_lmdb_gulf(): read first and last event numbers.
*/
c3_o
c3_lmdb_gulf(MDB_env* env_u, c3_d* low_d, c3_d* hig_d);
/* c3_lmdb_read(): read [len_d] events starting at [eve_d].
*/
c3_o
c3_lmdb_read(MDB_env* env_u,
void* vod_p,
c3_d eve_d,
c3_d len_d,
c3_o (*read_f)(void*, c3_d, size_t , void*));
/* c3_lmdb_save(): save [len_d] events starting at [eve_d].
*/
c3_o
c3_lmdb_save(MDB_env* env_u,
c3_d eve_d,
c3_d len_d,
void** byt_p,
size_t* siz_i);
/* c3_lmdb_read_meta(): read by string from the META db.
*/
void
c3_lmdb_read_meta(MDB_env* env_u,
void* vod_p,
const c3_c* key_c,
void (*read_f)(void*, size_t, void*));
/* c3_lmdb_save_meta(): save by string into the META db.
*/
c3_o
c3_lmdb_save_meta(MDB_env* env_u,
const c3_c* key_c,
size_t val_i,
void* val_p);

60
pkg/urbit/include/vere/serf.h Normal file
View File

@ -0,0 +1,60 @@
/* include/vere/serf.h
*/
/** Data types.
**/
/* u3_serf: worker-process state
*/
typedef struct _u3_serf {
c3_d key_d[4]; // disk key
c3_c* dir_c; // execution directory (pier)
c3_d sen_d; // last event requested
c3_d dun_d; // last event processed
c3_l mug_l; // hash of state
c3_o pac_o; // pack kernel
c3_o rec_o; // reclaim cache
c3_o mut_o; // mutated kerne
u3_noun sac; // space measurementl
} u3_serf;
/** Functions.
**/
/* u3_serf_init(): init or restore, producing status.
*/
u3_noun
u3_serf_init(u3_serf* sef_u);
/* u3_serf_unpack(): initialize from rock at [eve_d].
*/
void
u3_serf_unpack(u3_serf* sef_u, c3_d eve_d);
/* u3_serf_writ(): apply writ [wit], producing plea [*pel] on c3y.
*/
c3_o
u3_serf_writ(u3_serf* sef_u, u3_noun wit, u3_noun* pel);
/* u3_serf_live(): apply %live command [com], producing *ret on c3y.
*/
c3_o
u3_serf_live(u3_serf* sef_u, u3_noun com, u3_noun* ret);
/* u3_serf_peek(): read namespace.
*/
u3_noun
u3_serf_peek(u3_serf* sef_u, u3_noun sam);
/* u3_serf_play(): apply event list, producing status.
*/
u3_noun
u3_serf_play(u3_serf* sef_u, c3_d eve_d, u3_noun lit);
/* u3_serf_work(): apply event, producing effects.
*/
u3_noun
u3_serf_work(u3_serf* sef_u, u3_noun job);
/* u3_serf_post(): update serf state post-writ.
*/
void
u3_serf_post(u3_serf* sef_u);

1231
pkg/urbit/include/vere/vere.h
View File

File diff suppressed because it is too large Load Diff

395
pkg/urbit/noun/imprison.c
View File

@ -1,90 +1,25 @@
/* g/i.c
/* noun/imprison.c
**
*/
#include "all.h"
/* u3i_words():
**
** Copy [a] words from [b] into an atom.
*/
u3_noun
u3i_words(c3_w a_w,
const c3_w* b_w)
{
/* Strip trailing zeroes.
*/
while ( a_w && !b_w[a_w - 1] ) {
a_w--;
}
/* Check for cat.
*/
if ( !a_w ) {
return 0;
}
else if ( (a_w == 1) && !(b_w[0] >> 31) ) {
return b_w[0];
}
/* Allocate, fill, return.
*/
{
c3_w* nov_w = u3a_walloc(a_w + c3_wiseof(u3a_atom));
u3a_atom* nov_u = (void*)nov_w;
nov_u->mug_w = 0;
nov_u->len_w = a_w;
/* Fill the words.
*/
{
c3_w i_w;
for ( i_w=0; i_w < a_w; i_w++ ) {
nov_u->buf_w[i_w] = b_w[i_w];
}
}
return u3a_to_pug(u3a_outa(nov_w));
}
}
/* u3i_chubs():
**
** Construct `a` double-words from `b`, LSD first, as an atom.
*/
u3_atom
u3i_chubs(c3_w a_w,
const c3_d* b_d)
{
c3_w *b_w = c3_malloc(a_w * 8);
c3_w i_w;
u3_atom p;
for ( i_w = 0; i_w < a_w; i_w++ ) {
b_w[(2 * i_w)] = b_d[i_w] & 0xffffffffULL;
b_w[(2 * i_w) + 1] = b_d[i_w] >> 32ULL;
}
p = u3i_words((a_w * 2), b_w);
c3_free(b_w);
return p;
}
/* u3i_bytes():
**
** Copy `a` bytes from `b` to an LSB first atom.
/* u3i_bytes(): Copy [a] bytes from [b] to an LSB first atom.
*/
u3_noun
u3i_bytes(c3_w a_w,
const c3_y* b_y)
const c3_y* b_y)
{
/* Strip trailing zeroes.
*/
u3_noun pro;
u3t_on(mal_o);
// Strip trailing zeroes.
//
while ( a_w && !b_y[a_w - 1] ) {
a_w--;
}
/* Check for cat.
*/
// Check for cat.
//
if ( a_w <= 4 ) {
if ( !a_w ) {
return 0;
@ -103,18 +38,18 @@ u3i_bytes(c3_w a_w,
}
}
/* Allocate, fill, return.
*/
// Allocate, fill, return.
//
{
c3_w len_w = (a_w + 3) >> 2;
c3_w* nov_w = u3a_walloc((len_w + c3_wiseof(u3a_atom)));
c3_w len_w = (a_w + 3) >> 2;
c3_w* nov_w = u3a_walloc((len_w + c3_wiseof(u3a_atom)));
u3a_atom* nov_u = (void*)nov_w;
nov_u->mug_w = 0;
nov_u->len_w = len_w;
/* Clear the words.
*/
// Clear the words.
//
{
c3_w i_w;
@ -123,8 +58,8 @@ u3i_bytes(c3_w a_w,
}
}
/* Fill the bytes.
*/
// Fill the bytes.
//
{
c3_w i_w;
@ -132,13 +67,137 @@ u3i_bytes(c3_w a_w,
nov_u->buf_w[i_w >> 2] |= (b_y[i_w] << ((i_w & 3) * 8));
}
}
return u3a_to_pug(u3a_outa(nov_w));
pro = u3a_to_pug(u3a_outa(nov_w));
}
u3t_off(mal_o);
return pro;
}
/* u3i_mp():
**
** Copy the GMP integer `a` into an atom, and clear it.
/* u3i_words(): Copy [a] words from [b] into an atom.
*/
u3_noun
u3i_words(c3_w a_w,
const c3_w* b_w)
{
u3_noun pro;
u3t_on(mal_o);
// Strip trailing zeroes.
//
while ( a_w && !b_w[a_w - 1] ) {
a_w--;
}
// Check for cat.
//
if ( !a_w ) {
return 0;
}
else if ( (a_w == 1) && !(b_w[0] >> 31) ) {
return b_w[0];
}
// Allocate, fill, return.
//
{
c3_w* nov_w = u3a_walloc(a_w + c3_wiseof(u3a_atom));
u3a_atom* nov_u = (void*)nov_w;
nov_u->mug_w = 0;
nov_u->len_w = a_w;
// Fill the words.
//
{
c3_w i_w;
for ( i_w=0; i_w < a_w; i_w++ ) {
nov_u->buf_w[i_w] = b_w[i_w];
}
}
pro = u3a_to_pug(u3a_outa(nov_w));
}
u3t_off(mal_o);
return pro;
}
/* u3i_chubs(): Copy [a] chubs from [b] into an atom.
*/
u3_atom
u3i_chubs(c3_w a_w,
const c3_d* b_d)
{
u3_noun pro;
u3t_on(mal_o);
// Strip trailing zeroes.
//
while ( a_w && !b_d[a_w - 1] ) {
a_w--;
}
// Check for cat.
//
if ( !a_w ) {
return 0;
}
else if ( (1 == a_w) && !(b_d[0] >> 31) ) {
return (c3_w)b_d[0];
}
// Allocate, fill, return.
//
{
c3_w len_w = 2 * a_w;
if ( !(b_d[a_w - 1] >> 32) ) {
len_w--;
}
c3_w* nov_w = u3a_walloc(len_w + c3_wiseof(u3a_atom));
u3a_atom* nov_u = (void*)nov_w;
nov_u->mug_w = 0;
nov_u->len_w = len_w;
// Fill the words.
//
{
c3_w i_w, x_w, max_w = a_w - 1;
c3_d i_d;
for ( i_w = 0; i_w < max_w; i_w++ ) {
i_d = b_d[i_w];
x_w = 2 * i_w;
nov_u->buf_w[x_w] = i_d & 0xffffffffULL;
x_w++;
nov_u->buf_w[x_w] = i_d >> 32;
}
{
i_d = b_d[i_w];
x_w = 2 * i_w;
nov_u->buf_w[x_w] = i_d & 0xffffffffULL;
x_w++;
}
if ( x_w < len_w ) {
nov_u->buf_w[x_w] = i_d >> 32;
}
}
pro = u3a_to_pug(u3a_outa(nov_w));
}
u3t_off(mal_o);
return pro;
}
/* u3i_mp(): Copy the GMP integer [a] into an atom, and clear it.
*/
u3_noun
u3i_mp(mpz_t a_mp)
@ -152,9 +211,7 @@ u3i_mp(mpz_t a_mp)
return u3a_malt(buz_w);
}
/* u3i_vint():
**
** Create `a + 1`.
/* u3i_vint(): increment [a].
*/
u3_noun
u3i_vint(u3_noun a)
@ -176,67 +233,41 @@ u3i_vint(u3_noun a)
mpz_t a_mp;
u3r_mp(a_mp, a);
u3a_lose(a);
u3z(a);
mpz_add_ui(a_mp, a_mp, 1);
return u3i_mp(a_mp);
}
}
c3_w BAD;
/* u3i_cell():
**
** Produce the cell `[a b]`.
/* u3i_cell(): Produce the cell `[a b]`.
*/
u3_noun
u3i_cell(u3_noun a, u3_noun b)
{
u3_noun pro;
u3t_on(mal_o);
#ifdef U3_CPU_DEBUG
u3R->pro.cel_d++;
#endif
{
// c3_w* nov_w = u3a_walloc(c3_wiseof(u3a_cell));
c3_w* nov_w = u3a_celloc();
c3_w* nov_w = u3a_celloc();
u3a_cell* nov_u = (void *)nov_w;
u3_noun pro;
nov_u->mug_w = 0;
nov_u->hed = a;
nov_u->tel = b;
pro = u3a_to_pom(u3a_outa(nov_w));
#if 0
if ( (0x730e66cc == u3r_mug(pro)) &&
(c3__tssg == u3h(u3t(u3t(pro)))) ) {
static c3_w xuc_w;
u3l_log("BAD %x %p\r\n", pro, u3a_to_ptr(a));
BAD = pro;
if ( xuc_w == 1 ) u3m_bail(c3__exit);
xuc_w++;
}
#endif
#if 1
u3t_off(mal_o);
return pro;
#else
if ( !FOO ) return u3a_to_pom(u3a_outa(nov_w));
else {
u3_noun pro = u3a_to_pom(u3a_outa(nov_w));
u3m_p("leaked", pro);
u3l_log("pro %u, %x\r\n", pro, u3r_mug(pro));
abort();
}
#endif
}
u3t_off(mal_o);
return pro;
}
/* u3i_trel():
**
** Produce the triple `[a b c]`.
/* u3i_trel(): Produce the triple `[a b c]`.
*/
u3_noun
u3i_trel(u3_noun a, u3_noun b, u3_noun c)
@ -244,9 +275,7 @@ u3i_trel(u3_noun a, u3_noun b, u3_noun c)
return u3i_cell(a, u3i_cell(b, c));
}
/* u3i_qual():
**
** Produce the cell `[a b c d]`.
/* u3i_qual(): Produce the cell `[a b c d]`.
*/
u3_noun
u3i_qual(u3_noun a, u3_noun b, u3_noun c, u3_noun d)
@ -254,6 +283,57 @@ u3i_qual(u3_noun a, u3_noun b, u3_noun c, u3_noun d)
return u3i_cell(a, u3i_trel(b, c, d));
}
/* u3i_string(): Produce an LSB-first atom from the C string [a].
*/
u3_noun
u3i_string(const c3_c* a_c)
{
return u3i_bytes(strlen(a_c), (c3_y *)a_c);
}
/* u3i_tape(): from a C string, to a list of bytes.
*/
u3_atom
u3i_tape(const c3_c* txt_c)
{
if ( !*txt_c ) {
return u3_nul;
} else return u3i_cell(*txt_c, u3i_tape(txt_c + 1));
}
/* u3i_list(): list from `u3_none`-terminated varargs.
*/
u3_noun
u3i_list(u3_weak som, ...)
{
u3_noun lit = u3_nul;
va_list ap;
if ( u3_none == som ) {
return lit;
}
else {
lit = u3nc(som, lit);
}
{
u3_noun tem;
va_start(ap, som);
while ( 1 ) {
if ( u3_none == (tem = va_arg(ap, u3_weak)) ) {
break;
}
else {
lit = u3nc(tem, lit);
}
}
va_end(ap);
}
return u3kb_flop(lit);
}
static u3_noun
_edit_cat(u3_noun big, c3_l axe_l, u3_noun som)
{
@ -398,48 +478,6 @@ u3i_edit(u3_noun big, u3_noun axe, u3_noun som)
}
}
/* u3i_string():
**
** Produce an LSB-first atom from the C string `a`.
*/
u3_noun
u3i_string(const c3_c* a_c)
{
return u3i_bytes(strlen(a_c), (c3_y *)a_c);
}
/* u3i_tape(): from a C string, to a list of bytes.
*/
u3_atom
u3i_tape(const c3_c* txt_c)
{
if ( !*txt_c ) {
return u3_nul;
} else return u3i_cell(*txt_c, u3i_tape(txt_c + 1));
}
/* u3i_decimal():
**
** Parse `a` as a list of decimal digits.
*/
u3_atom
u3i_decimal(u3_noun a);
/* u3i_heximal():
**
** Parse `a` as a list of hex digits.
*/
u3_noun
u3i_heximal(u3_noun a);
/* u3i_list():
**
** Generate a null-terminated list, with `u3_none` as terminator.
*/
u3_noun
u3i_list(u3_weak one, ...);
/* u3i_molt():
**
** Mutate `som` with a 0-terminated list of axis, noun pairs.
@ -476,7 +514,7 @@ u3i_list(u3_weak one, ...);
struct _molt_pair* pms_m) // transfer
{
if ( len_w == 0 ) {
return u3a_gain(som);
return u3k(som);
}
else if ( (len_w == 1) && (1 == pms_m[0].axe_w) ) {
return pms_m[0].som;
@ -503,8 +541,8 @@ u3i_molt(u3_noun som, ...)
struct _molt_pair* pms_m;
u3_noun pro;
/* Count.
*/
// Count.
//
len_w = 0;
{
va_start(ap, som);
@ -521,8 +559,8 @@ u3i_molt(u3_noun som, ...)
c3_assert( 0 != len_w );
pms_m = alloca(len_w * sizeof(struct _molt_pair));
/* Install.
*/
// Install.
//
{
c3_w i_w;
@ -534,10 +572,9 @@ u3i_molt(u3_noun som, ...)
va_end(ap);
}
/* Apply.
*/
// Apply.
//
pro = _molt_apply(som, len_w, pms_m);
u3a_lose(som);
u3z(som);
return pro;
}

2
pkg/urbit/noun/manage.c
View File

@ -370,7 +370,9 @@ _cm_signal_done()
signal(SIGTERM, SIG_IGN);
signal(SIGVTALRM, SIG_IGN);
#ifndef NO_OVERFLOW
stackoverflow_deinstall_handler();
#endif
{
struct itimerval itm_u;

80
pkg/urbit/noun/retrieve.c
View File

@ -1202,6 +1202,51 @@ u3r_chubs(c3_w a_w,
u3r_words(a_w * 2, b_w * 2, (c3_w *)c_d, d);
}
/* u3r_safe_byte(): validate and retrieve byte.
*/
c3_o
u3r_safe_byte(u3_noun dat, c3_y* out_y)
{
if ( (c3n == u3a_is_atom(dat))
|| (1 < u3r_met(3, dat)) )
{
return c3n;
}
*out_y = u3r_byte(0, dat);
return c3y;
}
/* u3r_safe_word(): validate and retrieve word.
*/
c3_o
u3r_safe_word(u3_noun dat, c3_w* out_w)
{
if ( (c3n == u3a_is_atom(dat))
|| (1 < u3r_met(5, dat)) )
{
return c3n;
}
*out_w = u3r_word(0, dat);
return c3y;
}
/* u3r_safe_chub(): validate and retrieve chub.
*/
c3_o
u3r_safe_chub(u3_noun dat, c3_d* out_d)
{
if ( (c3n == u3a_is_atom(dat))
|| (1 < u3r_met(6, dat)) )
{
return c3n;
}
*out_d = u3r_chub(0, dat);
return c3y;
}
/* u3r_chop():
**
** Into the bloq space of `met`, from position `fum` for a
@ -1342,7 +1387,7 @@ u3r_mug_chub(c3_d num_d)
c3_w buf_w[2];
buf_w[0] = (c3_w)(num_d & 0xffffffffULL);
buf_w[1] = (c3_w)(num_d >> 32ULL);
buf_w[1] = (c3_w)(num_d >> 32);
return u3r_mug_words(buf_w, 2);
}
@ -1360,14 +1405,30 @@ u3r_mug_string(const c3_c *a_c)
c3_w
u3r_mug_words(const c3_w* key_w, c3_w len_w)
{
c3_w byt_w = 0;
c3_w wor_w;
c3_w byt_w;
while ( 0 < len_w ) {
wor_w = key_w[--len_w];
byt_w += _(u3a_is_cat(wor_w)) ? u3r_met(3, wor_w) : 4;
// ignore trailing zeros
//
while ( len_w && !key_w[len_w - 1] ) {
len_w--;
}
// calculate byte-width a la u3r_met(3, ...)
//
if ( !len_w ) {
byt_w = 0;
}
else {
c3_w gal_w = len_w - 1;
c3_w daz_w = key_w[gal_w];
byt_w = (gal_w << 2)
+ ((daz_w >> 24) ? 4 : (daz_w >> 16) ? 3 : (daz_w >> 8) ? 2 : 1);
}
// XX: assumes little-endian
//
return u3r_mug_bytes((c3_y*)key_w, byt_w);
}
@ -1377,8 +1438,7 @@ c3_w
u3r_mug_both(c3_w lef_w, c3_w rit_w)
{
c3_w ham_w = lef_w ^ (0x7fffffff ^ rit_w);
return u3r_mug_words(&ham_w, (0 == ham_w) ? 0 : 1);
return u3r_mug_words(&ham_w, 1);
}
/* u3r_mug_cell(): Compute the mug of the cell `[hed tel]`.
@ -1486,7 +1546,7 @@ u3r_mug(u3_noun veb)
// veb is a direct atom, mug is not memoized
//
if ( _(u3a_is_cat(veb)) ) {
mug_w = u3r_mug_bytes((c3_y*)&veb, u3r_met(3, veb));
mug_w = u3r_mug_words(&veb, 1);
goto retreat;
}
// veb is indirect, a pointer into the loom
@ -1504,7 +1564,7 @@ u3r_mug(u3_noun veb)
//
else if ( _(u3a_is_atom(veb)) ) {
u3a_atom* vat_u = (u3a_atom*)veb_u;
mug_w = u3r_mug_bytes((c3_y*)vat_u->buf_w, u3r_met(3, veb));
mug_w = u3r_mug_words(vat_u->buf_w, vat_u->len_w);
vat_u->mug_w = mug_w;
goto retreat;
}

10
pkg/urbit/noun/vortex.c
View File

@ -8,10 +8,10 @@
#define _CVX_POKE 47
#define _CVX_PEEK 46
/* _cv_life(): execute initial lifecycle, producing Arvo core.
/* u3v_life(): execute initial lifecycle, producing Arvo core.
*/
static u3_noun
_cv_life(u3_noun eve)
u3_noun
u3v_life(u3_noun eve)
{
u3_noun lyf = u3nt(2, u3nc(0, 3), u3nc(0, 2));
u3_noun gat = u3n_nock_on(eve, lyf);
@ -31,7 +31,7 @@ u3v_boot(u3_noun eve)
u3A->roc = 0;
{
u3_noun pro = u3m_soft(0, _cv_life, eve);
u3_noun pro = u3m_soft(0, u3v_life, eve);
if ( u3_blip != u3h(pro) ) {
u3z(pro);
@ -56,7 +56,7 @@ _cv_lite(u3_noun pil)
u3x_trel(arv, &eve, 0, 0);
u3l_log("lite: arvo formula %x\r\n", u3r_mug(arv));
pro = _cv_life(u3k(eve));
pro = u3v_life(u3k(eve));
u3l_log("lite: core %x\r\n", u3r_mug(pro));
u3z(arv);

81
pkg/urbit/tests/mug_tests.c
View File

@ -94,6 +94,87 @@ _test_mug(void)
c3_free(str_w);
}
{
c3_w som_w[4];
u3_noun som;
{
som_w[0] = 0;
som_w[1] = 0;
som_w[2] = 0;
som_w[3] = 1;
som = u3i_words(4, som_w);
if ( 0x519bd45c != u3r_mug(som) ) {
fprintf(stderr, "fail (j) (1)\r\n");
exit(1);
}
if ( 0x519bd45c != u3r_mug_words(som_w, 4) ) {
fprintf(stderr, "fail (j) (2)\r\n");
exit(1);
}
u3z(som);
}
{
som_w[0] = 0;
som_w[1] = 1;
som_w[2] = 0;
som_w[3] = 1;
som = u3i_words(4, som_w);
if ( 0x540eb8a9 != u3r_mug(som) ) {
fprintf(stderr, "fail (k) (1)\r\n");
exit(1);
}
if ( 0x540eb8a9 != u3r_mug_words(som_w, 4) ) {
fprintf(stderr, "fail (k) (2)\r\n");
exit(1);
}
u3z(som);
}
{
som_w[0] = 1;
som_w[1] = 1;
som_w[2] = 0;
som_w[3] = 1;
som = u3i_words(4, som_w);
if ( 0x319d28f9 != u3r_mug(som) ) {
fprintf(stderr, "fail (l) (1)\r\n");
exit(1);
}
if ( 0x319d28f9 != u3r_mug_words(som_w, 4) ) {
fprintf(stderr, "fail (l) (2)\r\n");
exit(1);
}
u3z(som);
}
{
som_w[0] = 0;
som_w[1] = 0;
som_w[2] = 0;
som_w[3] = 0xffff;
som = u3i_words(4, som_w);
if ( 0x5230a260 != u3r_mug(som) ) {
fprintf(stderr, "fail (m) (1)\r\n");
exit(1);
}
if ( 0x5230a260 != u3r_mug_words(som_w, 4) ) {
fprintf(stderr, "fail (m) (2)\r\n");
exit(1);
}
u3z(som);
}
}
fprintf(stderr, "test_mug: ok\n");
}

121
pkg/urbit/tests/newt_tests.c
View File

@ -10,20 +10,43 @@ _setup(void)
u3m_pave(c3y, c3n);
}
static c3_w pok_w;
static c3_w bal_w;
static void
_moat_poke_cb(void* vod_p, u3_atom a)
/* _newt_encode(): synchronous serialization into a single buffer, for test purposes
*/
static c3_y*
_newt_encode(u3_atom mat, c3_w* len_w)
{
pok_w++;
u3z(a);
c3_w met_w = u3r_met(3, mat);
c3_y* buf_y;
*len_w = 8 + met_w;
buf_y = c3_malloc(*len_w);
// write header; c3_d is futureproofing
//
buf_y[0] = ((met_w >> 0) & 0xff);
buf_y[1] = ((met_w >> 8) & 0xff);
buf_y[2] = ((met_w >> 16) & 0xff);
buf_y[3] = ((met_w >> 24) & 0xff);
buf_y[4] = buf_y[5] = buf_y[6] = buf_y[7] = 0;
u3r_bytes(0, met_w, buf_y + 8, mat);
u3z(mat);
return buf_y;
}
static void
_moat_bail_cb(void* vod_p, const c3_c* err_c)
static c3_w
_moat_length(u3_moat* mot_u)
{
bal_w++;
u3_meat* met_u = mot_u->ext_u;
c3_w len_w = 0;
while ( met_u ) {
met_u = met_u->nex_u;
len_w++;
}
return len_w;
}
/* _test_newt_smol(): various scenarios with small messages
@ -39,19 +62,16 @@ _test_newt_smol(void)
c3_y* buf_y;
memset(&mot_u, 0, sizeof(u3_moat));
mot_u.pok_f = _moat_poke_cb;
mot_u.bal_f = _moat_bail_cb;
// one message one buffer
//
{
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
u3_newt_decode(&mot_u, buf_y, len_w);
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt smol fail (a)\n");
exit(1);
}
@ -60,10 +80,9 @@ _test_newt_smol(void)
// two messages one buffer
//
{
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
buf_y = c3_realloc(buf_y, 2 * len_w);
memcpy(buf_y + len_w, buf_y, len_w);
@ -71,7 +90,7 @@ _test_newt_smol(void)
u3_newt_decode(&mot_u, buf_y, len_w);
if ( 2 != pok_w ) {
if ( 2 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt smol fail (b)\n");
exit(1);
}
@ -81,24 +100,24 @@ _test_newt_smol(void)
//
{
c3_y* end_y;
pok_w = 0;
bal_w = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = _newt_encode(u3k(a), &len_w);
end_y = c3_malloc(1);
end_y[0] = buf_y[len_w - 1];
u3_newt_decode(&mot_u, buf_y, len_w - 1);
if ( 0 != pok_w ) {
if ( 0 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt smol fail (c)\n");
exit(1);
}
u3_newt_decode(&mot_u, end_y, 1);
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt smol fail (d)\n");
exit(1);
}
@ -110,10 +129,9 @@ _test_newt_smol(void)
c3_y* haf_y;
c3_w haf_w, dub_w;
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
dub_w = 2 * len_w;
haf_w = len_w / 2;
@ -130,14 +148,14 @@ _test_newt_smol(void)
u3_newt_decode(&mot_u, buf_y, dub_w - haf_w);
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt smol fail (e)\n");
exit(1);
}
u3_newt_decode(&mot_u, haf_y, haf_w);
if ( 2 != pok_w ) {
if ( 2 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt smol fail (f)\n");
exit(1);
}
@ -159,19 +177,16 @@ _test_newt_vast(void)
c3_y* buf_y;
memset(&mot_u, 0, sizeof(u3_moat));
mot_u.pok_f = _moat_poke_cb;
mot_u.bal_f = _moat_bail_cb;
// one message one buffer
//
{
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
u3_newt_decode(&mot_u, buf_y, len_w);
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (a)\n");
exit(1);
}
@ -180,10 +195,9 @@ _test_newt_vast(void)
// two messages one buffer
//
{
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
buf_y = c3_realloc(buf_y, 2 * len_w);
memcpy(buf_y + len_w, buf_y, len_w);
@ -191,7 +205,7 @@ _test_newt_vast(void)
u3_newt_decode(&mot_u, buf_y, len_w);
if ( 2 != pok_w ) {
if ( 2 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (b)\n");
exit(1);
}
@ -200,10 +214,9 @@ _test_newt_vast(void)
// one message many buffers
//
{
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
{
c3_y* cop_y = c3_malloc(len_w);
@ -216,7 +229,7 @@ _test_newt_vast(void)
c3_y* end_y = c3_malloc(1);
end_y[0] = cop_y[haf_w];
if ( 0 != pok_w ) {
if ( 0 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (c) %u\n", haf_w);
exit(1);
}
@ -228,7 +241,7 @@ _test_newt_vast(void)
c3_free(cop_y);
}
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (d)\n");
exit(1);
}
@ -240,10 +253,9 @@ _test_newt_vast(void)
c3_y* haf_y;
c3_w haf_w, dub_w;
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
dub_w = 2 * len_w;
haf_w = len_w / 2;
@ -260,14 +272,14 @@ _test_newt_vast(void)
u3_newt_decode(&mot_u, buf_y, dub_w - haf_w);
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (e)\n");
exit(1);
}
u3_newt_decode(&mot_u, haf_y, haf_w);
if ( 2 != pok_w ) {
if ( 2 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (f)\n");
exit(1);
}
@ -278,10 +290,9 @@ _test_newt_vast(void)
{
c3_w dub_w;
pok_w = 0;
bal_w = 0;
mot_u.ent_u = mot_u.ext_u = 0;
buf_y = u3_newt_encode(u3k(a), &len_w);
buf_y = _newt_encode(u3k(a), &len_w);
dub_w = 2 * len_w;
@ -301,7 +312,7 @@ _test_newt_vast(void)
c3_y* end_y = c3_malloc(1);
end_y[0] = cop_y[haf_w];
if ( 1 != pok_w ) {
if ( 1 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (g) %u\n", haf_w);
exit(1);
}
@ -313,7 +324,7 @@ _test_newt_vast(void)
c3_free(cop_y);
}
if ( 2 != pok_w ) {
if ( 2 != _moat_length(&mot_u) ) {
fprintf(stderr, "newt vast fail (h)\n");
exit(1);
}

341
pkg/urbit/vere/ames.c
View File

@ -9,13 +9,40 @@
#include <netdb.h>
#include <uv.h>
#include <errno.h>
#include <ncurses/curses.h>
#include <termios.h>
#include <ncurses/term.h>
#include "all.h"
#include "vere/vere.h"
/* u3_pact: ames packet, coming or going.
*/
typedef struct _u3_pact {
uv_udp_send_t snd_u; // udp send request
c3_w pip_w; // target IPv4 address
c3_s por_s; // target port
c3_w len_w; // length in bytes
c3_y* hun_y; // packet buffer
c3_y imp_y; // galaxy number (optional)
c3_c* dns_c; // galaxy fqdn (optional)
struct _u3_ames* sam_u; // ames backpointer
} u3_pact;
/* u3_ames: ames networking.
*/
typedef struct _u3_ames { // packet network state
u3_auto car_u; // driver
union { //
uv_udp_t wax_u; //
uv_handle_t had_u; //
}; //
c3_d who_d[2]; // identity
c3_o fak_o; // fake keys
c3_s por_s; // public IPv4 port
c3_c* dns_c; // domain XX multiple/fallback
c3_w imp_w[256]; // imperial IPs
time_t imp_t[256]; // imperial IP timestamps
c3_o imp_o[256]; // imperial print status
} u3_ames;
/* _ames_alloc(): libuv buffer allocator.
*/
static void
@ -48,11 +75,9 @@ _ames_send_cb(uv_udp_send_t* req_u, c3_i sas_i)
{
u3_pact* pac_u = (u3_pact*)req_u;
#if 0
if ( 0 != sas_i ) {
u3l_log("ames: send_cb: %s\n", uv_strerror(sas_i));
u3l_log("ames: send fail: %s\n", uv_strerror(sas_i));
}
#endif
_ames_pact_free(pac_u);
}
@ -62,9 +87,7 @@ _ames_send_cb(uv_udp_send_t* req_u, c3_i sas_i)
static void
_ames_send(u3_pact* pac_u)
{
// XX revisit
u3_pier* pir_u = u3_pier_stub();
u3_ames* sam_u = pir_u->sam_u;
u3_ames* sam_u = pac_u->sam_u;
if ( !pac_u->hun_y ) {
_ames_pact_free(pac_u);
@ -108,9 +131,7 @@ _ames_czar_port(c3_y imp_y)
static void
_ames_czar_gone(u3_pact* pac_u, time_t now)
{
// XX revisit
u3_pier* pir_u = u3_pier_stub();
u3_ames* sam_u = pir_u->sam_u;
u3_ames* sam_u = pac_u->sam_u;
if ( c3y == sam_u->imp_o[pac_u->imp_y] ) {
u3l_log("ames: czar at %s: not found (b)\n", pac_u->dns_c);
@ -137,12 +158,9 @@ _ames_czar_cb(uv_getaddrinfo_t* adr_u,
c3_i sas_i,
struct addrinfo* aif_u)
{
// XX revisit
u3_pier* pir_u = u3_pier_stub();
u3_ames* sam_u = pir_u->sam_u;
u3_pact* pac_u = (u3_pact*)adr_u->data;
time_t now = time(0);
u3_ames* sam_u = pac_u->sam_u;
time_t now = time(0);
struct addrinfo* rai_u = aif_u;
@ -217,9 +235,7 @@ u3_ames_encode_lane(u3_lane lan) {
static void
_ames_czar(u3_pact* pac_u, c3_c* bos_c)
{
// XX revisit
u3_pier* pir_u = u3_pier_stub();
u3_ames* sam_u = pir_u->sam_u;
u3_ames* sam_u = pac_u->sam_u;
pac_u->por_s = _ames_czar_port(pac_u->imp_y);
@ -285,32 +301,21 @@ _ames_czar(u3_pact* pac_u, c3_c* bos_c)
}
}
/* u3_ames_ef_bake(): notify %ames that we're live.
/* _ames_ef_send(): send packet to network (v4).
*/
void
u3_ames_ef_bake(u3_pier* pir_u)
static void
_ames_ef_send(u3_ames* sam_u, u3_noun lan, u3_noun pac)
{
u3_noun pax = u3nq(u3_blip, c3__newt, u3k(u3A->sen), u3_nul);
u3_pier_plan(pax, u3nc(c3__born, u3_nul));
}
/* u3_ames_ef_send(): send packet to network (v4).
*/
void
u3_ames_ef_send(u3_pier* pir_u, u3_noun lan, u3_noun pac)
{
u3_ames* sam_u = pir_u->sam_u;
if ( c3n == sam_u->liv ) {
if ( c3n == sam_u->car_u.liv_o ) {
u3l_log("ames: not yet live, dropping outbound\r\n");
u3z(lan); u3z(pac);
return;
}
u3_pact* pac_u = c3_calloc(sizeof(*pac_u));
pac_u->len_w = u3r_met(3, pac);
pac_u->hun_y = c3_malloc(pac_u->len_w);
pac_u->sam_u = sam_u;
pac_u->len_w = u3r_met(3, pac);
pac_u->hun_y = c3_malloc(pac_u->len_w);
u3r_bytes(0, pac_u->len_w, pac_u->hun_y, pac);
@ -360,52 +365,52 @@ _ames_recv_cb(uv_udp_t* wax_u,
const struct sockaddr* adr_u,
unsigned flg_i)
{
// u3l_log("ames: rx %p\r\n", buf_u.base);
u3_ames* sam_u = wax_u->data;
if ( 0 == nrd_i ) {
c3_free(buf_u->base);
}
// check protocol version in header matches 0
// data present, and protocol version in header matches 0
//
else if ( 0 != (0x7 & *((c3_w*)buf_u->base)) ) {
c3_free(buf_u->base);
}
else {
// XX inflexible, scry version out of ames
//
if ( (0 < nrd_i)
&& (0 == (0x7 & *((c3_w*)buf_u->base))) )
{
u3_noun wir = u3nc(c3__ames, u3_nul);
u3_noun cad;
{
u3_noun msg = u3i_bytes((c3_w)nrd_i, (c3_y*)buf_u->base);
u3_noun lan;
// u3l_log("ames: plan\r\n");
#if 0
u3z(msg);
#else
u3_lane lan_u;
struct sockaddr_in* add_u = (struct sockaddr_in *)adr_u;
{
struct sockaddr_in* add_u = (struct sockaddr_in *)adr_u;
u3_lane lan_u;
lan_u.por_s = ntohs(add_u->sin_port);
lan_u.pip_w = ntohl(add_u->sin_addr.s_addr);
u3_noun lan = u3_ames_encode_lane(lan_u);
u3_noun mov = u3nt(c3__hear, u3nc(c3n, lan), msg);
lan_u.por_s = ntohs(add_u->sin_port);
lan_u.pip_w = ntohl(add_u->sin_addr.s_addr);
lan = u3_ames_encode_lane(lan_u);
}
u3_pier_plan(u3nt(u3_blip, c3__ames, u3_nul), mov);
#endif
cad = u3nt(c3__hear, u3nc(c3n, lan), msg);
}
c3_free(buf_u->base);
u3_auto_plan(&sam_u->car_u, 0, c3__a, wir, cad);
}
c3_free(buf_u->base);
}
/* _ames_io_start(): initialize ames I/O.
*/
static void
_ames_io_start(u3_pier* pir_u)
_ames_io_start(u3_ames* sam_u)
{
u3_ames* sam_u = pir_u->sam_u;
c3_s por_s = pir_u->por_s;
u3_noun who = u3i_chubs(2, pir_u->who_d);
c3_s por_s = sam_u->por_s;
u3_noun who = u3i_chubs(2, sam_u->who_d);
u3_noun rac = u3do("clan:title", u3k(who));
c3_i ret_i;
if ( c3__czar == rac ) {
c3_y num_y = (c3_y)pir_u->who_d[0];
c3_y num_y = (c3_y)sam_u->who_d[0];
c3_s zar_s = _ames_czar_port(num_y);
if ( 0 == por_s ) {
@ -417,11 +422,6 @@ _ames_io_start(u3_pier* pir_u)
}
}
if ( 0 != (ret_i = uv_udp_init(u3L, &sam_u->wax_u)) ) {
u3l_log("ames: init: %s\n", uv_strerror(ret_i));
c3_assert(0);
}
// Bind and stuff.
{
struct sockaddr_in add_u;
@ -445,7 +445,9 @@ _ames_io_start(u3_pier* pir_u)
u3l_log(" ...perhaps you've got two copies of vere running?\n");
}
u3_pier_exit(pir_u);
// XX revise
//
u3_pier_exit(u3_pier_stub());
}
uv_udp_getsockname(&sam_u->wax_u, (struct sockaddr *)&add_u, &add_i);
@ -455,15 +457,15 @@ _ames_io_start(u3_pier* pir_u)
}
if ( c3y == u3_Host.ops_u.net ) {
u3l_log("ames: live on %d\n", por_s);
u3l_log("ames: live on %d\n", sam_u->por_s);
}
else {
u3l_log("ames: live on %d (localhost only)\n", por_s);
u3l_log("ames: live on %d (localhost only)\n", sam_u->por_s);
}
uv_udp_recv_start(&sam_u->wax_u, _ames_alloc, _ames_recv_cb);
sam_u->liv = c3y;
sam_u->car_u.liv_o = c3y;
u3z(rac);
u3z(who);
}
@ -524,15 +526,14 @@ _cttp_mcut_host(c3_c* buf_c, c3_w len_w, u3_noun hot)
return len_w;
}
/* u3_ames_ef_turf(): initialize ames I/O on domain(s).
/* _ames_ef_turf(): initialize ames I/O on domain(s).
*/
void
u3_ames_ef_turf(u3_pier* pir_u, u3_noun tuf)
static void
_ames_ef_turf(u3_ames* sam_u, u3_noun tuf)
{
u3_ames* sam_u = pir_u->sam_u;
if ( u3_nul != tuf ) {
// XX save all for fallback, not just first
// XX save all for fallback, not just first
//
u3_noun hot = u3k(u3h(tuf));
c3_w len_w = _cttp_mcut_host(0, 0, u3k(hot));
@ -540,42 +541,174 @@ u3_ames_ef_turf(u3_pier* pir_u, u3_noun tuf)
_cttp_mcut_host(sam_u->dns_c, 0, hot);
sam_u->dns_c[len_w] = 0;
// XX invalidate sam_u->imp_w &c ?
//
u3z(tuf);
}
else if ( (c3n == pir_u->fak_o) && (0 == sam_u->dns_c) ) {
else if ( (c3n == sam_u->fak_o) && (0 == sam_u->dns_c) ) {
u3l_log("ames: turf: no domains\n");
}
if ( c3n == sam_u->liv ) {
_ames_io_start(pir_u);
// XX is this ever necessary?
//
if ( c3n == sam_u->car_u.liv_o ) {
_ames_io_start(sam_u);
}
}
/* _ames_io_talk(): start receiving ames traffic.
*/
static void
_ames_io_talk(u3_auto* car_u)
{
u3_ames* sam_u = (u3_ames*)car_u;
_ames_io_start(sam_u);
// send born event
//
{
u3_noun wir = u3nt(c3__newt, u3k(u3A->sen), u3_nul);
u3_noun cad = u3nc(c3__born, u3_nul);
u3_auto_plan(car_u, 0, c3__a, wir, cad);
}
}
/* _ames_kick_newt(): apply packet network outputs.
*/
static c3_o
_ames_kick_newt(u3_ames* sam_u, u3_noun tag, u3_noun dat)
{
c3_o ret_o;
switch ( tag ) {
default: {
ret_o = c3n;
} break;
case c3__send: {
u3_noun lan = u3k(u3h(dat));
u3_noun pac = u3k(u3t(dat));
_ames_ef_send(sam_u, lan, pac);
ret_o = c3y;
} break;
case c3__turf: {
_ames_ef_turf(sam_u, u3k(dat));
ret_o = c3y;
} break;
}
u3z(tag); u3z(dat);
return ret_o;
}
/* _ames_io_kick(): apply effects
*/
static c3_o
_ames_io_kick(u3_auto* car_u, u3_noun wir, u3_noun cad)
{
u3_ames* sam_u = (u3_ames*)car_u;
u3_noun tag, dat, i_wir;
c3_o ret_o;
if ( (c3n == u3r_cell(wir, &i_wir, 0))
|| (c3n == u3r_cell(cad, &tag, &dat)) )
{
ret_o = c3n;
}
else {
switch ( i_wir ) {
default: {
ret_o = c3n;
} break;
// XX should also be c3__ames
//
case c3__newt: {
ret_o = _ames_kick_newt(sam_u, u3k(tag), u3k(dat));
} break;
// XX obsolete
//
// used to also handle %west and %woot for tcp proxy setup
//
case c3__ames: {
ret_o = _( c3__init == tag);
} break;
// this can return through dill due to our fscked up boot sequence
//
// XX s/b obsolete, verify
//
case c3__term: {
if ( c3__send != tag ) {
ret_o = c3n;
}
else {
u3l_log("kick: strange send\r\n");
ret_o = _ames_kick_newt(sam_u, u3k(tag), u3k(dat));
}
} break;
}
}
u3z(wir); u3z(cad);
return ret_o;
}
/* _ames_exit_cb(): dispose resources aftr close.
*/
static void
_ames_exit_cb(uv_handle_t* had_u)
{
u3_ames* sam_u = had_u->data;
c3_free(sam_u);
}
/* _ames_io_exit(): terminate ames I/O.
*/
static void
_ames_io_exit(u3_auto* car_u)
{
u3_ames* sam_u = (u3_ames*)car_u;
uv_close(&sam_u->had_u, _ames_exit_cb);
}
/* u3_ames_io_init(): initialize ames I/O.
*/
void
u3_auto*
u3_ames_io_init(u3_pier* pir_u)
{
u3_ames* sam_u = pir_u->sam_u;
sam_u->liv = c3n;
}
u3_ames* sam_u = c3_calloc(sizeof(*sam_u));
sam_u->who_d[0] = pir_u->who_d[0];
sam_u->who_d[1] = pir_u->who_d[1];
sam_u->por_s = pir_u->por_s;
sam_u->fak_o = pir_u->fak_o;
/* u3_ames_io_talk(): start receiving ames traffic.
*/
void
u3_ames_io_talk(u3_pier* pir_u)
{
_ames_io_start(pir_u);
}
c3_assert( !uv_udp_init(u3L, &sam_u->wax_u) );
sam_u->wax_u.data = sam_u;
/* u3_ames_io_exit(): terminate ames I/O.
*/
void
u3_ames_io_exit(u3_pier* pir_u)
{
u3_ames* sam_u = pir_u->sam_u;
if ( c3y == sam_u->liv ) {
uv_close(&sam_u->had_u, 0);
// Disable networking for fake ships
//
if ( c3y == sam_u->fak_o ) {
u3_Host.ops_u.net = c3n;
}
}
u3_auto* car_u = &sam_u->car_u;
car_u->nam_m = c3__ames;
car_u->liv_o = c3n;
car_u->io.talk_f = _ames_io_talk;
car_u->io.kick_f = _ames_io_kick;
car_u->io.exit_f = _ames_io_exit;
// XX track and print every N?
//
// car_u->ev.bail_f = ...;
return car_u;
}

365
pkg/urbit/vere/auto.c Normal file
View File

@ -0,0 +1,365 @@
/* vere/auto.c
*/
#include <stdio.h>
#include <stdlib.h>
#include <fcntl.h>
#include <sys/ioctl.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <unistd.h>
#include <setjmp.h>
#include <gmp.h>
#include <sigsegv.h>
#include <stdint.h>
#include <sys/socket.h>
#include <netinet/in.h>
#include <uv.h>
#include <errno.h>
#include "all.h"
#include "vere/vere.h"
/* u3_auto_plan(): create and enqueue an ovum.
*/
u3_ovum*
u3_auto_plan(u3_auto* car_u,
c3_l msc_l,
u3_noun tar,
u3_noun wir,
u3_noun cad)
{
u3_ovum* egg_u = c3_malloc(sizeof(*egg_u));
egg_u->car_u = car_u;
egg_u->vod_p = 0;
egg_u->msc_l = msc_l;
egg_u->tar = tar;
egg_u->wir = wir;
egg_u->cad = cad;
// spinner defaults
//
egg_u->pin_u.lab = u3k(u3h(wir));
egg_u->pin_u.del_o = c3y;
egg_u->cb_u.news_f = 0;
egg_u->cb_u.bail_f = 0;
if ( !car_u->ent_u ) {
c3_assert(!car_u->ext_u);
egg_u->pre_u = egg_u->nex_u = 0;
car_u->ent_u = car_u->ext_u = egg_u;
}
else {
egg_u->nex_u = 0;
egg_u->pre_u = car_u->ent_u;
car_u->ent_u->nex_u = egg_u;
car_u->ent_u = egg_u;
}
u3_pier_spin(car_u->pir_u);
return egg_u;
}
/* u3_auto_peer(): subscribe to updates.
*/
void
u3_auto_peer(u3_ovum* egg_u,
u3_ovum_peer news_f,
u3_ovum_bail bail_f)
{
egg_u->cb_u.news_f = news_f;
egg_u->cb_u.bail_f = bail_f;
}
/* u3_auto_bail_slog(): print a bail notification.
*/
void
u3_auto_bail_slog(u3_ovum* egg_u, u3_noun lud)
{
c3_c* car_c = u3r_string(egg_u->car_u->nam_m);
u3_noun dul = lud;
c3_w len_w = 1;
while ( u3_nul != dul ) {
u3l_log("%s: bail %u\r\n", car_c, len_w++);
u3_pier_punt_goof(car_c, u3k(u3h(dul)));
dul = u3t(dul);
}
u3_pier_punt_ovum(car_c, u3k(egg_u->wir), u3k(u3h(egg_u->cad)));
u3z(lud);
c3_free(car_c);
}
/* u3_auto_bail(): notify driver that [egg_u] crashed.
*/
void
u3_auto_bail(u3_ovum* egg_u, u3_noun lud)
{
// optional
//
if ( egg_u->cb_u.bail_f ) {
c3_l cod_l = u3a_lush(egg_u->car_u->nam_m);
egg_u->cb_u.bail_f(egg_u, lud);
u3a_lop(cod_l);
}
else {
u3_auto_bail_slog(egg_u, lud);
}
// XX confirm
//
u3_auto_drop(0, egg_u);
}
/* _auto_news(): notify driver of ovum status
*/
static void
_auto_news(u3_ovum* egg_u, u3_ovum_news new_e)
{
// optional
//
if ( egg_u->cb_u.news_f ) {
c3_l cod_l = u3a_lush(egg_u->car_u->nam_m);
egg_u->cb_u.news_f(egg_u, new_e);
u3a_lop(cod_l);
}
}
/* u3_auto_done(): notify driver of [egg_u] completion.
*/
void
u3_auto_done(u3_ovum* egg_u)
{
_auto_news(egg_u, u3_ovum_done);
// XX confirm
//
u3_auto_drop(0, egg_u);
//
}
/* u3_auto_work(): notify driver of [egg_u] commencement.
*/
void
u3_auto_work(u3_ovum* egg_u)
{
_auto_news(egg_u, u3_ovum_work);
}
/* u3_auto_drop(): dequeue and dispose an ovum.
*/
void
u3_auto_drop(u3_auto* car_u, u3_ovum* egg_u)
{
if ( egg_u->pre_u ) {
egg_u->pre_u->nex_u = egg_u->nex_u;
}
if ( egg_u->nex_u ) {
egg_u->nex_u->pre_u = egg_u->pre_u;
}
// notify driver if not self-caused
//
if ( egg_u->car_u && ( car_u != egg_u->car_u ) ) {
_auto_news(egg_u, u3_ovum_drop);
}
u3z(egg_u->pin_u.lab);
u3z(egg_u->tar);
u3z(egg_u->wir);
u3z(egg_u->cad);
c3_free(egg_u);
}
/* u3_auto_next(): select an ovum, dequeue and construct.
*/
u3_ovum*
u3_auto_next(u3_auto* car_u, u3_noun* ovo)
{
while ( car_u ) {
if ( !car_u->ext_u ) {
car_u = car_u->nex_u;
continue;
}
else {
u3_ovum* egg_u = car_u->ext_u;
c3_assert( !egg_u->pre_u );
if ( egg_u->nex_u ) {
egg_u->nex_u->pre_u = 0;
car_u->ext_u = egg_u->nex_u;
}
else {
car_u->ent_u = car_u->ext_u = 0;
}
egg_u->nex_u = 0;
u3_auto_work(egg_u);
// XX cons [tar] route onto wire
//
// *ovo = u3nt(u3nc(u3k(egg_u->tar), u3k(egg_u->wir)),
// u3k(egg_u->cad));
*ovo = u3nc(u3nc(u3_blip, u3k(egg_u->wir)),
u3k(egg_u->cad));
return egg_u;
}
}
return 0;
}
/* _auto_kick_lost(): print details of unroutable effect. RETAIN
*/
static void
_auto_kick_lost(u3_noun pax, u3_noun fav)
{
u3_noun tox = u3do("spat", u3k(pax));
c3_c* tag_c = u3r_string(u3h(fav));
c3_c* pax_c = u3r_string(tox);
u3l_log("kick: lost %%%s on %s\n", tag_c, pax_c);
c3_free(pax_c);
c3_free(tag_c);
u3z(tox);
}
/* _auto_kick(): kick with leak label.
*/
static c3_o
_auto_kick(u3_auto* car_u, u3_noun pax, u3_noun fav)
{
c3_l cod_l = u3a_lush(car_u->nam_m);
c3_o kik_o = car_u->io.kick_f(car_u, pax, fav);
u3a_lop(cod_l);
return kik_o;
}
/* u3_auto_kick(): route effects to a linked driver. RETAIN
*/
void
u3_auto_kick(u3_auto* car_u, u3_noun act)
{
u3_auto* rac_u = car_u;
u3_noun fec, pax, wir, cad;
while ( u3_nul != act ) {
fec = u3h(act);
u3x_cell(fec, &pax, &cad);
u3_assent(u3r_p(pax, u3_blip, &wir));
while ( c3n == _auto_kick(car_u, u3k(wir), u3k(cad)) ) {
if ( car_u->nex_u ) {
car_u = car_u->nex_u;
continue;
}
else {
_auto_kick_lost(wir, cad);
break;
}
}
car_u = rac_u;
act = u3t(act);
}
}
/* u3_auto_live(): check if all drivers are live.
*/
c3_o
u3_auto_live(u3_auto* car_u)
{
while ( car_u ) {
if ( c3n == car_u->liv_o ) {
return c3n;
}
car_u = car_u->nex_u;
}
return c3y;
}
/* u3_auto_talk(): start all drivers.
*/
void
u3_auto_talk(u3_auto* car_u)
{
c3_l cod_l;
while ( car_u ) {
cod_l = u3a_lush(car_u->nam_m);
car_u->io.talk_f(car_u);
u3a_lop(cod_l);
car_u = car_u->nex_u;
}
}
/* u3_auto_exit(): close all drivers.
*/
void
u3_auto_exit(u3_auto* car_u)
{
u3_auto* nex_u;
c3_l cod_l;
while ( car_u ) {
nex_u = car_u->nex_u;
// while ( car_u->ext_u ) {
// u3_auto_drop(car_u, car_u->ext_u);
// }
cod_l = u3a_lush(car_u->nam_m);
car_u->io.exit_f(car_u);
u3a_lop(cod_l);
car_u = nex_u;
}
}
/* _auto_link(): validate and link initalized [car_u]
*/
static u3_auto*
_auto_link(u3_auto* car_u, u3_pier* pir_u, u3_auto* nex_u)
{
// assert that io callbacks are present
//
c3_assert( car_u->io.talk_f );
c3_assert( car_u->io.kick_f );
c3_assert( car_u->io.exit_f );
car_u->pir_u = pir_u;
car_u->nex_u = nex_u;
return car_u;
}
/* u3_auto_init(): initialize all drivers.
*/
u3_auto*
u3_auto_init(u3_pier* pir_u)
{
u3_auto* car_u = 0;
car_u = _auto_link(u3_hind_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_ames_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_http_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_cttp_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_behn_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_unix_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_term_io_init(pir_u), pir_u, car_u);
car_u = _auto_link(u3_fore_io_init(pir_u), pir_u, car_u);
return car_u;
}

130
pkg/urbit/vere/behn.c
View File

@ -6,42 +6,25 @@
#include <sys/stat.h>
#include <dirent.h>
#include <uv.h>
#include <ncurses/curses.h>
#include <termios.h>
#include <ncurses/term.h>
#include <errno.h>
#include "all.h"
#include "vere/vere.h"
/* u3_behn(): initialize time timer.
/* u3_behn: just a timer for ever
*/
void
u3_behn_io_init(u3_pier *pir_u)
{
u3_behn* teh_u = pir_u->teh_u;
teh_u->alm = c3n;
uv_timer_init(u3L, &teh_u->tim_u);
teh_u->tim_u.data = pir_u;
}
/* u3_behn_io_exit(): terminate timer.
*/
void
u3_behn_io_exit(u3_pier *pir_u)
{
u3_behn* teh_u = pir_u->teh_u;
uv_close((uv_handle_t*)&teh_u->tim_u, 0);
}
typedef struct _u3_behn {
u3_auto car_u; // driver
uv_timer_t tim_u; // behn timer
c3_o alm; // alarm
} u3_behn;
/* _behn_time_cb(): timer callback.
*/
static void
_behn_time_cb(uv_timer_t* tim_u)
{
u3_pier *pir_u = tim_u->data;
u3_behn* teh_u = pir_u->teh_u;
u3_behn* teh_u = tim_u->data;
teh_u->alm = c3n;
// start another timer for 10 minutes
@ -60,19 +43,21 @@ _behn_time_cb(uv_timer_t* tim_u)
// send timer event
//
{
u3_pier_work
(pir_u,
u3nt(u3_blip, c3__behn, u3_nul),
u3nc(c3__wake, u3_nul));
u3_noun wir = u3nc(c3__behn, u3_nul);
u3_noun cad = u3nc(c3__wake, u3_nul);
u3_auto_plan(&teh_u->car_u, 0, c3__b, wir, cad);
}
}
/* u3_behn_ef_doze(): set or cancel timer
*/
void
u3_behn_ef_doze(u3_pier *pir_u, u3_noun wen)
static void
_behn_ef_doze(u3_behn* teh_u, u3_noun wen)
{
u3_behn* teh_u = pir_u->teh_u;
if ( c3n == teh_u->car_u.liv_o ) {
teh_u->car_u.liv_o = c3y;
}
if ( c3y == teh_u->alm ) {
uv_timer_stop(&teh_u->tim_u);
@ -96,12 +81,85 @@ u3_behn_ef_doze(u3_pier *pir_u, u3_noun wen)
u3z(wen);
}
/* u3_behn_ef_bake(): notify %behn that we're live
/* _behn_io_talk(): notify %behn that we're live
*/
void
u3_behn_ef_bake(u3_pier *pir_u)
static void
_behn_io_talk(u3_auto* car_u)
{
u3_noun pax = u3nq(u3_blip, c3__behn, u3k(u3A->sen), u3_nul);
// XX remove u3A->sen
//
u3_noun wir = u3nt(c3__behn, u3k(u3A->sen), u3_nul);
u3_noun cad = u3nc(c3__born, u3_nul);
u3_pier_work(pir_u, pax, u3nc(c3__born, u3_nul));
u3_auto_plan(car_u, 0, c3__b, wir, cad);
}
/* _behn_io_kick(): apply effects.
*/
static c3_o
_behn_io_kick(u3_auto* car_u, u3_noun wir, u3_noun cad)
{
u3_behn* teh_u = (u3_behn*)car_u;
u3_noun tag, dat, i_wir;
c3_o ret_o;
if ( (c3n == u3r_cell(wir, &i_wir, 0))
|| (c3n == u3r_cell(cad, &tag, &dat))
|| (c3__behn != i_wir) )
{
ret_o = c3n;
}
else {
ret_o = c3y;
_behn_ef_doze(teh_u, u3k(dat));
}
u3z(wir); u3z(cad);
return ret_o;
}
/* _behn_exit_cb();
*/
static void
_behn_exit_cb(uv_timer_t* tim_u)
{
u3_behn* teh_u = tim_u->data;
c3_free(teh_u);
}
/* _behn_io_exit(): terminate timer.
*/
static void
_behn_io_exit(u3_auto* car_u)
{
u3_behn* teh_u = (u3_behn*)car_u;
uv_close((uv_handle_t*)&teh_u->tim_u, (uv_close_cb)_behn_exit_cb);
}
/* u3_behn(): initialize time timer.
*/
u3_auto*
u3_behn_io_init(u3_pier* pir_u)
{
u3_behn* teh_u = c3_calloc(sizeof(*teh_u));
teh_u->alm = c3n;
uv_timer_init(u3L, &teh_u->tim_u);
teh_u->tim_u.data = teh_u;
u3_auto* car_u = &teh_u->car_u;
car_u->nam_m = c3__behn;
// XX set in done_cb for %born
//
car_u->liv_o = c3y;
car_u->io.talk_f = _behn_io_talk;
car_u->io.kick_f = _behn_io_kick;
car_u->io.exit_f = _behn_io_exit;
// XX retry up to N?
//
// car_u->ev.bail_f = ...;
return car_u;
}

255
pkg/urbit/vere/cttp.c
View File

@ -14,6 +14,59 @@
#include "all.h"
#include "vere/vere.h"
/* u3_csat: client connection state.
*/
typedef enum {
u3_csat_init = 0, // initialized
u3_csat_addr = 1, // address resolution begun
u3_csat_quit = 2, // cancellation requested
u3_csat_ripe = 3 // passed to libh2o
} u3_csat;
/* u3_cres: response to http client.
*/
typedef struct _u3_cres {
c3_w sas_w; // status code
u3_noun hed; // headers
u3_hbod* bod_u; // exit of body queue
u3_hbod* dob_u; // entry of body queue
} u3_cres;
/* u3_creq: outgoing http request.
*/
typedef struct _u3_creq { // client request
c3_l num_l; // request number
h2o_http1client_t* cli_u; // h2o client
u3_csat sat_e; // connection state
c3_o sec; // yes == https
c3_w ipf_w; // IP
c3_c* ipf_c; // IP (string)
c3_c* hot_c; // host
c3_s por_s; // port
c3_c* por_c; // port (string)
c3_c* met_c; // method
c3_c* url_c; // url
u3_hhed* hed_u; // headers
u3_hbod* bod_u; // body
u3_hbod* rub_u; // exit of send queue
u3_hbod* bur_u; // entry of send queue
h2o_iovec_t* vec_u; // send-buffer array
u3_cres* res_u; // nascent response
struct _u3_creq* nex_u; // next in list
struct _u3_creq* pre_u; // previous in list
struct _u3_cttp* ctp_u; // cttp backpointer
} u3_creq;
/* u3_cttp: http client.
*/
typedef struct _u3_cttp {
u3_auto car_u; // driver
u3_creq* ceq_u; // request list
h2o_timeout_t tim_u; // request timeout
h2o_http1client_ctx_t //
ctx_u; // h2o client ctx
void* tls_u; // client SSL_CTX*
} u3_cttp;
// XX deduplicate with _http_vec_to_atom
/* _cttp_vec_to_atom(): convert h2o_iovec_t to atom (cord)
@ -466,9 +519,9 @@ _cttp_creq_ip(c3_w ipf_w)
/* _cttp_creq_find(): find a request by number in the client
*/
static u3_creq*
_cttp_creq_find(c3_l num_l)
_cttp_creq_find(u3_cttp* ctp_u, c3_l num_l)
{
u3_creq* ceq_u = u3_Host.ctp_u.ceq_u;
u3_creq* ceq_u = ctp_u->ceq_u;
// XX glories of linear search
//
@ -484,14 +537,16 @@ _cttp_creq_find(c3_l num_l)
/* _cttp_creq_link(): link request to client
*/
static void
_cttp_creq_link(u3_creq* ceq_u)
_cttp_creq_link(u3_cttp* ctp_u, u3_creq* ceq_u)
{
ceq_u->nex_u = u3_Host.ctp_u.ceq_u;
ceq_u->nex_u = ctp_u->ceq_u;
if ( 0 != ceq_u->nex_u ) {
ceq_u->nex_u->pre_u = ceq_u;
}
u3_Host.ctp_u.ceq_u = ceq_u;
ceq_u->ctp_u = ctp_u;
ctp_u->ceq_u = ceq_u;
}
/* _cttp_creq_unlink(): unlink request from client
@ -499,6 +554,8 @@ _cttp_creq_link(u3_creq* ceq_u)
static void
_cttp_creq_unlink(u3_creq* ceq_u)
{
u3_cttp* ctp_u = ceq_u->ctp_u;
if ( ceq_u->pre_u ) {
ceq_u->pre_u->nex_u = ceq_u->nex_u;
@ -507,7 +564,7 @@ _cttp_creq_unlink(u3_creq* ceq_u)
}
}
else {
u3_Host.ctp_u.ceq_u = ceq_u->nex_u;
ctp_u->ceq_u = ceq_u->nex_u;
if ( 0 != ceq_u->nex_u ) {
ceq_u->nex_u->pre_u = 0;
@ -531,6 +588,7 @@ _cttp_creq_free(u3_creq* ceq_u)
}
c3_free(ceq_u->hot_c);
c3_free(ceq_u->ipf_c);
c3_free(ceq_u->por_c);
c3_free(ceq_u->met_c);
c3_free(ceq_u->url_c);
@ -545,7 +603,7 @@ _cttp_creq_free(u3_creq* ceq_u)
* We start with the (?? - JB)
*/
static u3_creq*
_cttp_creq_new(c3_l num_l, u3_noun hes)
_cttp_creq_new(u3_cttp* ctp_u, c3_l num_l, u3_noun hes)
{
u3_creq* ceq_u = c3_calloc(sizeof(*ceq_u));
@ -597,7 +655,7 @@ _cttp_creq_new(c3_l num_l, u3_noun hes)
ceq_u->bod_u = _cttp_bod_from_octs(u3k(u3t(body)));
}
_cttp_creq_link(ceq_u);
_cttp_creq_link(ctp_u, ceq_u);
u3z(unit_pul);
u3z(hes);
@ -627,6 +685,7 @@ static void
_cttp_creq_fire_str(u3_creq* ceq_u, c3_c* str_c)
{
_cttp_creq_fire_body(ceq_u, _cttp_bod_new(strlen(str_c), str_c));
c3_free(str_c);
}
/* _cttp_creq_fire_heds(): attach output headers.
@ -708,19 +767,16 @@ _cttp_creq_quit(u3_creq* ceq_u)
}
static void
_cttp_http_client_receive(c3_l num_l, c3_w sas_w, u3_noun mes, u3_noun uct)
_cttp_http_client_receive(u3_creq* ceq_u, c3_w sas_w, u3_noun mes, u3_noun uct)
{
// TODO: We want to eventually deal with partial responses, but I don't know
// how to get that working right now.
u3_noun pox = u3nq(u3_blip, u3i_string("http-client"), u3k(u3A->sen), u3_nul);
// XX inject partial responses as separate events
//
u3_noun wir = u3nt(u3i_string("http-client"), u3k(u3A->sen), u3_nul);
u3_noun cad = u3nt(u3i_string("receive"),
ceq_u->num_l,
u3nq(u3i_string("start"), u3nc(sas_w, mes), uct, c3y));
u3_pier_plan(pox,
u3nt(u3i_string("receive"),
num_l,
u3nq(u3i_string("start"),
u3nc(sas_w, mes),
uct,
c3y)));
u3_auto_plan(&ceq_u->ctp_u->car_u, 0, c3__i, wir, cad);
}
/* _cttp_creq_fail(): dispatch error response
@ -734,7 +790,7 @@ _cttp_creq_fail(u3_creq* ceq_u, const c3_c* err_c)
u3l_log("http: fail (%d, %d): %s\r\n", ceq_u->num_l, cod_w, err_c);
// XX include err_c as response body?
_cttp_http_client_receive(ceq_u->num_l, cod_w, u3_nul, u3_nul);
_cttp_http_client_receive(ceq_u, cod_w, u3_nul, u3_nul);
_cttp_creq_free(ceq_u);
}
@ -745,7 +801,7 @@ _cttp_creq_respond(u3_creq* ceq_u)
{
u3_cres* res_u = ceq_u->res_u;
_cttp_http_client_receive(ceq_u->num_l, res_u->sas_w, res_u->hed,
_cttp_http_client_receive(ceq_u, res_u->sas_w, res_u->hed,
( !res_u->bod_u ) ? u3_nul :
u3nc(u3_nul, _cttp_bods_to_octs(res_u->bod_u)));
@ -844,7 +900,7 @@ _cttp_creq_connect(u3_creq* ceq_u)
( c3y == ceq_u->sec ) ? 443 : 80;
// connect by IP
h2o_http1client_connect(&ceq_u->cli_u, ceq_u, &u3_Host.ctp_u.ctx_u, ipf_u,
h2o_http1client_connect(&ceq_u->cli_u, ceq_u, &ceq_u->ctp_u->ctx_u, ipf_u,
por_s, c3y == ceq_u->sec, _cttp_creq_on_connect);
// set hostname for TLS handshake
@ -935,7 +991,7 @@ _cttp_creq_start(u3_creq* ceq_u)
/* _cttp_init_tls: initialize OpenSSL context
*/
static SSL_CTX*
_cttp_init_tls()
_cttp_init_tls(void)
{
// XX require 1.1.0 and use TLS_client_method()
SSL_CTX* tls_u = SSL_CTX_new(SSLv23_client_method());
@ -956,86 +1012,107 @@ _cttp_init_tls()
return tls_u;
}
/* u3_cttp_ef_http_client(): send an %http-client (outgoing request) to cttp.
/* _cttp_ef_http_client(): send an %http-client (outgoing request) to cttp.
*/
void
u3_cttp_ef_http_client(u3_noun fav)
static c3_o
_cttp_ef_http_client(u3_cttp* ctp_u, u3_noun tag, u3_noun dat)
{
u3_creq* ceq_u;
c3_o ret_o;
if ( c3y == u3r_sing_c("request", u3h(fav)) ) {
u3_noun p_fav, q_fav;
u3x_cell(u3t(fav), &p_fav, &q_fav);
if ( c3y == u3r_sing_c("request", tag) ) {
u3_noun num, req;
c3_l num_l;
ceq_u = _cttp_creq_new(u3r_word(0, p_fav), u3k(q_fav));
if ( ceq_u ) {
if ( (c3n == u3r_cell(dat, &num, &req))
|| (c3n == u3r_safe_word(num, &num_l)) )
{
u3l_log("cttp: strange request\n");
ret_o = c3n;
}
else if ( (ceq_u = _cttp_creq_new(ctp_u, num_l, u3k(req))) ) {
_cttp_creq_start(ceq_u);
ret_o = c3y;
}
else {
u3l_log("cttp: strange request (unparsable url)\n");
ret_o = c3n;
}
}
else if ( c3y == u3r_sing_c("cancel-request", u3h(fav)) ) {
ceq_u =_cttp_creq_find(u3r_word(0, u3t(fav)));
else if ( c3y == u3r_sing_c("cancel-request", tag) ) {
c3_l num_l;
if ( ceq_u ) {
if ( c3n == u3r_safe_word(dat, &num_l) ) {
u3l_log("cttp: strange cancel-request\n");
ret_o = c3n;
}
else if ( (ceq_u =_cttp_creq_find(ctp_u, num_l)) ) {
_cttp_creq_quit(ceq_u);
ret_o = c3y;
}
else {
// accepted whether or not request exists
//
ret_o = c3y;
}
}
else {
u3l_log("cttp: strange request (unknown type)\n");
u3l_log("cttp: strange effect (unknown type)\n");
ret_o = c3n;
}
u3z(fav);
u3z(tag); u3z(dat);
return ret_o;
}
/* u3_cttp_ef_bake(): notify that we're live.
/* _cttp_io_talk(): notify that we're live.
*/
void
u3_cttp_ef_bake()
static void
_cttp_io_talk(u3_auto* car_u)
{
u3_noun pax = u3nq(u3_blip, u3i_string("http-client"), u3k(u3A->sen), u3_nul);
u3_pier_plan(pax, u3nc(c3__born, u3_nul));
// XX remove u3A->sen
//
u3_noun wir = u3nt(u3i_string("http-client"), u3k(u3A->sen), u3_nul);
u3_noun cad = u3nc(c3__born, u3_nul);
u3_auto_plan(car_u, 0, c3__i, wir, cad);
}
/* u3_cttp_io_init(): initialize http client I/O.
/* _cttp_io_kick(): apply effects
*/
void
u3_cttp_io_init()
static c3_o
_cttp_io_kick(u3_auto* car_u, u3_noun wir, u3_noun cad)
{
// zero-initialize h2o ctx
//
memset(&u3_Host.ctp_u.ctx_u, 0, sizeof(u3_Host.ctp_u.ctx_u));
u3_cttp* ctp_u = (u3_cttp*)car_u;
// link to event loop
//
u3_Host.ctp_u.ctx_u.loop = u3L;
u3_noun tag, dat, i_wir;
c3_o ret_o;
// link to initialized request timeout
//
h2o_timeout_init(u3L, &u3_Host.ctp_u.tim_u, 300 * 1000);
u3_Host.ctp_u.ctx_u.io_timeout = &u3_Host.ctp_u.tim_u;
if ( (c3n == u3r_cell(wir, &i_wir, 0))
|| (c3n == u3r_cell(cad, &tag, &dat))
|| (c3n == u3r_sing_c("http-client", i_wir)) )
{
ret_o = c3n;
}
else {
ret_o = _cttp_ef_http_client(ctp_u, u3k(tag), u3k(dat));
}
// link to initialized tls ctx
//
u3_Host.ctp_u.tls_u = _cttp_init_tls();
u3_Host.ctp_u.ctx_u.ssl_ctx = u3_Host.ctp_u.tls_u;
// zero-initialize request list
//
u3_Host.ctp_u.ceq_u = 0;
u3z(wir); u3z(cad);
return ret_o;
}
/* u3_cttp_io_exit(): shut down cttp.
/* _cttp_io_exit(): shut down cttp.
*/
void
u3_cttp_io_exit(void)
static void
_cttp_io_exit(u3_auto* car_u)
{
u3_cttp* ctp_u = (u3_cttp*)car_u;
// cancel requests
//
{
u3_creq* ceq_u = u3_Host.ctp_u.ceq_u;
u3_creq* ceq_u = ctp_u->ceq_u;
while ( ceq_u ) {
_cttp_creq_quit(ceq_u);
@ -1043,8 +1120,44 @@ u3_cttp_io_exit(void)
}
}
// dispose of global resources
//
h2o_timeout_dispose(u3L, &u3_Host.ctp_u.tim_u);
SSL_CTX_free(u3_Host.ctp_u.tls_u);
h2o_timeout_dispose(u3L, &ctp_u->tim_u);
SSL_CTX_free(ctp_u->tls_u);
c3_free(ctp_u);
}
/* u3_cttp_io_init(): initialize http client I/O.
*/
u3_auto*
u3_cttp_io_init(u3_pier* pir_u)
{
u3_cttp* ctp_u = c3_calloc(sizeof(*ctp_u));
// link to event loop
//
ctp_u->ctx_u.loop = u3L;
// link to initialized request timeout
//
h2o_timeout_init(u3L, &ctp_u->tim_u, 300 * 1000);
ctp_u->ctx_u.io_timeout = &ctp_u->tim_u;
// link to initialized tls ctx
//
ctp_u->tls_u = _cttp_init_tls();
ctp_u->ctx_u.ssl_ctx = ctp_u->tls_u;
u3_auto* car_u = &ctp_u->car_u;
car_u->nam_m = c3__cttp;
// XX set in done_cb for %born
//
car_u->liv_o = c3y;
car_u->io.talk_f = _cttp_io_talk;
car_u->io.kick_f = _cttp_io_kick;
car_u->io.exit_f = _cttp_io_exit;
// XX retry up to N?
//
// car_u->ev.bail_f = ...;
return car_u;
}

34
pkg/urbit/vere/daemon.c
View File

@ -243,10 +243,6 @@ _daemon_susp(u3_atom ship, u3_noun susp)
void
_daemon_vent(u3_atom ship, u3_noun vent)
{
/* stub; have to find pier from ship */
u3z(ship);
u3_pier_work(u3_pier_stub(), u3h(vent), u3t(vent));
u3z(vent);
}
/* _daemon_doom(): doom parser
@ -388,21 +384,23 @@ _daemon_root(u3_noun root)
/* _daemon_bail(): bail for command socket newt
*/
void
_daemon_bail(u3_moor *vod_p, const c3_c *err_c)
_daemon_bail(void* vod_p, const c3_c *err_c)
{
u3_moor *free_p;
u3_moor* mor_p = vod_p;
u3_moor* fre_p;
u3l_log("_daemon_bail: %s\r\n", err_c);
if ( vod_p == 0 ) {
free_p = u3K.cli_u;
if ( !mor_p ) {
fre_p = u3K.cli_u;
u3K.cli_u = u3K.cli_u->nex_u;
c3_free(free_p);
}
else {
free_p = vod_p->nex_u;
vod_p->nex_u = vod_p->nex_u->nex_u;
c3_free(free_p);
fre_p = mor_p->nex_u;
mor_p->nex_u = fre_p->nex_u;
}
c3_free(fre_p);
}
/* _daemon_socket_connect(): callback for new connections
@ -415,21 +413,22 @@ _daemon_socket_connect(uv_stream_t *sock, int status)
if ( u3K.cli_u == 0 ) {
u3K.cli_u = c3_malloc(sizeof(u3_moor));
mor_u = u3K.cli_u;
mor_u->vod_p = 0;
mor_u->ptr_v = 0;
mor_u->nex_u = 0;
}
else {
for (mor_u = u3K.cli_u; mor_u->nex_u; mor_u = mor_u->nex_u);
mor_u->nex_u = c3_malloc(sizeof(u3_moor));
mor_u->nex_u->vod_p = mor_u;
mor_u->nex_u->ptr_v = mor_u;
mor_u = mor_u->nex_u;
mor_u->nex_u = 0;
}
uv_timer_init(u3L, &mor_u->tim_u);
uv_pipe_init(u3L, &mor_u->pyp_u, 0);
mor_u->pok_f = _daemon_fate;
mor_u->bal_f = (u3_bail)_daemon_bail;
mor_u->bal_f = _daemon_bail;
uv_accept(sock, (uv_stream_t *)&mor_u->pyp_u);
u3_newt_read((u3_moat *)mor_u);
@ -850,7 +849,7 @@ _boothack_cb(uv_connect_t* con_u, c3_i sas_i)
else {
u3_noun dom = u3nc(c3__doom, _boothack_doom());
u3_atom mat = u3ke_jam(dom);
u3_newt_write(moj_u, mat, 0);
u3_newt_write(moj_u, mat);
c3_free(con_u);
@ -875,9 +874,12 @@ _daemon_loop_init()
u3_moor* mor_u = c3_malloc(sizeof(u3_moor));
uv_connect_t* con_u = c3_malloc(sizeof(uv_connect_t));
con_u->data = mor_u;
uv_timer_init(u3L, &mor_u->tim_u);
uv_pipe_init(u3L, &mor_u->pyp_u, 0);
uv_pipe_connect(con_u, &mor_u->pyp_u, u3K.soc_c, _boothack_cb);
}
u3_term_log_init();
}
/* _daemon_loop_exit(): cleanup after event loop

464
pkg/urbit/vere/db/lmdb.c Normal file
View File

@ -0,0 +1,464 @@
/* vere/db/lmdb.c
*/
#include <lmdb.h>
#include "c/portable.h"
#include "c/types.h"
#include "c/defs.h"
#include <vere/db/lmdb.h>
// lmdb api wrapper
//
// this module implements a simple persistence api on top of lmdb.
// outside of its use of c3 type definitions, this module has no
// dependence on anything u3, or on any library besides lmdb itself.
//
// urbit requires very little from a persist store -- it merely
// needs to store variable-length buffers in:
//
// - a metadata store with c3_c (unsigned char) keys
// - an event store with contiguous c3_d (uint64_t) keys
//
// supported operations are as follows
//
// - open/close an environment
// - read/save metadata
// - read the first and last event numbers
// - read/save ranges of events
//
/* c3_lmdb_init(): open lmdb at [pax_c], mmap up to [siz_i].
*/
MDB_env*
c3_lmdb_init(const c3_c* pax_c, size_t siz_i)
{
MDB_env* env_u;
c3_w ret_w;
if ( (ret_w = mdb_env_create(&env_u)) ) {
fprintf(stderr, "lmdb: init fail: %s\n", mdb_strerror(ret_w));
return 0;
}
// Our databases have two tables: META and EVENTS
//
if ( (ret_w = mdb_env_set_maxdbs(env_u, 2)) ) {
fprintf(stderr, "lmdb: failed to set number of databases: %s\r\n",
mdb_strerror(ret_w));
// XX dispose env_u
//
return 0;
}
if ( (ret_w = mdb_env_set_mapsize(env_u, siz_i)) ) {
fprintf(stderr, "lmdb: failed to set database size: %s\r\n",
mdb_strerror(ret_w));
// XX dispose env_u
//
return 0;
}
if ( (ret_w = mdb_env_open(env_u, pax_c, 0, 0664)) ) {
fprintf(stderr, "lmdb: failed to open event log: %s\n",
mdb_strerror(ret_w));
// XX dispose env_u
//
return 0;
}
return env_u;
}
/* c3_lmdb_exit(): close lmdb.
*/
void
c3_lmdb_exit(MDB_env* env_u)
{
mdb_env_close(env_u);
}
/* c3_lmdb_gulf(): read first and last event numbers.
*/
c3_o
c3_lmdb_gulf(MDB_env* env_u, c3_d* low_d, c3_d* hig_d)
{
MDB_txn* txn_u;
MDB_dbi mdb_u;
c3_w ret_w;
// create a read-only transaction.
//
// XX why no MDB_RDONLY?
//
if ( (ret_w = mdb_txn_begin(env_u, 0, 0, &txn_u)) ) {
fprintf(stderr, "lmdb: gulf: txn_begin fail: %s\n", mdb_strerror(ret_w));
return c3n;
}
// open the database in the transaction
//
{
c3_w ops_w = MDB_CREATE | MDB_INTEGERKEY;
if ( (ret_w = mdb_dbi_open(txn_u, "EVENTS", ops_w, &mdb_u)) ) {
fprintf(stderr, "lmdb: gulf: dbi_open fail: %s\n", mdb_strerror(ret_w));
// XX confirm
//
mdb_txn_abort(txn_u);
return c3n;
}
}
{
MDB_cursor* cur_u;
MDB_val key_u;
MDB_val val_u;
c3_d fir_d, las_d;
// creates a cursor to point to the last event
//
if ( (ret_w = mdb_cursor_open(txn_u, mdb_u, &cur_u)) ) {
fprintf(stderr, "lmdb: gulf: cursor_open fail: %s\n",
mdb_strerror(ret_w));
// XX confirm
//
mdb_txn_abort(txn_u);
return c3n;
}
// read with the cursor from the start of the database
//
ret_w = mdb_cursor_get(cur_u, &key_u, &val_u, MDB_FIRST);
if ( MDB_NOTFOUND == ret_w ) {
*low_d = 0;
*hig_d = 0;
mdb_cursor_close(cur_u);
mdb_txn_abort(txn_u);
return c3y;
}
else if ( ret_w ) {
fprintf(stderr, "lmdb: gulf: head fail: %s\n",
mdb_strerror(ret_w));
mdb_cursor_close(cur_u);
mdb_txn_abort(txn_u);
return c3n;
}
else {
fir_d = *(c3_d*)key_u.mv_data;
}
// read with the cursor from the end of the database
//
ret_w = mdb_cursor_get(cur_u, &key_u, &val_u, MDB_LAST);
if ( !ret_w ) {
las_d = *(c3_d*)key_u.mv_data;
}
// clean up unconditionally, we're done
//
mdb_cursor_close(cur_u);
mdb_txn_abort(txn_u);
if ( ret_w ) {
fprintf(stderr, "lmdb: gulf: last fail: %s\r\n", mdb_strerror(ret_w));
return c3n;
}
else {
*low_d = fir_d;
*hig_d = las_d;
return c3y;
}
}
}
/* c3_lmdb_read(): read [len_d] events starting at [eve_d].
*/
c3_o
c3_lmdb_read(MDB_env* env_u,
void* vod_p,
c3_d eve_d,
c3_d len_d,
c3_o (*read_f)(void*, c3_d, size_t, void*))
{
MDB_txn* txn_u;
MDB_dbi mdb_u;
c3_w ret_w;
// create a read-only transaction.
//
if ( (ret_w = mdb_txn_begin(env_u, 0, MDB_RDONLY, &txn_u)) ) {
fprintf(stderr, "lmdb: read txn_begin fail: %s\n", mdb_strerror(ret_w));
return c3n;
}
// open the database in the transaction
//
{
c3_w ops_w = MDB_CREATE | MDB_INTEGERKEY;
if ( (ret_w = mdb_dbi_open(txn_u, "EVENTS", ops_w, &mdb_u)) ) {
fprintf(stderr, "lmdb: read: dbi_open fail: %s\n", mdb_strerror(ret_w));
// XX confirm
//
mdb_txn_abort(txn_u);
return c3n;
}
}
{
MDB_cursor* cur_u;
MDB_val val_u;
// set the initial key to [eve_d]
//
MDB_val key_u = { .mv_size = sizeof(c3_d), .mv_data = &eve_d };
// creates a cursor to iterate over keys starting at [eve_d]
//
if ( (ret_w = mdb_cursor_open(txn_u, mdb_u, &cur_u)) ) {
fprintf(stderr, "lmdb: read: cursor_open fail: %s\n",
mdb_strerror(ret_w));
// XX confirm
//
mdb_txn_abort(txn_u);
return c3n;
}
// set the cursor to the position of [eve_d]
//
if ( (ret_w = mdb_cursor_get(cur_u, &key_u, &val_u, MDB_SET_KEY)) ) {
fprintf(stderr, "lmdb: read: initial cursor_get failed at %" PRIu64 ": %s\r\n",
eve_d,
mdb_strerror(ret_w));
mdb_cursor_close(cur_u);
// XX confirm
//
mdb_txn_abort(txn_u);
return c3n;
}
// load up to [len_d] events, iterating forward across the cursor.
//
{
c3_o ret_o = c3y;
c3_d i_d;
for ( i_d = 0; (ret_w != MDB_NOTFOUND) && (i_d < len_d); ++i_d) {
c3_d cur_d = (eve_d + i_d);
if ( sizeof(c3_d) != key_u.mv_size ) {
fprintf(stderr, "lmdb: read: invalid key size\r\n");
ret_o = c3n;
break;
}
// sanity check: ensure contiguous event numbers
//
if ( *(c3_d*)key_u.mv_data != cur_d ) {
fprintf(stderr, "lmdb: read gap: expected %" PRIu64
", received %" PRIu64 "\r\n",
cur_d,
*(c3_d*)key_u.mv_data);
ret_o = c3n;
break;
}
// invoke read callback with [val_u]
//
if ( c3n == read_f(vod_p, cur_d, val_u.mv_size, val_u.mv_data) ) {
ret_o = c3n;
break;
}
// read the next event from the cursor
//
if ( (ret_w = mdb_cursor_get(cur_u, &key_u, &val_u, MDB_NEXT))
&& (MDB_NOTFOUND != ret_w) )
{
fprintf(stderr, "lmdb: read: error: %s\r\n",
mdb_strerror(ret_w));
ret_o = c3n;
break;
}
}
mdb_cursor_close(cur_u);
// read-only transactions are aborted when complete
//
mdb_txn_abort(txn_u);
return ret_o;
}
}
}
/* c3_lmdb_save(): save [len_d] events starting at [eve_d].
*/
c3_o
c3_lmdb_save(MDB_env* env_u,
c3_d eve_d, // first event
c3_d len_d, // number of events
void** byt_p, // array of bytes
size_t* siz_i) // array of lengths
{
MDB_txn* txn_u;
MDB_dbi mdb_u;
c3_w ret_w;
// create a write transaction
//
if ( (ret_w = mdb_txn_begin(env_u, 0, 0, &txn_u)) ) {
fprintf(stderr, "lmdb: write: txn_begin fail: %s\n", mdb_strerror(ret_w));
return c3n;
}
// opens the database in the transaction
//
{
c3_w ops_w = MDB_CREATE | MDB_INTEGERKEY;
if ( (ret_w = mdb_dbi_open(txn_u, "EVENTS", ops_w, &mdb_u)) ) {
fprintf(stderr, "lmdb: write: dbi_open fail: %s\n", mdb_strerror(ret_w));
mdb_txn_abort(txn_u);
return c3n;
}
}
// write every event in the batch
//
{
c3_w ops_w = MDB_NOOVERWRITE;
c3_d las_d = (eve_d + len_d);
c3_d key_d, i_d;
for ( i_d = 0; i_d < len_d; ++i_d) {
key_d = eve_d + i_d;
{
MDB_val key_u = { .mv_size = sizeof(c3_d), .mv_data = &key_d };
MDB_val val_u = { .mv_size = siz_i[i_d], .mv_data = byt_p[i_d] };
if ( (ret_w = mdb_put(txn_u, mdb_u, &key_u, &val_u, ops_w)) ) {
fprintf(stderr, "lmdb: write failed on event %" PRIu64 "\n", key_d);
mdb_txn_abort(txn_u);
return c3n;
}
}
}
}
// commit transaction
//
if ( (ret_w = mdb_txn_commit(txn_u)) ) {
fprintf(stderr, "lmdb: write failed: %s\n", mdb_strerror(ret_w));
return c3n;
}
return c3y;
}
/* c3_lmdb_read_meta(): read by string from the META db.
*/
void
c3_lmdb_read_meta(MDB_env* env_u,
void* vod_p,
const c3_c* key_c,
void (*read_f)(void*, size_t, void*))
{
MDB_txn* txn_u;
MDB_dbi mdb_u;
c3_w ret_w;
// create a read transaction
//
if ( (ret_w = mdb_txn_begin(env_u, 0, MDB_RDONLY, &txn_u)) ) {
fprintf(stderr, "lmdb: meta read: txn_begin fail: %s\n",
mdb_strerror(ret_w));
return read_f(vod_p, 0, 0);
}
// open the database in the transaction
//
if ( (ret_w = mdb_dbi_open(txn_u, "META", 0, &mdb_u)) ) {
fprintf(stderr, "lmdb: meta read: dbi_open fail: %s\n",
mdb_strerror(ret_w));
mdb_txn_abort(txn_u);
return read_f(vod_p, 0, 0);
}
// read by string key, invoking callback with result
{
MDB_val key_u = { .mv_size = strlen(key_c), .mv_data = (void*)key_c };
MDB_val val_u;
if ( (ret_w = mdb_get(txn_u, mdb_u, &key_u, &val_u)) ) {
fprintf(stderr, "lmdb: read failed: %s\n", mdb_strerror(ret_w));
mdb_txn_abort(txn_u);
return read_f(vod_p, 0, 0);
}
else {
read_f(vod_p, val_u.mv_size, val_u.mv_data);
// read-only transactions are aborted when complete
//
mdb_txn_abort(txn_u);
}
}
}
/* c3_lmdb_save_meta(): save by string into the META db.
*/
c3_o
c3_lmdb_save_meta(MDB_env* env_u,
const c3_c* key_c,
size_t val_i,
void* val_p)
{
MDB_txn* txn_u;
MDB_dbi mdb_u;
c3_w ret_w;
// create a write transaction
//
if ( (ret_w = mdb_txn_begin(env_u, 0, 0, &txn_u)) ) {
fprintf(stderr, "lmdb: meta write: txn_begin fail: %s\n",
mdb_strerror(ret_w));
return c3n;
}
// opens the database in the transaction
//
if ( (ret_w = mdb_dbi_open(txn_u, "META", MDB_CREATE, &mdb_u)) ) {
fprintf(stderr, "lmdb: meta write: dbi_open fail: %s\n",
mdb_strerror(ret_w));
mdb_txn_abort(txn_u);
return c3n;
}
// put value by string key
//
{
MDB_val key_u = { .mv_size = strlen(key_c), .mv_data = (void*)key_c };
MDB_val val_u = { .mv_size = val_i, .mv_data = val_p };
if ( (ret_w = mdb_put(txn_u, mdb_u, &key_u, &val_u, 0)) ) {
fprintf(stderr, "lmdb: write failed: %s\n", mdb_strerror(ret_w));
mdb_txn_abort(txn_u);
return c3n;
}
}
// commit txn
//
if ( (ret_w = mdb_txn_commit(txn_u)) ) {
fprintf(stderr, "lmdb: meta write: commit failed: %s\n",
mdb_strerror(ret_w));
return c3n;
}
return c3y;
}

Some files were not shown because too many files have changed in this diff Show More