king haskell: automatically connect to terminal when running a ship

pkg/hs/king/app/CLI.hs

@@ -83,7 +83,7 @@ data Bug
 
 data Cmd
     = CmdNew New Opts
-    | CmdRun Run Opts
+    | CmdRun Run Opts Bool
     | CmdBug Bug
     | CmdCon FilePath
   deriving (Show)
@@ -267,7 +267,11 @@ runShip :: Parser Cmd
 runShip = do
     rPierPath <- pierPath
     o         <- opts
-    pure (CmdRun (Run{..}) o)
+    daemon    <- switch $ short 'd'
+                         <> long "daemon"
+                         <> help "Daemon mode"
+                         <> hidden
+    pure (CmdRun (Run{..}) o daemon)
 
 valPill :: Parser Bug
 valPill = do

pkg/hs/king/app/Main.hs

@@ -73,7 +73,7 @@ import Control.Concurrent   (myThreadId, runInBoundThread)
 import Control.Exception    (AsyncException(UserInterrupt))
 import Control.Lens         ((&))
 import Data.Default         (def)
-import King.App             (runApp, runAppLogFile, runPierApp)
+import King.App             (runApp, runAppLogFile, runPierApp, runAppNoLog)
 import King.App             (HasConfigDir(..))
 import RIO                  (logSticky, logStickyDone)
 import Text.Show.Pretty     (pPrint)
@@ -149,8 +149,9 @@ tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
                 => Bool -> Pill -> Bool -> Serf.Flags -> Ship
                 -> LegacyBootEvent
                 -> RIO e ()
-tryBootFromPill oExit pill lite flags ship boot =
-    runOrExitImmediately bootedPier oExit
+tryBootFromPill oExit pill lite flags ship boot = do
+    mStart <- newEmptyMVar
+    runOrExitImmediately bootedPier oExit mStart
   where
     bootedPier = do
         view pierPathL >>= lockFile
@@ -164,8 +165,9 @@ runOrExitImmediately :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
                         )
                      => RAcquire e (Serf e, Log.EventLog, SerfState)
                      -> Bool
+                     -> MVar ()
                      -> RIO e ()
-runOrExitImmediately getPier oExit =
+runOrExitImmediately getPier oExit mStart =
     rwith getPier $ if oExit then shutdownImmediately else runPier
   where
     shutdownImmediately (serf, log, ss) = do
@@ -177,15 +179,15 @@ runOrExitImmediately getPier oExit =
         logTrace "Shutdown!"
 
     runPier sls = do
-        runRAcquire $ Pier.pier sls
+        runRAcquire $ Pier.pier sls mStart
 
 tryPlayShip :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
                , HasConfigDir e
                )
-            => Bool -> Bool -> Serf.Flags -> RIO e ()
-tryPlayShip exitImmediately fullReplay flags = do
+            => Bool -> Bool -> Serf.Flags -> MVar ()-> RIO e ()
+tryPlayShip exitImmediately fullReplay flags mStart = do
     when fullReplay wipeSnapshot
-    runOrExitImmediately resumeShip exitImmediately
+    runOrExitImmediately resumeShip exitImmediately mStart
   where
     wipeSnapshot = do
         shipPath <- view pierPathL
@@ -434,17 +436,30 @@ newShip CLI.New{..} opts
     runTryBootFromPill pill name ship bootEvent = do
       let pierConfig = toPierConfig (pierPath name) opts
       let networkConfig = toNetworkConfig opts
-      io $ runPierApp pierConfig networkConfig $
+      io $ runPierApp pierConfig networkConfig True $
         tryBootFromPill True pill nLite flags ship bootEvent
 ------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
 
 
