Pulled in and integrated a commit from my king-daemon branch.

pkg/king/app/Main.hs

@@ -72,7 +72,7 @@ import Control.Concurrent   (myThreadId, runInBoundThread)
 import Control.Exception    (AsyncException(UserInterrupt))
 import Control.Lens         ((&))
 import Data.Default         (def)
-import KingApp              (runApp, runPierApp)
+import King.App             (runApp, runPierApp)
 import System.Environment   (getProgName)
 import System.Posix.Signals (Handler(Catch), installHandler, sigTERM)
 import System.Random        (randomIO)
@@ -125,29 +125,28 @@ toSerfFlags CLI.Opts{..} = catMaybes m
 
 toPierConfig :: FilePath -> CLI.Opts -> PierConfig
 toPierConfig pierPath CLI.Opts{..} = PierConfig
-  { pcPierPath = pierPath
-  , pcDryRun = oDryRun
-  }
+    { _pcPierPath = pierPath
+    , _pcDryRun   = oDryRun
+    }
 
 toNetworkConfig :: CLI.Opts -> NetworkConfig
 toNetworkConfig CLI.Opts{..} = NetworkConfig
-  { ncNetworking = if oDryRun then NetworkNone
-                   else if oOffline then NetworkNone
-                   else if oLocalhost then NetworkLocalhost
-                   else NetworkNormal
-  , ncAmesPort = oAmesPort
-  }
+    { ncNetworking = if oDryRun then NetworkNone
+                     else if oOffline then NetworkNone
+                     else if oLocalhost then NetworkLocalhost
+                     else NetworkNormal
+    , ncAmesPort = oAmesPort
+    }
 
 tryBootFromPill :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
                 => Bool -> Pill -> Bool -> Serf.Flags -> Ship
                 -> LegacyBootEvent
                 -> RIO e ()
 tryBootFromPill oExit pill lite flags ship boot =
-  do
     runOrExitImmediately bootedPier oExit
   where
     bootedPier = do
-        getPierPath >>= lockFile
+        view pierPathL >>= lockFile
         rio $ logTrace "Starting boot"
         sls <- Pier.booted pill lite flags ship boot
         rio $ logTrace "Completed boot"
@@ -158,7 +157,6 @@ runOrExitImmediately :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
                      -> Bool
                      -> RIO e ()
 runOrExitImmediately getPier oExit =
-  do
     rwith getPier $ if oExit then shutdownImmediately else runPier
   where
     shutdownImmediately (serf, log, ss) = do
@@ -174,14 +172,12 @@ runOrExitImmediately getPier oExit =
 
 tryPlayShip :: (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
             => Bool -> Bool -> Serf.Flags -> RIO e ()
-tryPlayShip exitImmediately fullReplay flags =
-  do
-    when fullReplay $ do
-      wipeSnapshot
+tryPlayShip exitImmediately fullReplay flags = do
+    when fullReplay wipeSnapshot
     runOrExitImmediately resumeShip exitImmediately
   where
     wipeSnapshot = do
-        shipPath <- getPierPath
+        shipPath <- view pierPathL
         logTrace "wipeSnapshot"
         logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
         logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
@@ -192,7 +188,7 @@ tryPlayShip exitImmediately fullReplay flags =
     south shipPath = shipPath <> "/.urb/chk/south.bin"
 
     resumeShip = do
-        getPierPath >>= lockFile
+        view pierPathL >>= lockFile
         rio $ logTrace "RESUMING SHIP"
         sls <- Pier.resumed flags
         rio $ logTrace "SHIP RESUMED"

pkg/king/lib/Config.hs

@@ -2,25 +2,25 @@ module Config where
 
 import UrbitPrelude
 
--- 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
+    } deriving (Show)
+
+makeLenses ''PierConfig
 
 class HasPierConfig env where
     pierConfigL :: Lens' env PierConfig
 
-getPierPath :: (MonadReader env m, HasPierConfig env) => m FilePath
-getPierPath = do
-  PierConfig{..} <- view pierConfigL
-  pure pcPierPath
+pierPathL ∷ HasPierConfig a => Lens' a FilePath
+pierPathL = pierConfigL . pcPierPath
 
-getIsDryRun :: (MonadReader env m, HasPierConfig env) => m Bool
-getIsDryRun = do
-  PierConfig{..} <- view pierConfigL
-  pure pcDryRun
+dryRunL :: HasPierConfig a => Lens' a Bool
+dryRunL = pierConfigL . pcDryRun
 
 -------------------------------------------------------------------------------
 

pkg/king/lib/King/API.hs

