Merge branch 'master' into release/next-userspace

.travis.yml

@@ -1,6 +1,13 @@
+stages:
+  - compile
+  # Don't run the combine stage in pull requests, because deploy is disabled there.
+  - name: combine
+    if: type != pull_request
+
 jobs:
   include:
-  - os: linux
+  - stage: compile
+    os: linux
     language: nix
     nix: 2.3.6
     before_install:
@@ -15,7 +22,8 @@ jobs:
       - make release
       - sh/ci-tests
 
-  - os: linux
+  - stage: compile
+    os: linux
     language: generic
     env: STACK_YAML=pkg/hs/stack.yaml
     cache:
@@ -32,7 +40,8 @@ jobs:
       - stack test
       - sh/release-king-linux64-dynamic
 
-  - os: osx
+  - stage: compile
+    os: osx
     language: generic
     sudo: required
     env: STACK_YAML=pkg/hs/stack.yaml
@@ -50,6 +59,12 @@ jobs:
       - stack test
       - sh/release-king-darwin-dynamic
 
+  - stage: combine
+    os: linux
+    language: generic
+    script:
+      - sh/combine-release-builds
+
 deploy:
   - skip_cleanup: true
     provider: gcs

bin/brass.pill

@@ -1,3 +1,3 @@
 version https://git-lfs.github.com/spec/v1
-oid sha256:f738f60e9e028081864f317106f623d2f21a5fe5c2f6fdd83576e22d21a8c6a6
-size 14862847
+oid sha256:35d8930b9b35364605196d99766ec713154af9105ce7b9fabfaa50e8ca29a5fd
+size 4448128

bin/ivory.pill

@@ -1,3 +1,3 @@
 version https://git-lfs.github.com/spec/v1
-oid sha256:9fbfbe75a6685df444621ebd27677716fd0abf7113020f3274c3b5c209e3616e
-size 1304972
+oid sha256:e5c82dea80aa7c5593f43fa4294db7974211abceedd907663da73889857642e7
+size 1309381

bin/solid.pill

@@ -1,3 +1,3 @@
 version https://git-lfs.github.com/spec/v1
-oid sha256:59786d78805460632c4de60275b994260d255be7b721ccf47140d7647a46e66c
-size 6244195
+oid sha256:ecf3f8593815742e409008421f318b664124e672b1eecd131e4a1e49864a1c2a
+size 6175676

nix/cachix/local.nix

@@ -13,7 +13,6 @@ let
     murmur3-src    = deps.murmur3.src;
     scrypt-src     = deps.scrypt.src;
     secp256k1-src  = deps.secp256k1.src;
-    sni-src        = deps.sni.src;
     softfloat3-src = deps.softfloat3.src;
     uv-src         = deps.uv.src;
   };

nix/cachix/tests.nix

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

nix/crossdeps.nix

