king: Misc Small Cleanup.

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

@@ -31,7 +31,7 @@ import Data.Conduit
 import Data.Text              (append)
 import System.Posix.Files     (ownerModes, setFileMode)
 import Urbit.King.App         (HasConfigDir(..), HasStderrLogFunc(..))
-import Urbit.Time             (Wen)
+-- ort Urbit.Time             (Wen)
 import Urbit.Vere.Ames        (ames)
 import Urbit.Vere.Behn        (behn)
 import Urbit.Vere.Clay        (clay)
@@ -49,7 +49,7 @@ 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
-import qualified Data.Conduit.Combinators as CC
+-- ort qualified Data.Conduit.Combinators as CC
 
 
 --------------------------------------------------------------------------------
@@ -275,15 +275,18 @@ pier (serf, log) vStderr mStart = do
 
     let stubErrCallback = \_ -> pure ()
 
-    tExe  <- startDrivers >>= router (readTQueue executeQ)
+    let computeConfig = ComputeConfig
-    tDisk <- runPersist log persistQ (writeTQueue executeQ)
+          { ccOnWork = (,stubErrCallback) <$> readTQueue computeQ
-    tCpu  <- runCompute serf
+          , ccOnKill = takeTMVar shutdownM
-               ((,stubErrCallback) <$> readTQueue computeQ)
+          , ccOnSave = takeTMVar saveM
-               (takeTMVar saveM)
+          , ccPutResult = writeTQueue persistQ
-               (takeTMVar shutdownM)
+          , ccShowSpinner = Term.spin muxed
-               (Term.spin muxed)
+          , ccHideSpinner = Term.stopSpin muxed
-               (Term.stopSpin muxed)
+          }
-               (writeTQueue persistQ)
+
+    tExe  <- startDrivers >>= acquireWorker . router (readTQueue executeQ)
+    tDisk <- acquireWorkerBound (runPersist log persistQ (writeTQueue executeQ))
+    tCpu  <- acquireWorker (runCompute serf computeConfig)
 
     tSaveSignal <- saveSignalThread saveM
 
@@ -359,17 +362,14 @@ drivers inst who isFake plan shutdownSTM termSys stderr =
 
 -- Route Effects to Drivers ----------------------------------------------------
 
-router :: HasLogFunc e => STM FX -> Drivers e -> RAcquire e (Async ())
+router :: HasLogFunc e => STM FX -> Drivers e -> RIO e ()
-router waitFx Drivers{..} =
+router waitFx Drivers {..} = forever $ do
-    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 (EfVega _ _              ) -> error "TODO"
-              GoodParse (EfExit _ _)               -> error "TODO"
+      GoodParse (EfExit _ _              ) -> error "TODO"
       GoodParse (EfVane (VEAmes       ef)) -> dAmes ef
       GoodParse (EfVane (VEBehn       ef)) -> dBehn ef
       GoodParse (EfVane (VEBoat       ef)) -> dSync ef
@@ -379,9 +379,7 @@ router waitFx Drivers{..} =
       GoodParse (EfVane (VENewt       ef)) -> dNewt ef
       GoodParse (EfVane (VESync       ef)) -> dSync ef
       GoodParse (EfVane (VETerm       ef)) -> dTerm ef
-              FailParse n                          -> logError
+      FailParse n -> logError $ display $ pack @Text (ppShow n)
-                                                    $ display
-                                                    $ pack @Text (ppShow n)
 
 
 -- Compute Thread --------------------------------------------------------------
@@ -407,29 +405,6 @@ data ComputeRequest
     | CRSave ()
     | CRShutdown ()
 
-runCompute
-  :: forall e
-   . HasLogFunc e
-  => Serf
-  -> STM (Ev, Serf.RunError -> IO ())
-  -> STM ()
-  -> STM ()
-  -> (Maybe Text -> STM ())
-  -> STM ()
-  -> ((Fact, FX) -> STM ())
-  -> RAcquire e (Async ())
-runCompute serf getEvent getSaveSignal getShutdownSignal showSpinner hideSpinner putResult = do
-  acquireWorker (newRunCompute serf config)
- where
-  config = ComputeConfig
-    { ccOnWork = getEvent
-    , ccOnKill = getShutdownSignal
-    , ccOnSave = getSaveSignal
-    , ccPutResult = putResult
-    , ccShowSpinner = showSpinner
-    , ccHideSpinner = hideSpinner
-    }
-
 {-
   TODO Pack and Peek
 -}
