Merge pull request #3769 from urbit/kh-inject

king: implement -I and --inject-event-list

pkg/arvo/gen/configure-hosting.hoon

@@ -0,0 +1,12 @@
+::  .configuration/pill +configure-hosting
+::
+::  boot king haskell with `--inject-event-list /path/to/configuration.pill`
+::
+:-  %say
+|=  [[now=@da @ our=@p ^] *]
+:-  %noun
+:~  [//term/1 %belt %txt "|unlink %chat-cli"]
+    [//term/1 %belt %ret 0]
+    [//term/1 %belt %txt "|cors-approve 'https://horizon.tlon.network'"]
+    [//term/1 %belt %ret 0]
+==

pkg/hs/urbit-king/TODO.md

@@ -85,11 +85,12 @@ Implement Pier-wide process start events
 - [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`?)
+
+- CLI event injection: `-I file-path`. The `file-path` is a jammed noun
+  representing an event: `[wire card]`.
+  - [x] Just parse it as an `Ev` for now.
+  - [ ] Make the serf IPC code not care about the shape of events and effects.
+  - [ ] Support invalid events throughout the system (use `Lenient`?)
 
 # Polish
 

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

@@ -44,6 +44,7 @@ data Opts = Opts
     , oHttpPort     :: Maybe Word16
     , oHttpsPort    :: Maybe Word16
     , oLoopbackPort :: Maybe Word16
+    , oInjectEvents :: [Injection]
     }
   deriving (Show)
 
@@ -77,6 +78,11 @@ data Nat
   | NatNever
   deriving (Show)
 
+data Injection
+  = InjectOneEvent   FilePath
+  | InjectManyEvents FilePath
+  deriving (Show)
+
 data New = New
     { nPillSource :: PillSource
     , nPierPath   :: Maybe FilePath -- Derived from ship name if not specified.
@@ -221,6 +227,19 @@ pillFromURL = PillSourceURL <$> strOption
 pierPath :: Parser FilePath
 pierPath = strArgument (metavar "PIER" <> help "Path to pier")
 
+injectEvents :: Parser [Injection]
+injectEvents = many $ InjectOneEvent <$> strOption
+                        ( short 'I'
+                       <> long "inject-event"
+                       <> metavar "JAM"
+                       <> help "Path to a jammed event"
+                       <> hidden)
+                  <|> InjectManyEvents <$> strOption
+                        ( long "inject-event-list"
+                       <> metavar "JAM_LIST"
+                       <> help "Path to a jammed list of events"
+                       <> hidden)
+
 serfExe :: Parser (Maybe Text)
 serfExe =  optional
     $  strOption
@@ -306,6 +325,8 @@ opts = do
       <> help "Localhost-only HTTP port"
       <> hidden
 
+    oInjectEvents <- injectEvents
+
     oHashless  <- switch $ short 'S'
                         <> long "hashless"
                         <> help "Disable battery hashing (Ignored for now)"

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

@@ -190,7 +190,7 @@ tryBootFromPill
 tryBootFromPill oExit pill lite ship boot = do
   mStart <- newEmptyMVar
   vSlog  <- logSlogs
-  runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart
+  runOrExitImmediately vSlog (bootedPier vSlog) oExit mStart []
  where
   bootedPier vSlog = do
     view pierPathL >>= lockFile
@@ -204,8 +204,9 @@ runOrExitImmediately
   -> RAcquire PierEnv (Serf, Log.EventLog)
   -> Bool
   -> MVar ()
+  -> [Ev]
   -> RIO PierEnv ()
-runOrExitImmediately vSlog getPier oExit mStart = do
+runOrExitImmediately vSlog getPier oExit mStart injected = do
   rwith getPier (if oExit then shutdownImmediately else runPier)
  where
   shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
@@ -216,18 +217,19 @@ runOrExitImmediately vSlog getPier oExit mStart = do
 
   runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
   runPier serfLog = do
-    runRAcquire (Pier.pier serfLog vSlog mStart)
+    runRAcquire (Pier.pier serfLog vSlog mStart injected)
 
 tryPlayShip
   :: Bool
   -> Bool
   -> Maybe Word64
   -> MVar ()
+  -> [Ev]
   -> RIO PierEnv ()
-tryPlayShip exitImmediately fullReplay playFrom mStart = do
+tryPlayShip exitImmediately fullReplay playFrom mStart injected = do
   when fullReplay wipeSnapshot
   vSlog <- logSlogs
-  runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart
+  runOrExitImmediately vSlog (resumeShip vSlog) exitImmediately mStart injected
  where
   wipeSnapshot = do
     shipPath <- view pierPathL
@@ -586,11 +588,28 @@ runShip (CLI.Run pierPath) opts daemon = do
   where
     runPier :: MVar () -> RIO PierEnv ()
     runPier mStart = do
+      injections <- loadInjections (CLI.oInjectEvents opts)
       tryPlayShip
         (CLI.oExit opts)
         (CLI.oFullReplay opts)
         (CLI.oDryFrom opts)
         mStart
+        injections
+
+    loadInjections :: [CLI.Injection] -> RIO PierEnv [Ev]
+    loadInjections injections = do
+      perInjection :: [[Ev]] <- for injections $ \case
+          CLI.InjectOneEvent filePath -> do
+            logInfo $ display $ "boot: reading injected event from " ++
+              (pack filePath :: Text)
+            io (loadFile filePath >>= either throwIO (pure . singleton))
+
+          CLI.InjectManyEvents filePath -> do
+            logInfo $ display $ "boot: reading injected event list from " ++
+              (pack filePath :: Text)
+            io (loadFile filePath >>= either throwIO pure)
+      pure $ concat perInjection
+
 
 
 buildPortHandler :: HasLogFunc e => CLI.Nat -> RIO e PortControlApi

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

@@ -183,7 +183,7 @@ bootNewShip pill lite ship bootEv = do
   let logPath = (pierPath </> ".urb/log")
 
   rwith (Log.new logPath ident) $ \log -> do
-    logInfo "Event log onitialized."
+    logInfo "Event log initialized."
     jobs <- (\now -> bootSeqJobs now seq) <$> io Time.now
     writeJobs log (fromList jobs)
 
@@ -264,8 +264,9 @@ pier
   :: (Serf, EventLog)
   -> TVar ((Atom, Tank) -> IO ())
   -> MVar ()
+  -> [Ev]
   -> RAcquire PierEnv ()
-pier (serf, log) vSlog startedSig = do
+pier (serf, log) vSlog startedSig injected = do
   let logId = Log.identity log :: LogIdentity
   let ship  = who logId :: Ship
 
@@ -360,6 +361,29 @@ pier (serf, log) vSlog startedSig = do
   tExec <- acquireWorker "Effects" (router slog (readTQueue executeQ) drivz)
   tDisk <- acquireWorkerBound "Persist" (runPersist log persistQ execute)
 
+  -- Now that the Serf is configured, the IO drivers are hooked up, their
+  -- starting events have been dispatched, and the terminal is live, we can now
+  -- handle injecting events requested from the command line.
+  for_ (zip [1..] injected) $ \(num, ev) -> rio $ do
+    logTrace $ display @Text ("Injecting event " ++ (tshow num) ++ " of " ++
+                              (tshow $ length injected) ++ "...")
+    okaySig :: MVar (Either [Goof] ()) <- newEmptyMVar
+
+    let inject = atomically $ compute $ RRWork $ EvErr ev $ cb
+        cb :: WorkError -> IO ()
+        cb = \case
+          RunOkay _         -> putMVar okaySig (Right ())
+          RunSwap _ _ _ _ _ -> putMVar okaySig (Right ())
+          RunBail goofs     -> putMVar okaySig (Left goofs)
+
+    io inject
+
+    takeMVar okaySig >>= \case
+      Left goof -> logError $ display @Text ("Goof in injected event: " <>
+                                             tshow goof)
+      Right ()  -> pure ()
+
+
   let snapshotEverySecs = 120
 
   void $ acquireWorker "Save" $ forever $ do