@@ -5,7 +5,6 @@ rec {
   murmur3      = import ./deps/murmur3/cross.nix      { inherit crossenv; };
   uv           = import ./deps/uv/cross.nix           { inherit crossenv; };
   ed25519      = import ./deps/ed25519/cross.nix      { inherit crossenv; };
-  sni          = import ./deps/sni/cross.nix          { inherit crossenv; };
   scrypt       = import ./deps/scrypt/cross.nix       { inherit crossenv; };
   softfloat3   = import ./deps/softfloat3/cross.nix   { inherit crossenv; };
   secp256k1    = import ./deps/secp256k1/cross.nix    { inherit crossenv; };

nix/deps-env.nix

@@ -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;
@@ -20,7 +20,7 @@ let
 
   vendor =
     with deps;
-    [ argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv ent ge-additions ivory-header ca-header ];
+    [ argon2 ed25519 h2o murmur3 scrypt secp256k1 softfloat3 uv ent ge-additions ivory-header ca-header ];
 
 in
 

nix/deps/default.nix

@@ -5,7 +5,6 @@ rec {
   murmur3      = import ./murmur3      { inherit pkgs; };
   uv           = import ./uv           { inherit pkgs; };
   ed25519      = import ./ed25519      { inherit pkgs; };
-  sni          = import ./sni          { inherit pkgs; };
   scrypt       = import ./scrypt       { inherit pkgs; };
   softfloat3   = import ./softfloat3   { inherit pkgs; };
   secp256k1    = import ./secp256k1    { inherit pkgs; };

nix/deps/sni/builder.sh

@@ -1,13 +0,0 @@
-source $stdenv/setup
-
-CFLAGS="-O3 -Wall -ffast-math -Wno-unused-const-variable"
-
-echo $CC $CFLAGS -c $src/src/tls.c -o tls.o
-$CC $CFLAGS -c $src/src/tls.c -o tls.o
-
-echo $AR rcs libsni.a tls.o
-$AR rcs libsni.a tls.o
-
-mkdir -p $out/{lib,include}
-cp libsni.a $out/lib/
-cp $src/src/tls.h $out/include/

nix/deps/sni/cross.nix

@@ -1,18 +0,0 @@
-{ crossenv }:
-
-crossenv.make_derivation rec {
-  name    = "sni";
-  builder = ./builder.sh;
-
-  CC = "${crossenv.host}-gcc";
-  AR = "${crossenv.host}-ar";
-
-  src = crossenv.nixpkgs.fetchFromGitHub {
-    owner = "urbit";
-    repo = "sniproxy";
-    rev = "173beb88ee62bddd13874ca04ab338cdec704928";
-    sha256 = "1ib6p7vhpvbg6d5a2aimppsb09kjg4px4vlw5h3ys9zf9c1if5z4";
-  };
-}
-
-

nix/deps/sni/default.nix

@@ -1,12 +0,0 @@
-{ pkgs }:
-
-pkgs.stdenv.mkDerivation rec {
-  name = "sni";
-  builder = ./builder.sh;
-  src = pkgs.fetchFromGitHub {
-    owner = "urbit";
-    repo = "sniproxy";
-    rev = "173beb88ee62bddd13874ca04ab338cdec704928";
-    sha256 = "1ib6p7vhpvbg6d5a2aimppsb09kjg4px4vlw5h3ys9zf9c1if5z4";
-  };
-}

nix/nixcrpkgs/pkgs.nix

@@ -24,10 +24,6 @@ rec {
     inherit crossenv;
   };
 
-  ncurses = import ./pkgs/ncurses {
-    inherit crossenv;
-  };
-
   pdcurses = import ./pkgs/pdcurses {
     inherit crossenv;
   };

nix/ops/boot-ship.nix

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

nix/ops/default.nix

@@ -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;

nix/ops/fakeship/builder.sh

@@ -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

nix/ops/solid/builder.sh

@@ -7,13 +7,13 @@ chmod -R u+rw ./pier
 
 $URBIT -d ./pier
 
-cleanup () {
+shutdown () {
   if [ -e ./pier/.vere.lock ]
   then kill $(< ./pier/.vere.lock) || true;
   fi
 }
 
-trap cleanup EXIT
+trap shutdown EXIT
 
 #  update pill strategy to ensure correct staging
 #
@@ -75,6 +75,8 @@ herb ./pier -p hood -d "+hood/unmount %stage"
 
 herb ./pier -P solid.pill -d '+solid /=stage=/sys, =dub &'
 
+herb ./pier -p hood -d '+hood/exit' || true
+
 mv solid.pill $out
 
 set +x

nix/pkgs/default.nix

@@ -21,7 +21,7 @@ let
   mkUrbit = { debug }:
     import ./urbit {
       inherit pkgs ent debug ge-additions libaes_siv;
-      inherit (deps) argon2 murmur3 uv ed25519 sni scrypt softfloat3;
+      inherit (deps) argon2 murmur3 uv ed25519 scrypt softfloat3;
       inherit (deps) secp256k1 h2o ivory-header ca-header;
     };
 

nix/pkgs/urbit/default.nix

@@ -1,7 +1,7 @@
 {
   pkgs,
   debug,
-  argon2, ed25519, ent, ge-additions, libaes_siv, h2o, murmur3, scrypt, secp256k1, sni, softfloat3, uv, ivory-header, ca-header
+  argon2, ed25519, ent, ge-additions, libaes_siv, h2o, murmur3, scrypt, secp256k1, softfloat3, uv, ivory-header, ca-header
 }:
 
 let
@@ -23,10 +23,10 @@ let
 
   deps =
     with pkgs;
-    [ curl gmp sigseg ncurses openssl zlib lmdb ];
+    [ curl gmp sigseg openssl zlib lmdb ];
 
   vendor =
-    [ argon2 softfloat3 ed25519 ent ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 sni ivory-header ca-header ];
+    [ argon2 softfloat3 ed25519 ent ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 ivory-header ca-header ];
 
   urbit = pkgs.stdenv.mkDerivation {
     inherit name meta;

nix/pkgs/urbit/release.nix

@@ -12,11 +12,11 @@ let
 
   crossdeps =
     with env;
-    [ curl libgmp libsigsegv ncurses openssl zlib lmdb ];
+    [ curl libgmp libsigsegv openssl zlib lmdb ];
 
   vendor =
     with deps;
-    [ argon2 softfloat3 ed25519 ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 sni ivory-header ca-header ];
+    [ argon2 softfloat3 ed25519 ge-additions libaes_siv h2o scrypt uv murmur3 secp256k1 ivory-header ca-header ];
 
 in
 
@@ -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;

nix/pkgs/urbit/release.sh

@@ -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

nix/pkgs/urbit/shell.nix

@@ -12,5 +12,5 @@ import ./default.nix {
   inherit (tlon)
     ent ge-additions libaes_siv;
   inherit (deps)
-    argon2 ed25519 h2o murmur3 scrypt secp256k1 sni softfloat3 uv ivory-header ca-header;
+    argon2 ed25519 h2o murmur3 scrypt secp256k1 softfloat3 uv ivory-header ca-header;
 }

nix/release.nix

@@ -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;

pkg/arvo/gen/solid.hoon

@@ -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]
 ::

pkg/hs/.gitignore

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

pkg/hs/proto/package.yaml

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

pkg/hs/racquire/.gitignore

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

pkg/hs/racquire/LICENSE

@@ -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.

pkg/hs/racquire/package.yaml

@@ -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

pkg/hs/stack.yaml

@@ -3,10 +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

pkg/hs/urbit-eventlog-lmdb/.gitignore

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

pkg/hs/urbit-eventlog-lmdb/LICENSE

@@ -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.

pkg/hs/urbit-eventlog-lmdb/lib/Urbit/EventLog/LMDB.hs

@@ -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
 

pkg/hs/urbit-eventlog-lmdb/package.yaml

@@ -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

pkg/hs/urbit-king/TODO.md

@@ -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`

pkg/hs/urbit-king/lib/Urbit/Arvo/Common.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/King/API.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/King/App.hs

@@ -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)

pkg/hs/urbit-king/lib/Urbit/King/App/Class.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/King/CLI.hs

@@ -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
+      $  strOption
+      $  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

pkg/hs/urbit-king/lib/Urbit/King/Config.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/King/EventBrowser.hs

@@ -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 =

pkg/hs/urbit-king/lib/Urbit/King/Main.hs

@@ -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
+
 
 --------------------------------------------------------------------------------
 

pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs

@@ -1,87 +1,162 @@
 {-|
-    Ames IO Driver -- UDP
+  Ames IO Driver
 -}
 
-module Urbit.Vere.Ames (ames) where
+module Urbit.Vere.Ames (ames, ames', PacketOutcome(..)) 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)
+
+
+-- Constants -------------------------------------------------------------------
+
+-- | How many unprocessed ames packets to allow in the queue before we start
+-- dropping incoming packets.
+queueBound :: Word
+queueBound = 1000
+
+-- | How often, measured in number of packets dropped, we should announce packet
+-- loss.
+packetsDroppedPerComplaint :: Word
+packetsDroppedPerComplaint = 1000
+
 
 -- 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])
+  , aDropped  :: TVar Word
+  , aUdpServ  :: UdpServ
+  , aResolvr  :: ResolvServ
+  , aRecvTid  :: Async ()
   }
 
-data NetworkMode = Fake | Localhost | Real | NoNetwork
-  deriving (Eq, Ord, Show)
+data PacketOutcome
+  = Intake
+  | Ouster
 
 
 -- 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
+  -- Unfortunately, we cannot use TBQueue because the only behavior
+  -- provided for when full is to block the writer. The implementation
+  -- below uses materially the same data structures as TBQueue, however.
+  ventQ :: TQueue EvErr <- newTQueueIO
+  avail :: TVar Word <- newTVarIO queueBound
+  let
+    enqueuePacket p = do
+      vail <- readTVar avail
+      if vail > 0
+        then do
+          modifyTVar avail (subtract 1)
+          writeTQueue ventQ p
+          pure Intake
+        else do
+          _ <- readTQueue ventQ
+          writeTQueue ventQ p
+          pure Ouster
+    dequeuePacket = do
+      pM <- tryReadTQueue ventQ
+      when (isJust pM) $ modifyTVar avail (+ 1)
+      pure pM
+
+  env <- ask
+  let (bornEvs, startDriver) = ames env who isFake enqueuePacket stderr
+
+  let runDriver = do
+        diOnEffect <- startDriver
+        let diEventSource = fmap RRWork <$> dequeuePacket
+        pure (DriverApi {..})
+
+  pure (bornEvs, runDriver)
+
+
 {-|
     inst      -- Process instance number.
     who       -- Which ship are we?
@@ -93,229 +168,81 @@ 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 PacketOutcome)
+  -> (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 :: HasLogFunc e => RIO e AmesDrv
+  start = do
+    aTurfs   <- newTVarIO Nothing
+    aDropped <- newTVarIO 0
+    aUdpServ <- udpServ isFake who
+    aRecvTid <- queuePacketsThread aDropped 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 :: HasLogFunc e => TVar Word -> UdpServ -> RIO e (Async ())
+  queuePacketsThread dropCtr UdpServ {..} = async $ forever $ do
+    outcome <- atomically $ do
+      (p, a, b) <- usRecv
+      enqueueEv (EvErr (hearEv p a b) hearFailed)
+    case outcome of
+      Intake -> pure ()
+      Ouster -> do
+        d <- atomically $ do
+          d <- readTVar dropCtr
+          writeTVar dropCtr (d + 1)
+          pure d
+        when (d `rem` packetsDroppedPerComplaint == 0) $
+          logWarn "ames: queue full; dropping inbound packets"
 
-    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)

pkg/hs/urbit-king/lib/Urbit/Vere/Ames/DNS.hs

@@ -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)

pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs

@@ -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
+                 }

pkg/hs/urbit-king/lib/Urbit/Vere/Behn.hs

@@ -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))

pkg/hs/urbit-king/lib/Urbit/Vere/Clay.hs

@@ -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)

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs

@@ -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)
+    }

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/PortsFile.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Service.hs

@@ -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)

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Wai.hs

@@ -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)

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

@@ -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

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

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs

@@ -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.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.EventLog.LMDB    (EventLog)
+import Urbit.King.API         (TermConn)
+import Urbit.Noun.Time        (Wen)
+import Urbit.TermSize         (TermSize(..))
+import Urbit.Vere.Eyre.Multi  (MultiEyreApi)
+import Urbit.Vere.Serf        (Serf)
 
+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.Time             as Time
-import qualified Urbit.Vere.Log         as Log
+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
-import qualified Urbit.Vere.Term.Render 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
-                (Term.TSize{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()
-        -> (Term.TSize, 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)

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

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs

@@ -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

pkg/hs/urbit-king/lib/Urbit/Vere/Serf/IPC.hs

@@ -0,0 +1,704 @@
+{-|
+  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
+            $%  [%cram eve=@]
+                [%exit cod=@]
+                [%save eve=@]
+                [%pack ~]
+        ==  ==
+        [%peek mil=@ now=@da lyc=gang pat=path]
+        [%play eve=@ lit=(list ?((pair @da ovum) *))]
+        [%work mil=@ job=(pair @da ovum)]
+    ==
+  ::  +plea: from serf to king
+  ::
+  +$  plea
+    $%  [%live ~]
+        [%ripe [pro=%1 hon=@ nok=@] eve=@ mug=@]
+        [%slog pri=@ ?(cord tank)]
+        $:  %peek
+            $%  [%done dat=(unit (cask))]
+                [%bail dud=goof]
+        ==  ==
+        $:  %play
+            $%  [%done mug=@]
+                [%bail eve=@ mug=@ dud=goof]
+        ==  ==
+        $:  %work
+            $%  [%done eve=@ mug=@ fec=(list ovum)]
+                [%swap eve=@ mug=@ job=(pair @da 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
+  | LCram EventId
+  | LPack ()
+ deriving (Show)
+
+data Play
+  = PDone Mug
+  | PBail PlayBail
+ deriving (Show)
+
+data Scry
+  = SDone (Maybe (Term, Noun))
+  | SBail Goof
+ deriving (Show)
+
+data Work
+  = WDone EventId Mug FX
+  | WSwap EventId Mug (Wen, Noun) FX
+  | WBail [Goof]
+ deriving (Show)
+
+data Writ
+  = WLive Live
+  | WPeek Atom Wen Gang Path
+  | WPlay EventId [Noun]
+  | WWork Atom Wen Ev
+ deriving (Show)
+
+data Plea
+  = PLive ()
+  | PRipe SerfInfo
+  | PSlog Slog
+  | PPeek Scry
+  | PPlay Play
+  | PWork Work
+ deriving (Show)
+
+deriveNoun ''Live
+deriveNoun ''Play
+deriveNoun ''Scry
+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 (SDone peek) -> pure peek
+    -- XX produce error
+    PPeek (SBail dud)  -> throwIO (PeekBail dud)
+    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 -> IO ()
+sendCompactionRequest serf = do
+  sendWrit serf (WLive $ LPack ())
+  recvLive serf
+
+sendScryRequest :: Serf -> Wen -> Gang -> Path -> IO (Maybe (Term, Noun))
+sendScryRequest serf w g p = do
+  sendWrit serf (WPeek 0 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)
+  rock    = "0"      -- XX support loading from rock
+  cache   = "50000"  -- XX support memo-cache size
+  args    = ["serf", pierPath, diskKey, config, cache, rock]
+  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
+  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 0 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 0 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"

pkg/hs/urbit-king/lib/Urbit/Vere/Serf/Types.hs

@@ -0,0 +1,121 @@
+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
+  | PeekBail Goof
+  | 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

pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs

@@ -8,6 +8,7 @@ module Urbit.Vere.Term
     , runTerminalClient
     , connClient
     , term
+    , term'
     ) where
 
 import Data.Char
@@ -18,19 +19,21 @@ 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
 import qualified Urbit.Vere.Term.Render   as T
@@ -74,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)
@@ -138,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
@@ -153,20 +142,46 @@ 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.
 -}
 localClient :: ∀e. HasLogFunc e
             => STM ()
-            -> RAcquire e (T.TSize, Client)
+            -> RAcquire e (TermSize, Client)
 localClient doneSignal = fst <$> mkRAcquire start stop
   where
-    start :: HasLogFunc e => RIO e ((T.TSize, Client), Private)
+    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
 
@@ -187,12 +202,12 @@ localClient doneSignal = fst <$> mkRAcquire start stop
                           , give = writeTQueue tsWriteQueue
                           }
 
-      tsize <- io $ T.tsize
+      tsize <- io $ T.termSize
 
       pure ((tsize, client), Private{..})
 
     stop :: HasLogFunc e
-         => ((T.TSize, Client), Private) -> RIO e ()
+         => ((TermSize, Client), Private) -> RIO e ()
     stop ((_, Client{..}), Private{..}) = do
       -- Note that we don't `cancel pReaderThread` here. This is a deliberate
       -- decision because fdRead calls into a native function which the runtime
@@ -226,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.
@@ -246,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
@@ -266,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
@@ -274,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
@@ -291,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
 
@@ -306,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
@@ -356,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
@@ -489,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)
-     => (T.TSize, 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
-    T.TSize 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
@@ -521,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]

pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs

@@ -2,9 +2,7 @@
     Terminal Driver
 -}
 module Urbit.Vere.Term.Render
-    ( TSize(..)
-    , tsize
-    , clearScreen
+    ( clearScreen
     , clearLine
     , cursorRight
     , cursorLeft
@@ -13,29 +11,11 @@ module Urbit.Vere.Term.Render
 
 import ClassyPrelude
 
-import qualified System.Console.Terminal.Size as TSize
-import qualified System.Console.ANSI          as ANSI
+import qualified System.Console.ANSI as ANSI
 
 
 -- Types -----------------------------------------------------------------------
 
-data TSize = TSize
-    { tsWide ∷ Word
-    , tsTall ∷ Word
-    }
-
-
---------------------------------------------------------------------------------
-
-{- |
-    Get terminal size.  Produces 80x24 as a fallback if unable to figure
-    out terminal size.
--}
-tsize ∷ IO TSize
-tsize = do
-    TSize.Window wi hi <- TSize.size <&> fromMaybe (TSize.Window 80 24)
-    pure $ TSize { tsWide = wi, tsTall = hi }
-
 clearScreen ∷ MonadIO m ⇒ m ()
 clearScreen = liftIO $ ANSI.clearScreen
 

pkg/hs/urbit-king/package.yaml

@@ -1,5 +1,5 @@
 name: urbit-king
-version: 0.10.4
+version: 0.10.8
 license: MIT
 license-file: LICENSE
 
@@ -72,6 +72,7 @@ dependencies:
   - primitive
   - process
   - QuickCheck
+  - racquire
   - random
   - regex-tdfa
   - regex-tdfa-text
@@ -88,10 +89,10 @@ dependencies:
   - tasty-th
   - template-haskell
   - terminal-progress-bar
-  - terminal-size
   - text
   - these
   - time
+  - tls
   - transformers
   - unix
   - unliftio
@@ -99,7 +100,11 @@ dependencies:
   - unordered-containers
   - urbit-atom
   - urbit-azimuth
+  - urbit-eventlog-lmdb
   - urbit-hob
+  - urbit-noun
+  - urbit-noun-core
+  - urbit-termsize
   - utf8-string
   - vector
   - wai

pkg/hs/urbit-king/test/AmesTests.hs

@@ -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
-    let (_, runAmes) =
-          ames pid (fromIntegral point) True (writeTQueue q) noStderr
-    cb ← runAmes
-    rio $ cb turfEf
-    pure (q, cb)
+runGala
+  :: forall e
+   . HasAmes e
+  => Word8
+  -> RAcquire e (TQueue EvErr, NewtEf -> IO ())
+runGala point = do
+    env <- ask
+    que <- newTQueueIO
+    let enqueue = \p -> writeTQueue que p $> Intake
+    let (_, runAmes) = ames env (fromIntegral point) True enqueue 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

pkg/hs/urbit-king/test/ArvoTests.hs

@@ -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 -----------------------------------------------------------------------

pkg/hs/urbit-king/test/BehnTests.hs

@@ -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
 

pkg/hs/urbit-king/test/DeriveNounTests.hs

@@ -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 -------------------------------------------------------------------

pkg/hs/urbit-king/test/LogTests.hs

@@ -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

pkg/hs/urbit-noun-core/.gitignore

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

pkg/hs/urbit-noun-core/LICENSE

@@ -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.

pkg/hs/urbit-noun-core/package.yaml

@@ -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

pkg/hs/urbit-noun/.gitignore

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

pkg/hs/urbit-noun/LICENSE

@@ -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.

pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs

@@ -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

pkg/hs/urbit-noun/lib/Urbit/Noun/Tank.hs

@@ -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

pkg/hs/urbit-noun/lib/Urbit/Noun/Time.hs

@@ -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

pkg/hs/urbit-noun/package.yaml

@@ -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

pkg/hs/urbit-termsize/.gitignore

@@ -0,0 +1,3 @@
+.stack-work/
+urbit-termsize.cabal
+*~

pkg/hs/urbit-termsize/LICENSE

@@ -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.

pkg/hs/urbit-termsize/app/Main.hs

@@ -0,0 +1,13 @@
+module Main where
+
+import Prelude
+
+import Urbit.TermSize (liveTermSize)
+import System.IO (getLine)
+
+main :: IO ()
+main = do
+  init <- liveTermSize (putStrLn . ("New Size: " <>) . show)
+  putStrLn ("Initial Size: " <> show init)
+  _ <- getLine
+  pure ()

pkg/hs/urbit-termsize/lib/Urbit/TermSize.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveAnyClass  #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Urbit.TermSize
+  ( TermSize(..)
+  , termSize
+  , liveTermSize
+  )
+where
+
+import Prelude
+
+import Data.Functor                 ((<&>))
+import System.Console.Terminal.Size (Window(..), size)
+
+import qualified System.Posix.Signals      as Sys
+import qualified System.Posix.Signals.Exts as Sys
+
+
+-- Types -----------------------------------------------------------------------
+
+data TermSize = TermSize
+  { tsWide :: !Word
+  , tsTall :: !Word
+  }
+ deriving (Eq, Ord, Show)
+
+
+-- Utilities -------------------------------------------------------------------
+
+termSize :: IO TermSize
+termSize = size <&> \case
+  Nothing            -> TermSize 80 24
+  Just (Window {..}) -> TermSize width height
+
+liveTermSize :: (TermSize -> IO ()) -> IO TermSize
+liveTermSize cb = do
+  Sys.installHandler Sys.sigWINCH (Sys.Catch (termSize >>= cb)) Nothing
+  termSize

pkg/hs/urbit-termsize/package.yaml

@@ -0,0 +1,25 @@
+name: urbit-termsize
+version: 0.1.0
+license: MIT
+license-file: LICENSE
+
+dependencies:
+  - base
+  - terminal-size
+  - unix
+
+ghc-options:
+  - -fwarn-incomplete-patterns
+  - -fwarn-unused-binds
+  - -fwarn-unused-imports
+  - -O2
+
+library:
+  source-dirs: lib
+
+executables:
+  urbit-test-termsize-updates:
+    main: Main.hs
+    source-dirs: app
+    dependencies:
+      - urbit-termsize

pkg/urbit/Makefile

@@ -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)

pkg/urbit/configure

@@ -2,11 +2,11 @@
 
 set -e
 
-URBIT_VERSION="0.10.7"
+URBIT_VERSION="0.10.8"
 
-deps="                                                                    \
-  curl gmp sigsegv argon2 ed25519 ent h2o scrypt sni uv murmur3 secp256k1 \
-  softfloat3 ncurses ssl crypto z lmdb ge-additions aes_siv               \
+deps="                                                                \
+  curl gmp sigsegv argon2 ed25519 ent h2o scrypt uv murmur3 secp256k1 \
+  softfloat3 ssl crypto z lmdb ge-additions aes_siv pthread           \
 "
 
 headers="             \

pkg/urbit/daemon/main.c

@@ -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
@@ -97,9 +96,17 @@ _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:C:w:u:e:F:k:p:LljacdgqstvxPDRS")) )
+                 "X:Y:G:J:B:K:A:H:I:C:w:u:e:F:k:n:p:r:LljacdgqstvxPDRS")) )
   {
     switch ( ch_i ) {
+      case 'X': {
+        u3_Host.ops_u.pek_c = strdup(optarg);
+        break;
+      }
+      case 'Y': {
+        u3_Host.ops_u.puk_c = strdup(optarg);
+        break;
+      }
       case 'J': {
         u3_Host.ops_u.lit_c = strdup(optarg);
         break;
@@ -162,6 +169,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;
@@ -172,6 +183,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; }
@@ -398,7 +413,9 @@ u3_ve_usage(c3_i argc, c3_c** argv)
     "-u url        URL from which to download pill\n",
     "-v            Verbose\n",
     "-w name       Boot as ~name\n",
+    "-X path       Scry, jam to file, then exit\n"
     "-x            Exit immediately\n",
+    "-Y file       Optional name of jamfile (for -X)\n"
     "\n",
     "Development Usage:\n",
     "   To create a development ship, use a fakezod:\n",
@@ -449,7 +466,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,
@@ -474,19 +490,7 @@ _stop_exit(c3_i int_i)
   //  explicit fprintf to avoid allocation in u3l_log
   //
   fprintf(stderr, "\r\n[received keyboard stop signal, exiting]\r\n");
-  u3_daemon_bail();
-}
-
-/* _stop_signal(): handle termination signal.
-*/
-static void
-_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_king_bail();
 }
 
 /*
@@ -584,7 +588,7 @@ _fork_into_background_process()
 static void
 _stop_on_boot_completed_cb()
 {
-  u3_pier_exit(u3_pier_stub());
+  u3_king_exit();
 }
 
 c3_i
@@ -603,12 +607,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();
   }
@@ -651,10 +649,6 @@ main(c3_i   argc,
   //
   signal(SIGTSTP, _stop_exit);
 
-  //  Cleanup on SIGABRT.
-  //
-  signal(SIGABRT, _stop_signal);
-
   printf("~\n");
   //  printf("welcome.\n");
   printf("urbit %s\n", URBIT_VERSION);
@@ -768,7 +762,7 @@ main(c3_i   argc,
       exit(1);
     }
 
-    u3_daemon_commence();
+    u3_king_commence();
 
     //  uninitialize curl
     //

pkg/urbit/include/c/defs.h

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

pkg/urbit/include/c/motes.h

@@ -248,6 +248,7 @@
 #   define c3__cow    c3_s3('c','o','w')
 #   define c3__cpu    c3_s3('c','p','u')
 #   define c3__crad   c3_s4('c','r','a','d')
+#   define c3__cram   c3_s4('c','r','a','m')
 #   define c3__crap   c3_s4('c','r','a','p')
 #   define c3__cret   c3_s4('c','r','e','t')
 #   define c3__crib   c3_s4('c','r','i','b')
@@ -365,6 +366,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 +930,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 +1065,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 +1210,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')

pkg/urbit/include/noun/aliases.h

@@ -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))