@@ -460,17 +435,6 @@ ipcSource onEvent onSave onKill = loop
         yield (Serf.RunWork ev cb)
         loop
 
-fromRightErr :: Either a b -> IO b
-fromRightErr (Left l) = error "unexpected Left value"
-fromRightErr (Right r) = pure r
-
-data Fact = Fact
-  { factEve :: EventId
-  , factMug :: Mug
-  , factWen :: Wen
-  , factNon :: Noun
-  }
-
 data ComputeConfig = ComputeConfig
   { ccOnWork :: STM (Ev, Serf.RunError -> IO ())
   , ccOnKill :: STM ()
@@ -480,10 +444,10 @@ data ComputeConfig = ComputeConfig
   , ccHideSpinner :: STM ()
   }
 
-newRunCompute
+runCompute
   :: forall e . HasLogFunc e => Serf.Serf -> ComputeConfig -> RIO e ()
-newRunCompute serf ComputeConfig {..} = do
+runCompute serf ComputeConfig {..} = do
-  logTrace "newRunCompute"
+  logTrace "runCompute"
   runConduit
     $  ipcSource ccOnWork ccOnSave ccOnKill
     .| Serf.running serf (atomically . onStatusChange)
@@ -493,7 +457,7 @@ newRunCompute serf ComputeConfig {..} = do
   sendResults = await >>= \case
     Nothing                               -> pure ()
     Just (Serf.RunOutput e m w nounEv fx) -> do
-      lift $ logTrace "newRunCompute: Got play result"
+      lift $ logTrace "runCompute: Got play result"
       atomically $ ccPutResult (Fact e m w nounEv, GoodParse <$> fx) -- TODO GoodParse
       sendResults
 
@@ -521,11 +485,8 @@ runPersist
   => EventLog
   -> TQueue (Fact, FX)
   -> (FX -> STM ())
-  -> RAcquire e (Async ())
+  -> RIO e ()
-runPersist log inpQ out = mkRAcquire runThread cancel
+runPersist log inpQ out = do
- where
-  runThread :: RIO e (Async ())
-  runThread = asyncBound $ do
   dryRun <- view dryRunL
   forever $ do
     writs  <- atomically getBatchFromQueue
@@ -534,6 +495,7 @@ runPersist log inpQ out = mkRAcquire runThread cancel
     atomically $ for_ writs $ \(_, fx) -> do
       out fx
 
+ where
   validateFactsAndGetBytes :: [Fact] -> RIO e (Vector ByteString)
   validateFactsAndGetBytes facts = do
     expect <- Log.nextEv log

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

@@ -95,6 +95,13 @@ data IODriver = IODriver
     , startDriver :: (Ev -> STM ()) -> IO (Async (), Perform)
     }
 
+data Fact = Fact
+  { factEve :: EventId
+  , factMug :: Mug
+  , factWen :: Wen
+  , factNon :: Noun
+  }
+
 
 -- Instances -------------------------------------------------------------------
 

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

@@ -1,46 +1,27 @@
-{-# OPTIONS_GHC -Wwarn #-}
-
 {-|
-    Serf Interface
+  High-Level Serf Interface
-
-    TODO: `recvLen` is not big-endian safe.
 -}
 
 module Urbit.Vere.Serf
   ( module Urbit.Vere.Serf.IPC
   , withSerf
   , execReplay
-  , shutdown
-  , snapshot
   )
 where
 
 import Urbit.Prelude
 
 import Data.Conduit
-import System.Process
+-- ort System.ProgressBar
-import System.ProgressBar
+-- ort Urbit.Arvo
-import Urbit.Arvo
 import Urbit.Vere.Pier.Types
 import Urbit.Vere.Serf.IPC
-import System.Posix.Signals
 
-import Data.Bits              (setBit)
+-- ort Urbit.King.App         (HasStderrLogFunc(..))
-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 qualified Data.ByteString.Unsafe   as BS
 import qualified Data.Conduit.Combinators as CC
-import qualified Data.Text                as T
+-- ort qualified Urbit.Ob                 as Ob
-import qualified System.IO                as IO
+-- ort qualified Urbit.Time               as Time
-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