king: Use same logger from all contexts.

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

@@ -3,7 +3,7 @@
 -}
 module Urbit.King.App
     ( App
-    , runApp
+    , runAppStderr
     , runAppLogFile
     , runAppNoLog
     , runPierApp
@@ -39,8 +39,8 @@ instance HasLogFunc App where
 instance HasStderrLogFunc App where
     stderrLogFuncL = appStderrLogFunc
 
-runApp :: RIO App a -> IO a
+runAppStderr :: RIO App a -> IO a
-runApp inner = do
+runAppStderr inner = do
     logOptions <- logOptionsHandle stderr True
         <&> setLogUseTime True
         <&> setLogUseLoc False
@@ -105,36 +105,14 @@ instance HasNetworkConfig PierApp where
 instance HasConfigDir PierApp where
     configDirL = pierAppPierConfig . pcPierPath
 
-runPierApp :: PierConfig -> NetworkConfig -> Bool -> RIO PierApp a -> IO a
+runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> RIO App a
-runPierApp pierConfig networkConfig daemon inner =
+runPierApp pierConfig networkConfig action = do
-    if daemon
+  app <- ask
-    then execStderr
-    else withLogFileHandle execFile
-  where
-    execStderr = do
-        logOptions <- logOptionsHandle stderr True
-            <&> setLogUseTime True
-            <&> setLogUseLoc False
 
-        withLogFunc logOptions $ \logFunc ->
+  let pierApp = PierApp { _pierAppLogFunc       = app ^. logFuncL
-            go $ PierApp { _pierAppLogFunc = logFunc
+                        , _pierAppStderrLogFunc = app ^. stderrLogFuncL
-                         , _pierAppStderrLogFunc = logFunc
+                        , _pierAppPierConfig    = pierConfig
-                         , _pierAppPierConfig = pierConfig
+                        , _pierAppNetworkConfig = networkConfig
-                         , _pierAppNetworkConfig = networkConfig
+                        }
-                         }
 
-    execFile logHandle = do
+  io (runRIO pierApp action)
-        logOptions <- logOptionsHandle logHandle True
-            <&> setLogUseTime True
-            <&> setLogUseLoc False
-        logStderrOptions <- logOptionsHandle stderr True
-            <&> setLogUseTime False
-            <&> setLogUseLoc False
-        withLogFunc logStderrOptions $ \logStderr ->
-          withLogFunc logOptions $ \logFunc ->
-              go $ PierApp { _pierAppLogFunc = logFunc
-                           , _pierAppStderrLogFunc = logStderr
-                           , _pierAppPierConfig = pierConfig
-                           , _pierAppNetworkConfig = networkConfig
-                           }
-    go app = runRIO app inner

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

@@ -92,7 +92,7 @@ import Control.Lens           ((&))
 import System.Process         (system)
 import Text.Show.Pretty       (pPrint)
 import Urbit.King.App         (App)
-import Urbit.King.App         (runApp, runAppLogFile, runAppNoLog, runPierApp)
+import Urbit.King.App         (runAppLogFile, runAppStderr, runPierApp)
 import Urbit.King.App         (HasConfigDir(..), HasStderrLogFunc(..))
 import Urbit.Noun.Conversions (cordToUW)
 import Urbit.Time             (Wen)
@@ -437,14 +437,22 @@ pillFrom (CLI.PillSourceURL url) = do
   noun <- cueBS body & either throwIO pure
   fromNounErr noun & either (throwIO . uncurry ParseErr) pure
 
-newShip :: forall e. HasLogFunc e => CLI.New -> CLI.Opts -> RIO e ()
+newShip :: CLI.New -> CLI.Opts -> RIO App ()
-newShip new opts = do
+newShip CLI.New{..} opts = do
-  multi <- multiEyre (MultiEyreConf Nothing Nothing True) -- TODO Hack
+  {-
-  newShip' multi new opts
+    TODO XXX HACK
 
-newShip' :: forall e. HasLogFunc e => MultiEyreApi -> CLI.New -> CLI.Opts -> RIO e ()
+    Because the "new ship" flow *may* automatically start the ship,
-newShip' multi CLI.New{..} opts
+    we need to create this, but it's not actually correct.
-  | CLI.BootComet <- nBootType = do
+
+    The right solution is to separate out the "new ship" flow from the
+    "run ship" flow, and possibly sequence them from the outside if
+    that's really needed.
+  -}
+  multi <- multiEyre (MultiEyreConf Nothing Nothing True)
+
+  case nBootType of
+    CLI.BootComet -> do
       pill <- pillFrom nPillSource
       putStrLn "boot: retrieving list of stars currently accepting comets"
       starList <- dawnCometList
@@ -454,14 +462,14 @@ newShip' multi CLI.New{..} opts
       eny <- io $ Sys.randomIO
       let seed = mineComet (Set.fromList starList) eny
       putStrLn ("boot: found comet " ++ renderShip (sShip seed))
-      bootFromSeed pill seed
+      bootFromSeed multi pill seed
 
-  | CLI.BootFake name <- nBootType = do
+    CLI.BootFake name -> do
       pill <- pillFrom nPillSource
       ship <- shipFrom name
-      runTryBootFromPill pill name ship (Fake ship)
+      runTryBootFromPill multi pill name ship (Fake ship)
 
-  | CLI.BootFromKeyfile keyFile <- nBootType = do
+    CLI.BootFromKeyfile keyFile -> do
       text <- readFileUtf8 keyFile
       asAtom <- case cordToUW (Cord $ T.strip text) of
         Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
@@ -474,10 +482,10 @@ newShip' multi CLI.New{..} opts
 
       pill <- pillFrom nPillSource
 
-      bootFromSeed pill seed
+      bootFromSeed multi pill seed
 
   where
-    shipFrom :: Text -> RIO e Ship
+    shipFrom :: Text -> RIO App Ship
     shipFrom name = case Ob.parsePatp name of
       Left x  -> error "Invalid ship name"
       Right p -> pure $ Ship $ fromIntegral $ Ob.fromPatp p
@@ -487,7 +495,7 @@ newShip' multi CLI.New{..} opts
       Just x  -> x
       Nothing -> "./" <> unpack name
 
-    nameFromShip :: Ship -> RIO e Text
+    nameFromShip :: Ship -> RIO App Text
     nameFromShip s = name
       where
         nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
@@ -495,8 +503,8 @@ newShip' multi CLI.New{..} opts
           Nothing -> error "Urbit.ob didn't produce string with ~"
           Just x  -> pure x
 
-    bootFromSeed :: Pill -> Seed -> RIO e ()
+    bootFromSeed :: MultiEyreApi -> Pill -> Seed -> RIO App ()
-    bootFromSeed pill seed = do
+    bootFromSeed multi pill seed = do
       ethReturn <- dawnVent seed
 
       case ethReturn of
@@ -504,23 +512,22 @@ newShip' multi CLI.New{..} opts
         Right dawn -> do
           let ship = sShip $ dSeed dawn
           name <- nameFromShip ship
-          runTryBootFromPill pill name ship (Dawn dawn)
+          runTryBootFromPill multi pill name ship (Dawn dawn)
 
     flags = toSerfFlags opts
 
     -- Now that we have all the information for running an application with a
     -- PierConfig, do so.
-    runTryBootFromPill pill name ship bootEvent = do
+    runTryBootFromPill multi pill name ship bootEvent = do
       let pierConfig = toPierConfig (pierPath name) opts
       let networkConfig = toNetworkConfig opts
-      io $ runPierApp pierConfig networkConfig True $
+      runPierApp pierConfig networkConfig $
         tryBootFromPill True pill nLite flags ship bootEvent multi
 ------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
 
-
+runShip :: CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> RIO App ()
-runShip :: MonadIO m => CLI.Run -> CLI.Opts -> Bool -> MultiEyreApi -> m ()
+runShip (CLI.Run pierPath) opts daemon multi = do
-runShip (CLI.Run pierPath) opts daemon multi = io $ do
+    tid <- io myThreadId
-    tid <- myThreadId
     let onTermExit = throwTo tid UserInterrupt
     mStart <- newEmptyMVar
     if daemon
@@ -528,11 +535,11 @@ runShip (CLI.Run pierPath) opts daemon multi = io $ do
     else do
       connectionThread <- async $ do
         readMVar mStart
-        finally (runAppNoLog $ connTerm pierPath) onTermExit
+        finally (connTerm pierPath) onTermExit
       finally (runPier mStart) (cancel connectionThread)
   where
     runPier mStart =
-          runPierApp pierConfig networkConfig daemon $
+          runPierApp pierConfig networkConfig $
             tryPlayShip
               (CLI.oExit opts)
               (CLI.oFullReplay opts)
@@ -582,27 +589,39 @@ checkComet = do
 
 main :: IO ()
 main = do
+  args <- CLI.parseArgs
+  hSetBuffering stdout NoBuffering
+  setupSignalHandlers
+
+  runApp args $ case args of
+    CLI.CmdRun ko ships                       -> runShips ko ships
+    CLI.CmdNew n  o                           -> newShip n o
+    CLI.CmdBug (CLI.CollectAllFX pax        ) -> collectAllFx pax
+    CLI.CmdBug (CLI.EventBrowser pax        ) -> startBrowser pax
+    CLI.CmdBug (CLI.ValidatePill   pax pil s) -> testPill pax pil s
+    CLI.CmdBug (CLI.ValidateEvents pax f   l) -> checkEvs pax f l
+    CLI.CmdBug (CLI.ValidateFX     pax f   l) -> checkFx pax f l
+    CLI.CmdBug (CLI.ReplayEvents pax l      ) -> replayPartEvs pax l
+    CLI.CmdBug (CLI.CheckDawn pax           ) -> checkDawn pax
+    CLI.CmdBug CLI.CheckComet                 -> checkComet
+    CLI.CmdCon pier                           -> connTerm pier
+
+ where
+  runApp args | willRunTerminal args = runAppLogFile
+  runApp args | otherwise            = runAppStderr
+
+  setupSignalHandlers = do
     mainTid <- myThreadId
-
-    hSetBuffering stdout NoBuffering
-
     let onKillSig = throwTo mainTid UserInterrupt
+    for_ [Sys.sigTERM, Sys.sigINT] $ \sig -> do
+      Sys.installHandler sig (Sys.Catch onKillSig) Nothing
 
-    Sys.installHandler Sys.sigTERM (Sys.Catch onKillSig) Nothing
+  willRunTerminal :: CLI.Cmd -> Bool
-    Sys.installHandler Sys.sigINT  (Sys.Catch onKillSig) Nothing
+  willRunTerminal = \case
-
+    CLI.CmdCon _                 -> True
-    CLI.parseArgs >>= \case
+    CLI.CmdRun ko [(_,_,daemon)] -> not daemon
-        CLI.CmdRun ko ships                     -> runApp $ runShips ko ships
+    CLI.CmdRun ko _              -> False
-        CLI.CmdNew n o                          -> runApp $ newShip n o
+    _                            -> False
-        CLI.CmdBug (CLI.CollectAllFX pax)       -> runApp $ collectAllFx pax
-        CLI.CmdBug (CLI.EventBrowser pax)       -> runApp $ startBrowser pax
-        CLI.CmdBug (CLI.ValidatePill pax pil s) -> runApp $ testPill pax pil s
-        CLI.CmdBug (CLI.ValidateEvents pax f l) -> runApp $ checkEvs pax f l
-        CLI.CmdBug (CLI.ValidateFX pax f l)     -> runApp $ checkFx  pax f l
-        CLI.CmdBug (CLI.ReplayEvents pax l)     -> runApp $ replayPartEvs pax l
-        CLI.CmdBug (CLI.CheckDawn pax)          -> runApp $ checkDawn pax
-        CLI.CmdBug CLI.CheckComet               -> runApp $ checkComet
-        CLI.CmdCon pier                         -> runAppLogFile $ connTerm pier
 
 
 {-
@@ -613,7 +632,7 @@ main = do
 
   TODO Use logging system instead of printing.
 -}
-runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> IO ()
+runShipRestarting :: STM () -> CLI.Run -> CLI.Opts -> MultiEyreApi -> RIO App ()
 runShipRestarting waitForKillRequ r o multi = do
   let pier = pack (CLI.rPierPath r)
       loop = runShipRestarting waitForKillRequ r o multi
@@ -663,8 +682,8 @@ runShips CLI.KingOpts {..} ships = do
     [(r, o, d)] -> runShip r o d me
     ships       -> runMultipleShips (ships <&> \(r, o, _) -> (r, o)) me
 
-runMultipleShips :: MonadIO m => [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> m ()
+runMultipleShips :: [(CLI.Run, CLI.Opts)] -> MultiEyreApi -> RIO App ()
-runMultipleShips ships multi = io $ do
+runMultipleShips ships multi = do
   killSignal <- newEmptyTMVarIO
 
   let waitForKillRequ = readTMVar killSignal
@@ -692,8 +711,7 @@ runMultipleShips ships multi = io $ do
 --------------------------------------------------------------------------------
 
 connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
-connTerm pier =
+connTerm = Term.runTerminalClient
-    Term.runTerminalClient pier
 
 --------------------------------------------------------------------------------
 

pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs

@@ -149,11 +149,12 @@ openFreePort hos = do
 retry :: HasLogFunc e => RIO e (Either IOError a) -> RIO e a
 retry act = act >>= \case
   Right res -> pure res
-  Left exn  -> do
+  Left  exn -> do
-    logError (displayShow ("EYRE", "Failed to open ports.", exn))
+    logTr ctx ("Failed to open ports. Waiting 5s, then trying again.", exn)
-    logError (displayShow ("EYRE", "Waiting 250ms then trying again."))
+    threadDelay 5_000_000
-    threadDelay 250_000
     retry act
+ where
+  ctx = ["EYRE", "SERV", "retry"]
 
 tryOpenChoices
   :: HasLogFunc e
@@ -176,11 +177,18 @@ tryOpenChoices hos = go
 tryOpenAny
   :: HasLogFunc e => String -> RIO e (Either IOError (W.Port, Net.Socket))
 tryOpenAny hos = do
-  logTrace (displayShow ("EYRE", "Asking the OS for any free port."))
+  let ctx = ["EYRE", "SERV", "tryOpenAny"]
+  logTr ctx "Asking the OS for any free port."
   io (openFreePort hos) >>= \case
-    Left exn -> pure (Left exn)
+    Left  exn    -> pure (Left exn)
-    Right (p,s) -> do
+    Right (p, s) -> do
-      pure (Right (p,s))
+      pure (Right (p, s))
+
+logTr :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e ()
+logTr ctx msg = logTrace (prefix <> suffix)
+ where
+  prefix = display (concat $ fmap (<> ": ") ctx)
+  suffix = displayShow msg
 
 forceOpenSocket
   :: forall e
@@ -193,11 +201,12 @@ forceOpenSocket hos por = mkRAcquire opn kil
   kil = io . Net.close . snd
 
   opn = do
-    logTrace (displayShow ("EYRE", "SERV", "forceOpenSocket", hos, por))
+    let ctx = ["EYRE", "SERV", "forceOpenSocket"]
+    logTr ctx (hos, por)
     (p, s) <- retry $ case por of
       SPAnyPort    -> tryOpenAny bind
       SPChoices ps -> tryOpenChoices bind ps
-    rio $ logTrace $ displayShow ("EYRE", "Opened port.", p)
+    logTr ctx ("Opened port.", p)
     pure (p, s)
 
   bind = case hos of
@@ -221,14 +230,15 @@ onSniHdr
   :: HasLogFunc e => e -> MultiTlsConfig -> Maybe String -> IO Credentials
 onSniHdr env (MTC mtls) mHos = do
   tabl <- atomically (readTVar mtls)
-  runRIO env $ logTrace $ displayShow $ ("EYRE", "HTTPS", "SNI", tabl, mHos)
+  runRIO env $ logTr ctx (tabl, mHos)
   ship <- hostShip (encodeUtf8 . pack <$> mHos)
-  runRIO env $ logTrace $ displayShow $ ("EYRE", "HTTPS", "SNI", ship)
+  runRIO env $ logTr ctx ship
   tcfg <- lookup ship tabl & maybe (notRunning ship) (pure . snd)
-  runRIO env $ logTrace $ displayShow $ ("EYRE", "HTTPS", "SNI", tcfg)
+  runRIO env $ logTr ctx tcfg
   pure (Credentials [tcfg])
  where
   notRunning ship = error ("Ship not running: ~" <> show ship)
+  ctx = ["EYRE", "HTTPS", "SNI"]
 
 startServer
   :: HasLogFunc e
@@ -276,15 +286,19 @@ startServer typ hos por sok red vLive = do
 
       let sni = def { onServerNameIndication = onSniHdr envir mtls }
 
-      let tls = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey) { W.tlsServerHooks = sni }
+      let tlsSing = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey)
+      let tlsMany = tlsSing { W.tlsServerHooks = sni }
 
-      let app = \req resp -> do
+      let ctx = ["EYRE", "HTTPS", "REQ"]
-            runRIO envir $ logTrace $ displayShow ("EYRE", "HTTPS", "REQ")
-            who <- reqShip req
-            runRIO envir $ logTrace $ displayShow ("EYRE", "HTTPS", "REQ", who)
-            runAppl who (rcReq api who) (rcKil api who) req resp
 
-      io (W.runTLSSocket tls opts sok app)
+      let
+        app = \req resp -> do
+          runRIO envir $ logTr ctx "Got request"
+          who <- reqShip req
+          runRIO envir $ logTr ctx ("Parsed HOST", who)
+          runAppl who (rcReq api who) (rcKil api who) req resp
+
+      io (W.runTLSSocket tlsMany opts sok app)
 
 
 --------------------------------------------------------------------------------