@@ -0,0 +1,128 @@
+module King.API (kingAPI, readPortsFile) where
+
+import UrbitPrelude
+import Data.Aeson
+import RIO.Directory
+
+import King.App       (HasConfigDir(..))
+import Network.Socket (Socket)
+import Prelude        (read)
+import Vere.LockFile  (lockFile)
+
+import qualified Network.HTTP.Types             as H
+import qualified Network.Wai                    as W
+import qualified Network.Wai.Handler.Warp       as W
+import qualified Network.Wai.Handler.WebSockets as WS
+import qualified Network.WebSockets             as WS
+import qualified Urbit.Ob                       as Ob
+
+
+-- Types -----------------------------------------------------------------------
+
+{-
+    Daemon state.
+-}
+data King = King
+    { kServer :: Async ()
+    }
+
+data ShipStatus = Halted | Booting | Booted | Running | LandscapeUp
+  deriving (Generic, ToJSON, FromJSON)
+
+data KingStatus = Starting | Started
+  deriving (Generic, ToJSON, FromJSON)
+
+data StatusResp = StatusResp
+    { king  :: KingStatus
+    , ships :: Map Text ShipStatus
+    }
+  deriving (Generic, ToJSON, FromJSON)
+
+
+--------------------------------------------------------------------------------
+
+{-
+    Get the filepath of the urbit config directory and the ports file.
+-}
+portsFilePath :: HasConfigDir e => RIO e (FilePath, FilePath)
+portsFilePath = do
+    dir <- view configDirL
+    fil <- pure (dir </> ".king.ports")
+    pure (dir, fil)
+
+{-
+    Write the ports file.
+-}
+portsFile :: HasConfigDir e => Word -> RAcquire e (FilePath, FilePath)
+portsFile por =
+    mkRAcquire mkFile (removeFile . snd)
+  where
+    mkFile = do
+        (dir, fil) <- portsFilePath
+        createDirectoryIfMissing True dir
+        writeFile fil (encodeUtf8 $ tshow por)
+        pure (dir, fil)
+
+{-
+    Get the HTTP port for the running Urbit daemon.
+-}
+readPortsFile :: HasConfigDir e => RIO e (Maybe Word)
+readPortsFile = do
+    (_, fil) <- portsFilePath
+    bs <- readFile fil
+    evaluate (read $ unpack $ decodeUtf8 bs)
+
+kingServer :: HasLogFunc e => (Int, Socket) -> RAcquire e King
+kingServer is =
+    mkRAcquire (startKing is) (cancel . kServer)
+  where
+    startKing :: HasLogFunc e => (Int, Socket) -> RIO e King
+    startKing (port, sock) = do
+        let opts = W.defaultSettings & W.setPort port
+        tid <- async $ io $ W.runSettingsSocket opts sock $ app
+        pure (King tid)
+
+{-
+    Start the HTTP server and write to the ports file.
+-}
+kingAPI :: (HasConfigDir e, HasLogFunc e)
+        => RAcquire e King
+kingAPI = do
+    (port, sock) <- io $ W.openFreePort
+    (dir, fil)   <- portsFile (fromIntegral port)
+    lockFile dir
+    kingServer (port, sock)
+
+stubStatus :: StatusResp
+stubStatus = StatusResp Started $ mapFromList [("zod", Running)]
+
+serveTerminal :: Ship -> Word -> W.Application
+serveTerminal ship word =
+    WS.websocketsOr WS.defaultConnectionOptions placeholderWSApp fallback
+  where
+    fallback req respond =
+        respond $ W.responseLBS H.status500 []
+                $ "This endpoint uses websockets"
+
+placeholderWSApp :: WS.ServerApp
+placeholderWSApp _ = pure ()
+
+data BadShip = BadShip Text
+  deriving (Show, Exception)
+
+readShip :: Text -> IO Ship
+readShip t = Ob.parsePatp t & \case
+     Left err -> throwIO (BadShip t)
+     Right pp -> pure $ Ship $ fromIntegral $ Ob.fromPatp pp
+
+app :: W.Application
+app req respond =
+    case W.pathInfo req of
+        ["terminal", ship, session] -> do
+            session :: Word <- evaluate $ read $ unpack session
+            ship <- readShip ship
+            serveTerminal ship session req respond
+        ["status"] ->
+            respond $ W.responseLBS H.status200 [] $ encode stubStatus
+        _ ->
+            respond $ W.responseLBS H.status404 [] "No implemented"

pkg/king/lib/King/App.hs

