From b5c24eeadb034d1bc5ac2d731441084574a81c2c Mon Sep 17 00:00:00 2001 From: Isaac Visintainer Date: Fri, 10 Jan 2020 16:39:31 -0800 Subject: [PATCH] king haskell: automatically connect to terminal when running a ship --- pkg/hs/king/app/CLI.hs | 8 +++- pkg/hs/king/app/Main.hs | 47 +++++++++++------- pkg/hs/king/lib/King/App.hs | 49 +++++++++++-------- pkg/hs/king/lib/KingApp.hs | 92 ------------------------------------ pkg/hs/king/lib/Vere/Pier.hs | 5 +- pkg/hs/king/lib/Vere/Serf.hs | 2 +- 6 files changed, 71 insertions(+), 132 deletions(-) delete mode 100644 pkg/hs/king/lib/KingApp.hs diff --git a/pkg/hs/king/app/CLI.hs b/pkg/hs/king/app/CLI.hs index 6112b414b..21608ed3e 100644 --- a/pkg/hs/king/app/CLI.hs +++ b/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 diff --git a/pkg/hs/king/app/Main.hs b/pkg/hs/king/app/Main.hs index 4b4c80cf6..126b6832d 100644 --- a/pkg/hs/king/app/Main.hs +++ b/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 diff --git a/pkg/hs/king/lib/King/App.hs b/pkg/hs/king/lib/King/App.hs index 3fe76a10f..61bf4179e 100644 --- a/pkg/hs/king/lib/King/App.hs +++ b/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 diff --git a/pkg/hs/king/lib/KingApp.hs b/pkg/hs/king/lib/KingApp.hs deleted file mode 100644 index 9e5c3fd44..000000000 --- a/pkg/hs/king/lib/KingApp.hs +++ /dev/null @@ -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 diff --git a/pkg/hs/king/lib/Vere/Pier.hs b/pkg/hs/king/lib/Vere/Pier.hs index 62f96f320..0d718236e 100644 --- a/pkg/hs/king/lib/Vere/Pier.hs +++ b/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 diff --git a/pkg/hs/king/lib/Vere/Serf.hs b/pkg/hs/king/lib/Vere/Serf.hs index 3bc0658d0..07c52364c 100644 --- a/pkg/hs/king/lib/Vere/Serf.hs +++ b/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)