-runShip :: CLI.Run -> CLI.Opts -> IO ()
-runShip (CLI.Run pierPath) opts = do
-    let pierConfig = toPierConfig pierPath opts
-    let networkConfig = toNetworkConfig opts
-    runPierApp pierConfig networkConfig $
-      tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) (toSerfFlags opts)
+
+runShip :: CLI.Run -> CLI.Opts -> Bool -> IO ()
+runShip (CLI.Run pierPath) opts daemon = do
+    tid <- myThreadId
+    let onTermExit = throwTo tid UserInterrupt
+    mStart <- newEmptyMVar
+    if daemon
+    then runPier mStart
+    else do
+      connectionThread <- async $ do
+        readMVar mStart
+        finally (runAppNoLog $ connTerm pierPath) onTermExit
+      finally (runPier mStart) (cancel connectionThread)
+  where
+    runPier mStart =
+          runPierApp pierConfig networkConfig daemon $
+            tryPlayShip (CLI.oExit opts) (CLI.oFullReplay opts) (toSerfFlags opts) mStart
+    pierConfig = toPierConfig pierPath opts
+    networkConfig = toNetworkConfig opts
 
 
 startBrowser :: HasLogFunc e => FilePath -> RIO e ()
@@ -510,7 +525,7 @@ main = do
     terminfoHack
 
     CLI.parseArgs >>= \case
-        CLI.CmdRun r o                          -> runShip r o
+        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

pkg/hs/king/lib/King/App.hs

@@ -3,6 +3,7 @@ module King.App
     , runApp
     , runAppLogFile
     , runAppLogHandle
+    , runAppNoLog
     , runPierApp
     , HasConfigDir(..)
     ) where
@@ -42,16 +43,20 @@ runApp = runAppLogHandle stdout
 
 runAppLogFile :: RIO App a -> IO a
 runAppLogFile inner = withLogFileHandle (\h -> runAppLogHandle h inner)
-  where
-    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
 
+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
+
+runAppNoLog :: RIO App a -> IO a
+runAppNoLog act =
+    withFile "/dev/null" AppendMode $ \handle ->
+        runAppLogHandle handle act
 
 --------------------------------------------------------------------------------
 
@@ -76,16 +81,20 @@ instance HasNetworkConfig PierApp where
 instance HasConfigDir PierApp where
     configDirL = pierAppPierConfig . pcPierPath
 
-runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> IO a
-runPierApp pierConfig networkConfig inner = do
-    logOptions <- logOptionsHandle stdout True
-        <&> setLogUseTime True
-        <&> setLogUseLoc False
-
-    withLogFunc logOptions $ \logFunc ->
-        go $ PierApp { _pierAppLogFunc = logFunc
-                     , _pierAppPierConfig = pierConfig
-                     , _pierAppNetworkConfig = networkConfig
-                     }
+runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a
+runPierApp pierConfig networkConfig daemon inner =
+    if daemon
+    then exec stderr
+    else withLogFileHandle exec
   where
+    exec logHandle = do
+        logOptions <- logOptionsHandle logHandle True
+            <&> setLogUseTime True
+            <&> setLogUseLoc False
+
+        withLogFunc logOptions $ \logFunc ->
+            go $ PierApp { _pierAppLogFunc = logFunc
+                         , _pierAppPierConfig = pierConfig
+                         , _pierAppNetworkConfig = networkConfig
+                         }
     go app = runRIO app inner

pkg/hs/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/hs/king/lib/Vere/Pier.hs

@@ -144,8 +144,9 @@ acquireWorker act = mkRAcquire (async act) cancel
 
 pier :: ∀e. (HasConfigDir e, HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
      => (Serf e, EventLog, SerfState)
+     -> MVar ()
      -> RAcquire e ()
-pier (serf, log, ss) = do
+pier (serf, log, ss) mStart = do
     computeQ  <- newTQueueIO
     persistQ  <- newTQueueIO
     executeQ  <- newTQueueIO
@@ -213,6 +214,8 @@ pier (serf, log, ss) = do
 
     tSaveSignal <- saveSignalThread saveM
 
+    putMVar mStart ()
+
     -- Wait for something to die.
 
     let ded = asum [ death "effect thread" tExe

pkg/hs/king/lib/Vere/Serf.hs

@@ -367,7 +367,7 @@ updateProgressBar count startMsg = \case
       -- 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.
-      putStrLn startMsg
+      logTrace $ display startMsg
       let style = defStyle { stylePostfix = exact }
       pb <- newProgressBar style 10 (Progress 0 count ())
       pure (Just pb)