@@ -0,0 +1,72 @@
+module King.App
+    ( App
+    , runApp
+    , runPierApp
+    , HasConfigDir(..)
+    ) where
+
+import Config
+import UrbitPrelude
+
+--------------------------------------------------------------------------------
+
+class HasConfigDir a where
+    configDirL ∷ Lens' a FilePath
+
+data App = App
+    { _appLogFunc :: !LogFunc
+    }
+
+makeLenses ''App
+
+instance HasLogFunc App where
+    logFuncL = appLogFunc
+
+runApp :: RIO App a -> IO a
+runApp inner = do
+    logOptions <- logOptionsHandle stderr True
+        <&> setLogUseTime True
+        <&> setLogUseLoc False
+
+    withLogFunc logOptions $ \logFunc ->
+        go (App logFunc)
+  where
+    go app = runRIO app inner
+
+
+--------------------------------------------------------------------------------
+
+-- A PierApp is like an App, except that it also provides a PierConfig
+data PierApp = PierApp
+    { _pierAppLogFunc       :: !LogFunc
+    , _pierAppPierConfig    :: !PierConfig
+    , _pierAppNetworkConfig :: !NetworkConfig
+    }
+
+makeLenses ''PierApp
+
+instance HasLogFunc PierApp where
+    logFuncL = pierAppLogFunc
+
+instance HasPierConfig PierApp where
+    pierConfigL = pierAppPierConfig
+
+instance HasNetworkConfig PierApp where
+    networkConfigL = pierAppNetworkConfig
+
+instance HasConfigDir PierApp where
+    configDirL = pierAppPierConfig . pcPierPath
+
+runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> IO a
+runPierApp pierConfig networkConfig inner = do
+    logOptions <- logOptionsHandle stderr True
+        <&> setLogUseTime True
+        <&> setLogUseLoc False
+
+    withLogFunc logOptions $ \logFunc ->
+        go $ PierApp { _pierAppLogFunc = logFunc
+                     , _pierAppPierConfig = pierConfig
+                     , _pierAppNetworkConfig = networkConfig
+                     }
+  where
+    go app = runRIO app inner

pkg/king/lib/KingApp.hs

@@ -1,92 +0,0 @@
-module KingApp
-    ( App
-    , runApp
-    , runPierApp
-    , HasAppName(..)
-    ) where
-
-import Config
-import RIO.Directory
-import UrbitPrelude
-
---------------------------------------------------------------------------------
-
-class HasAppName env where
-    appNameL :: Lens' env Utf8Builder
-
-data App = App
-    { _appLogFunc :: !LogFunc
-    , _appName    :: !Utf8Builder
-    }
-
-makeLenses ''App
-
-instance HasLogFunc App where
-    logFuncL = appLogFunc
-
-instance HasAppName App where
-    appNameL = appName
-
-withLogFileHandle :: (Handle -> IO a) -> IO a
-withLogFileHandle act = do
-    home <- getHomeDirectory
-    let logDir = home <> "/log"
-    createDirectoryIfMissing True logDir
-    withTempFile logDir "king-" $ \_tmpFile handle -> do
-        hSetBuffering handle LineBuffering
-        act handle
-
-runApp :: RIO App a -> IO a
-runApp inner = do
-    withLogFileHandle $ \logFile -> do
-        logOptions <- logOptionsHandle stderr True
-            <&> setLogUseTime True
-            <&> setLogUseLoc False
-
-        withLogFunc logOptions $ \logFunc ->
-            go $ App { _appLogFunc = logFunc
-                     , _appName    = "Vere"
-                     }
-  where
-    go app = runRIO app inner
-
-
---------------------------------------------------------------------------------
-
--- A PierApp is like an App, except that it also provides a PierConfig
-data PierApp = PierApp
-    { _shipAppLogFunc       :: !LogFunc
-    , _shipAppName          :: !Utf8Builder
-    , _shipAppPierConfig    :: !PierConfig
-    , _shipAppNetworkConfig :: !NetworkConfig
-    }
-
-makeLenses ''PierApp
-
-instance HasLogFunc PierApp where
-    logFuncL = shipAppLogFunc
-
-instance HasAppName PierApp where
-    appNameL = shipAppName
-
-instance HasPierConfig PierApp where
-    pierConfigL = shipAppPierConfig
-
-instance HasNetworkConfig PierApp where
-    networkConfigL = shipAppNetworkConfig
-
-runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> IO a
-runPierApp pierConfig networkConfig inner = do
-    withLogFileHandle $ \logFile -> do
-        logOptions <- logOptionsHandle stderr True
-            <&> setLogUseTime True
-            <&> setLogUseLoc False
-
-        withLogFunc logOptions $ \logFunc ->
-            go $ PierApp { _shipAppLogFunc = logFunc
-                         , _shipAppName    = "Vere"
-                         , _shipAppPierConfig = pierConfig
-                         , _shipAppNetworkConfig = networkConfig
-                         }
-  where
-    go app = runRIO app inner

pkg/king/lib/Vere/Clay.hs

@@ -117,7 +117,7 @@ clay king enqueueEv =
     handleEffect cd = \case
       SyncEfHill _ mountPoints -> do
         logDebug $ displayShow ("(clay) known mount points:", mountPoints)
