CLI option for serf exe + serf exe/flags live in PierConfig.

pkg/hs/urbit-king/TODO.md

@@ -69,6 +69,20 @@ Polish:
       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
@@ -79,6 +93,9 @@ Implement Pier-wide process start events
 - [ ] 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`?)
 
 
 # Cleanup

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

@@ -29,13 +29,11 @@ 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(..))
 
 
 -- KingEnv ---------------------------------------------------------------------
 
-class HasStderrLogFunc a where
-  stderrLogFuncL :: Lens' a LogFunc
-
 class HasKingId a where
   kingIdL :: Lens' a Word16
 

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

@@ -40,6 +40,7 @@ data Opts = Opts
     , oHttpPort     :: Maybe Word16
     , oHttpsPort    :: Maybe Word16
     , oLoopbackPort :: Maybe Word16
+    , oSerfExe      :: Maybe Text
     }
   deriving (Show)
 
@@ -272,13 +273,18 @@ opts = do
       <> help "Localhost-only HTTP port"
       <> hidden
 
-    -- Always disable hashboard. Right now, urbit is almost unusable with this
-    -- flag enabled and it is disabled in vere.
-    let oHashless = True
-    -- oHashless  <- switch $ short 'S'
-    --                     <> long "hashless"
-    --                     <> help "Disable battery hashing"
-    --                     <> hidden
+    oSerfExe <-
+      optional
+      $  option auto
+      $  metavar "PATH"
+      <> long "serf"
+      <> help "Path to Serf"
+      <> hidden
+
+    oHashless  <- switch $ short 'S'
+                        <> long "hashless"
+                        <> help "Disable battery hashing (Ignored for now)"
+                        <> hidden
 
     oQuiet     <- switch $ short 'q'
                         <> long "quiet"

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

@@ -5,13 +5,17 @@ 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.
 -}
 data PierConfig = PierConfig
-  { _pcPierPath :: FilePath
-  , _pcDryRun   :: Bool
+  { _pcPierPath  :: FilePath
+  , _pcDryRun    :: Bool
+  , _pcSerfExe   :: Text
+  , _pcSerfFlags :: [Serf.Flag]
   } deriving (Show)
 
 makeLenses ''PierConfig

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

@@ -120,28 +120,32 @@ removeFileIfExists pax = do
       removeFile pax
 
 
---------------------------------------------------------------------------------
+-- 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 { .. }
@@ -178,12 +182,11 @@ tryBootFromPill
   :: Bool
   -> Pill
   -> Bool
-  -> [Serf.Flag]
   -> Ship
   -> LegacyBootEvent
   -> MultiEyreApi
   -> RIO PierEnv ()
-tryBootFromPill oExit pill lite flags ship boot multi = do
+tryBootFromPill oExit pill lite ship boot multi = do
   mStart <- newEmptyMVar
   vSlog  <- logSlogs
   runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart multi
@@ -191,7 +194,7 @@ tryBootFromPill oExit pill lite flags ship boot multi = do
   bootedPier vSlog = do
     view pierPathL >>= lockFile
     rio $ logTrace "Starting boot"
-    sls <- Pier.booted vSlog pill lite flags ship boot
+    sls <- Pier.booted vSlog pill lite ship boot
     rio $ logTrace "Completed boot"
     pure sls
 
@@ -219,11 +222,10 @@ tryPlayShip
   :: Bool
   -> Bool
   -> Maybe Word64
-  -> [Serf.Flag]
   -> MVar ()
   -> MultiEyreApi
   -> RIO PierEnv ()
-tryPlayShip exitImmediately fullReplay playFrom flags mStart multi = do
+tryPlayShip exitImmediately fullReplay playFrom mStart multi = do
   when fullReplay wipeSnapshot
   vSlog <- logSlogs
   runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart multi
@@ -243,7 +245,7 @@ tryPlayShip exitImmediately fullReplay playFrom flags mStart multi = do
   resumeShip vSlog = do
     view pierPathL >>= lockFile
     rio $ logTrace "RESUMING SHIP"
-    sls <- Pier.resumed vSlog playFrom flags
+    sls <- Pier.resumed vSlog playFrom
     rio $ logTrace "SHIP RESUMED"
     pure sls
 
@@ -251,6 +253,7 @@ runRAcquire :: (MonadUnliftIO (m e),  MonadIO (m e), MonadReader e (m e))
             => RAcquire e a -> m e a
 runRAcquire act = rwith act pure
 
+
 --------------------------------------------------------------------------------
 
 checkEvs :: FilePath -> Word64 -> Word64 -> RIO KingEnv ()
@@ -301,6 +304,10 @@ checkEvs pierPath first last = do
 
 --------------------------------------------------------------------------------
 
+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
@@ -325,6 +332,7 @@ collectAllFx top = do
 
     serfFlags :: [Serf.Flag]
     serfFlags = [Serf.Hashless, Serf.DryRun]
+-}
 
 
 --------------------------------------------------------------------------------
@@ -530,8 +538,6 @@ newShip CLI.New{..} opts = do
           name <- nameFromShip ship
           runTryBootFromPill multi pill name ship (Dawn dawn)
 
-    flags = toSerfFlags opts
-
     -- Now that we have all the information for running an application with a
     -- PierConfig, do so.
     runTryBootFromPill multi pill name ship bootEvent = do
@@ -539,7 +545,7 @@ newShip CLI.New{..} opts = do
       let pierConfig = toPierConfig (pierPath name) opts
       let networkConfig = toNetworkConfig opts
       runPierEnv pierConfig networkConfig vKill $
-        tryBootFromPill True pill nLite flags ship bootEvent multi
+        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
@@ -567,12 +573,12 @@ runShip (CLI.Run pierPath) opts daemon multi = do
       finally (runPier mStart) $ do
         cancel connectionThread
   where
+    runPier :: MVar () -> RIO PierEnv ()
     runPier mStart = do
       tryPlayShip
         (CLI.oExit opts)
         (CLI.oFullReplay opts)
         (CLI.oDryFrom opts)
-        (toSerfFlags opts)
         mStart
         multi
 
@@ -616,6 +622,7 @@ checkComet = do
 main :: IO ()
 main = do
   args <- CLI.parseArgs
+
   hSetBuffering stdout NoBuffering
   setupSignalHandlers
 

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

@@ -117,20 +117,19 @@ printTank f _priority = f . unlines . fmap unTape . wash (WashCfg 0 80) . tankTr
   tankTree (Tank t) = t
 
 runSerf
-  :: HasLogFunc e
+  :: HasPierEnv e
   => TVar (Text -> IO ())
   -> FilePath
-  -> [Serf.Flag]
   -> RAcquire e Serf
-runSerf vSlog pax fax = do
+runSerf vSlog pax = do
   env <- ask
   Serf.withSerf (config env)
  where
   slog txt = atomically (readTVar vSlog) >>= (\f -> f txt)
   config env = Serf.Config
-    { scSerf = "urbit-worker" -- TODO Find the executable in some proper way.
+    { scSerf = env ^. pierConfigL . pcSerfExe . to unpack
     , scPier = pax
-    , scFlag = fax
+    , scFlag = env ^. pierConfigL . pcSerfFlags
     , scSlog = \(pri, tank) -> printTank slog pri tank
     , scStdr = \txt -> slog (txt <> "\r\n")
     , scDead = pure () -- TODO: What can be done?
@@ -143,13 +142,12 @@ booted
   :: TVar (Text -> IO ())
   -> Pill
   -> Bool
-  -> [Serf.Flag]
   -> Ship
   -> LegacyBootEvent
   -> RAcquire PierEnv (Serf, EventLog)
-booted vSlog pill lite flags ship boot = do
-  rio $ bootNewShip pill lite flags ship boot
-  resumed vSlog Nothing flags
+booted vSlog pill lite ship boot = do
+  rio $ bootNewShip pill lite ship boot
+  resumed vSlog Nothing
 
 bootSeqJobs :: Time.Wen -> BootSeq -> [Job]
 bootSeqJobs now (BootSeq ident nocks ovums) = zipWith ($) bootSeqFns [1 ..]
@@ -167,11 +165,10 @@ bootNewShip
   :: HasPierEnv e
   => Pill
   -> Bool
-  -> [Serf.Flag]
   -> Ship
   -> LegacyBootEvent
   -> RIO e ()
-bootNewShip pill lite flags ship bootEv = do
+bootNewShip pill lite ship bootEv = do
   seq@(BootSeq ident x y) <- genBootSeq ship pill lite bootEv
   logDebug "BootSeq Computed"
 
@@ -195,9 +192,8 @@ bootNewShip pill lite flags ship bootEv = do
 resumed
   :: TVar (Text -> IO ())
   -> Maybe Word64
-  -> [Serf.Flag]
   -> RAcquire PierEnv (Serf, EventLog)
-resumed vSlog replayUntil flags  = do
+resumed vSlog replayUntil = do
   rio $ logTrace "Resuming ship"
   top <- view pierPathL
   tap <- fmap (fromMaybe top) $ rio $ runMaybeT $ do
@@ -209,7 +205,7 @@ resumed vSlog replayUntil flags  = do
     logTrace $ display @Text ("running serf in: " <> pack tap)
 
   log  <- Log.existing (top </> ".urb/log")
-  serf <- runSerf vSlog tap flags
+  serf <- runSerf vSlog tap
 
   rio $ do
     logDebug "Replaying events"

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

@@ -18,7 +18,7 @@ import Urbit.Vere.Serf.IPC
 
 import Control.Monad.Trans.Resource (runResourceT)
 import Urbit.Arvo                   (FX)
-import Urbit.King.App               (HasStderrLogFunc(..))
+import Urbit.King.App.Class         (HasStderrLogFunc(..))
 
 import qualified Data.Conduit.Combinators as CC
 import qualified System.ProgressBar       as PB