-        pierPath <- getPierPath
+        pierPath <- view pierPathL
         mountPairs <- flip mapM mountPoints $ \desk -> do
           ss <- takeFilesystemSnapshot (pierPath </> (deskToPath desk))
           pure (desk, ss)
@@ -127,7 +127,7 @@ clay king enqueueEv =
         logDebug $ displayShow ("(clay) dirk:", p, desk)
         m <- atomically $ readTVar (cdMountPoints cd)
         let snapshot = M.findWithDefault M.empty desk m
-        pierPath <- getPierPath
+        pierPath <- view pierPathL
         let dir = pierPath </> deskToPath desk
         actions <- buildActionListFromDifferences dir snapshot
 
@@ -147,7 +147,7 @@ clay king enqueueEv =
         m <- atomically $ readTVar (cdMountPoints cd)
         let mountPoint = M.findWithDefault M.empty desk m
 
-        pierPath <- getPierPath
+        pierPath <- view pierPathL
         let dir = pierPath </> deskToPath desk
         let hashedActions = map (calculateActionHash dir) actions
         for_ hashedActions (performAction mountPoint)
@@ -158,7 +158,7 @@ clay king enqueueEv =
 
       SyncEfOgre p desk -> do
         logDebug $ displayShow ("(clay) ogre:", p, desk)
-        pierPath <- getPierPath
+        pierPath <- view pierPathL
         removeDirectoryRecursive $ pierPath </> deskToPath desk
         atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
 

pkg/king/lib/Vere/Http/Server.hs

@@ -429,7 +429,7 @@ startServ conf plan = do
                       $ W.runTLSSocket tlsOpts httpsOpts httpsSock
                       $ app env sId liv plan Secure
 
-  pierPath <- getPierPath
+  pierPath <- view pierPathL
   let por = Ports (tls <&> const httpsPort) httpPort loopPort
       fil = pierPath <> "/.http.ports"
 

pkg/king/lib/Vere/Pier.hs

@@ -95,7 +95,7 @@ booted pill lite flags ship boot = do
 
   rio $ logTrace "BootSeq Computed"
 
-  pierPath <- getPierPath
+  pierPath <- view pierPathL
 
   liftRIO (setupPierDirectory pierPath)
 
@@ -125,7 +125,7 @@ resumed :: (HasPierConfig e, HasLogFunc e)
         => Serf.Flags
         -> RAcquire e (Serf e, EventLog, SerfState)
 resumed flags = do
-    top    <- getPierPath
+    top    <- view pierPathL
     log    <- Log.existing (top <> "/.urb/log")
     serf   <- Serf.run (Serf.Config top flags)
     serfSt <- rio $ Serf.replay serf log
@@ -394,7 +394,7 @@ runPersist log inpQ out =
   where
     runThread :: RIO e (Async ())
     runThread = asyncBound $ do
-        dryRun <- getIsDryRun
+        dryRun <- view dryRunL
         forever $ do
             writs  <- atomically getBatchFromQueue
             unless dryRun $ do

pkg/king/lib/Vere/Term.hs

@@ -559,7 +559,7 @@ term (tsize, Client{..}) shutdownSTM king enqueueEv =
 
     performPut :: Path -> ByteString -> RIO e ()
     performPut path bs = do
-      pierPath <- getPierPath
+      pierPath <- view pierPathL
       let putOutFile = pierPath </> ".urb" </> "put" </> (pathToFilePath path)
       createDirectoryIfMissing True (takeDirectory putOutFile)
       writeFile putOutFile bs

pkg/king/package.yaml

@@ -28,6 +28,7 @@ tests:
       - -with-rtsopts=-N
 
 dependencies:
+  - aeson
   - async
   - base
   - base-unicode-symbols
@@ -105,6 +106,7 @@ dependencies:
   - vector
   - wai
   - wai-conduit
+  - wai-websockets
   - warp
   - warp-tls
   - web3

pkg/king/test/BehnTests.hs

@@ -19,7 +19,7 @@ import Vere.Pier.Types
 import Control.Concurrent (runInBoundThread, threadDelay)
 import Data.LargeWord     (LargeKey(..))
 import GHC.Natural        (Natural)
-import KingApp            (runApp)
+import King.App           (runApp)
 import Network.Socket     (tupleToHostAddress)
 
 import qualified Urbit.Time as Time

pkg/king/test/LogTests.hs

@@ -14,7 +14,7 @@ import Data.Conduit.List hiding (filter)
 import Control.Concurrent (runInBoundThread, threadDelay)
 import Data.LargeWord     (LargeKey(..))
 import GHC.Natural        (Natural)
-import KingApp            (runApp, App)
+import King.App           (App, runApp)
 
 import qualified Vere.Log as Log