From eb81f5ca148e2aba3b5bc3aa1bb5a805a534546b Mon Sep 17 00:00:00 2001 From: ~siprel Date: Thu, 11 Jun 2020 02:02:09 +0000 Subject: [PATCH] Less verbose log output. --- pkg/hs/urbit-king/TODO.md | 5 ++ pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs | 7 ++ pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs | 7 ++ pkg/hs/urbit-king/lib/Urbit/King/App.hs | 14 ++-- pkg/hs/urbit-king/lib/Urbit/King/Main.hs | 72 ++++++++++--------- pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs | 26 +++---- pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs | 14 ++-- .../urbit-king/lib/Urbit/Vere/Eyre/Multi.hs | 6 +- pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs | 30 ++++---- pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs | 10 ++- pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs | 10 +-- 11 files changed, 113 insertions(+), 88 deletions(-) diff --git a/pkg/hs/urbit-king/TODO.md b/pkg/hs/urbit-king/TODO.md index c295a6403..a5e8429dd 100644 --- a/pkg/hs/urbit-king/TODO.md +++ b/pkg/hs/urbit-king/TODO.md @@ -97,6 +97,11 @@ Implement Pier-wide process start events 2. Make the serf IPC code not care about the shape of events and effects. 3. Support invalid events throughout the system (use `Lenient`?) +# Polish + +- [x] Goot logging output in non-verbose mode. +- [ ] Command-Line flag to re-enable verbose output. + # Cleanup diff --git a/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs b/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs index 0cb22a231..606539907 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Arvo/Effect.hs @@ -186,3 +186,10 @@ instance FromNoun Ef where ReOrg "" s "vega" p _ -> fail "%vega effect expects nil value" ReOrg "" s tag p val -> EfVane <$> parseNoun (toNoun (s, tag, p, val)) ReOrg _ _ _ _ _ -> fail "Non-empty first path-element" + +summarizeEffect :: Lenient Ef -> Text +summarizeEffect ef = + fromNoun (toNoun ef) & \case + Nothing -> "//invalid %effect" + Just (pax :: [Cord], tag :: Cord, val :: Noun) -> + "/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag diff --git a/pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs b/pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs index ed4fbe0c7..39df141e1 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Arvo/Event.hs @@ -382,3 +382,10 @@ getSpinnerNameForEvent = \case where isRet (TermEvBelt _ (Ret ())) = True isRet _ = False + +summarizeEvent :: Ev -> Text +summarizeEvent ev = + fromNoun (toNoun ev) & \case + Nothing -> "//invalid %event" + Just (pax :: [Cord], tag :: Cord, val :: Noun) -> + "/" <> intercalate "/" (unCord <$> pax) <> " %" <> unCord tag diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index 263a596a5..bd8b6b1a5 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -73,19 +73,19 @@ instance HasKingId KingEnv where -- Running KingEnvs ------------------------------------------------------------ -runKingEnvStderr :: RIO KingEnv a -> IO a -runKingEnvStderr inner = do +runKingEnvStderr :: Bool -> RIO KingEnv a -> IO a +runKingEnvStderr verb inner = do logOptions <- - logOptionsHandle stderr True <&> setLogUseTime True <&> setLogUseLoc False + logOptionsHandle stderr verb <&> setLogUseTime True <&> setLogUseLoc False withLogFunc logOptions $ \logFunc -> runKingEnv logFunc logFunc inner -runKingEnvLogFile :: RIO KingEnv a -> IO a -runKingEnvLogFile inner = withLogFileHandle $ \h -> do +runKingEnvLogFile :: Bool -> RIO KingEnv a -> IO a +runKingEnvLogFile verb inner = withLogFileHandle $ \h -> do logOptions <- - logOptionsHandle h True <&> setLogUseTime True <&> setLogUseLoc False + logOptionsHandle h verb <&> setLogUseTime True <&> setLogUseLoc False stderrLogOptions <- - logOptionsHandle stderr True <&> setLogUseTime False <&> setLogUseLoc False + logOptionsHandle stderr verb <&> setLogUseTime False <&> setLogUseLoc False withLogFunc stderrLogOptions $ \stderrLogFunc -> withLogFunc logOptions $ \logFunc -> runKingEnv logFunc stderrLogFunc inner diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index b6043c5f8..c64a09a1c 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -193,9 +193,9 @@ tryBootFromPill oExit pill lite ship boot multi = do where bootedPier vSlog = do view pierPathL >>= lockFile - rio $ logTrace "Starting boot" + rio $ logDebug "Starting boot" sls <- Pier.booted vSlog pill lite ship boot - rio $ logTrace "Completed boot" + rio $ logDebug "Completed boot" pure sls runOrExitImmediately @@ -210,9 +210,9 @@ runOrExitImmediately vSlog getPier oExit mStart multi = do where shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv () shutdownImmediately (serf, log) = do - logTrace "Sending shutdown signal" + logDebug "Sending shutdown signal" Serf.stop serf - logTrace "Shutdown!" + logDebug "Shutdown!" runPier :: (Serf, Log.EventLog) -> RIO PierEnv () runPier serfLog = do @@ -232,7 +232,7 @@ tryPlayShip exitImmediately fullReplay playFrom mStart multi = do where wipeSnapshot = do shipPath <- view pierPathL - logTrace "wipeSnapshot" + logDebug "wipeSnapshot" logDebug $ display $ pack @Text ("Wiping " <> north shipPath) logDebug $ display $ pack @Text ("Wiping " <> south shipPath) removeFileIfExists (north shipPath) @@ -244,9 +244,9 @@ tryPlayShip exitImmediately fullReplay playFrom mStart multi = do resumeShip :: TVar (Text -> IO ()) -> RAcquire PierEnv (Serf, Log.EventLog) resumeShip vSlog = do view pierPathL >>= lockFile - rio $ logTrace "RESUMING SHIP" + rio $ logDebug "RESUMING SHIP" sls <- Pier.resumed vSlog playFrom - rio $ logTrace "SHIP RESUMED" + rio $ logDebug "SHIP RESUMED" pure sls runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e)) @@ -261,7 +261,7 @@ checkEvs pierPath first last = do rwith (Log.existing logPath) $ \log -> do let ident = Log.identity log let pbSty = PB.defStyle { PB.stylePostfix = PB.exact } - logTrace (displayShow ident) + logDebug (displayShow ident) last <- atomically $ Log.lastEv log <&> \lastReal -> min last lastReal @@ -286,7 +286,7 @@ checkEvs pierPath first last = do showEvents pb eId cycle = await >>= \case Nothing -> do lift $ PB.killProgressBar pb - lift $ logTrace "Everything checks out." + lift $ logDebug "Everything checks out." Just bs -> do lift $ PB.incProgress pb 1 lift $ do @@ -315,10 +315,10 @@ collectAllFx = error "TODO" -} collectAllFx :: FilePath -> RIO KingEnv () collectAllFx top = do - logTrace $ display $ pack @Text top + logDebug $ display $ pack @Text top vSlog <- logSlogs rwith (collectedFX vSlog) $ \() -> - logTrace "Done collecting effects!" + logDebug "Done collecting effects!" where tmpDir :: FilePath tmpDir = top ".tmpdir" @@ -339,10 +339,10 @@ collectAllFx top = do replayPartEvs :: FilePath -> Word64 -> RIO KingEnv () replayPartEvs top last = do - logTrace $ display $ pack @Text top + logDebug $ display $ pack @Text top fetchSnapshot rwith replayedEvs $ \() -> - logTrace "Done replaying events!" + logDebug "Done replaying events!" where fetchSnapshot :: RIO KingEnv () fetchSnapshot = do @@ -385,57 +385,57 @@ replayPartEvs top last = do -} testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e () testPill pax showPil showSeq = do - logTrace "Reading pill file." + logDebug "Reading pill file." pillBytes <- readFile pax - logTrace "Cueing pill file." + logDebug "Cueing pill file." pillNoun <- io $ cueBS pillBytes & either throwIO pure - logTrace "Parsing pill file." + logDebug "Parsing pill file." pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure - logTrace "Using pill to generate boot sequence." + logDebug "Using pill to generate boot sequence." bootSeq <- genBootSeq (Ship 0) pill False (Fake (Ship 0)) - logTrace "Validate jam/cue and toNoun/fromNoun on pill value" + logDebug "Validate jam/cue and toNoun/fromNoun on pill value" reJam <- validateNounVal pill - logTrace "Checking if round-trip matches input file:" + logDebug "Checking if round-trip matches input file:" unless (reJam == pillBytes) $ do - logTrace " Our jam does not match the file...\n" - logTrace " This is surprising, but it is probably okay." + logDebug " Our jam does not match the file...\n" + logDebug " This is surprising, but it is probably okay." when showPil $ do - logTrace "\n\n== Pill ==\n" + logDebug "\n\n== Pill ==\n" io $ pPrint pill when showSeq $ do - logTrace "\n\n== Boot Sequence ==\n" + logDebug "\n\n== Boot Sequence ==\n" io $ pPrint bootSeq validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a) => a -> RIO e ByteString validateNounVal inpVal = do - logTrace " jam" + logDebug " jam" inpByt <- evaluate $ jamBS $ toNoun inpVal - logTrace " cue" + logDebug " cue" outNon <- cueBS inpByt & either throwIO pure - logTrace " fromNoun" + logDebug " fromNoun" outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure - logTrace " toNoun" + logDebug " toNoun" outNon <- evaluate (toNoun outVal) - logTrace " jam" + logDebug " jam" outByt <- evaluate $ jamBS outNon - logTrace "Checking if: x == cue (jam x)" + logDebug "Checking if: x == cue (jam x)" unless (inpVal == outVal) $ error "Value fails test: x == cue (jam x)" - logTrace "Checking if: jam x == jam (cue (jam x))" + logDebug "Checking if: jam x == jam (cue (jam x))" unless (inpByt == outByt) $ error "Value fails test: jam x == jam (cue (jam x))" @@ -447,11 +447,11 @@ validateNounVal inpVal = do pillFrom :: CLI.PillSource -> RIO KingEnv Pill pillFrom = \case CLI.PillSourceFile pillPath -> do - logTrace $ display $ "boot: reading pill from " ++ (pack pillPath :: Text) + logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text) io (loadFile pillPath >>= either throwIO pure) CLI.PillSourceURL url -> do - logTrace $ display $ "boot: retrieving pill from " ++ (pack url :: Text) + logDebug $ display $ "boot: retrieving pill from " ++ (pack url :: Text) -- Get the jamfile with the list of stars accepting comets right now. manager <- io $ C.newManager tlsManagerSettings request <- io $ C.parseRequest url @@ -640,8 +640,10 @@ main = do CLI.CmdCon pier -> connTerm pier where - runKingEnv args | willRunTerminal args = runKingEnvLogFile - runKingEnv args | otherwise = runKingEnvStderr + verboseLogging = False + + runKingEnv args | willRunTerminal args = runKingEnvLogFile verboseLogging + runKingEnv args | otherwise = runKingEnvStderr verboseLogging setupSignalHandlers = do mainTid <- myThreadId @@ -691,7 +693,7 @@ runShipRestarting r o multi = do logTrace $ display (pier <> " shutdown requested") race_ (wait tid) $ do threadDelay 5_000_000 - logTrace $ display (pier <> " not down after 5s, killing with fire.") + logDebug $ display (pier <> " not down after 5s, killing with fire.") cancel tid logTrace $ display ("Ship terminated: " <> pier) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs index a1ae17ca0..47a9b24fb 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs @@ -79,14 +79,14 @@ forceBind :: HasLogFunc e => PortNumber -> HostAddress -> RIO e Socket forceBind por hos = go where go = do - logTrace (display ("AMES: UDP: Opening socket on port " <> tshow por)) + logDebug (display ("AMES: UDP: Opening socket on port " <> tshow por)) io (doBind por hos) >>= \case Right sk -> do - logTrace (display ("AMES: UDP: Opened socket on port " <> tshow por)) + logDebug (display ("AMES: UDP: Opened socket on port " <> tshow por)) pure sk Left err -> do - logTrace (display ("AMES: UDP: " <> tshow err)) - logTrace ("AMES: UDP: Failed to open UDP socket. Waiting") + logDebug (display ("AMES: UDP: " <> tshow err)) + logDebug ("AMES: UDP: Failed to open UDP socket. Waiting") threadDelay 250_000 go @@ -97,14 +97,14 @@ forceBind por hos = go -} sendPacket :: HasLogFunc e => ByteString -> SockAddr -> Socket -> RIO e Bool sendPacket fullBytes adr sok = do - logTrace $ displayShow ("AMES", "UDP", "Sending packet.") + logDebug $ displayShow ("AMES", "UDP", "Sending packet.") res <- io $ tryIOError $ go fullBytes case res of Left err -> do logError $ displayShow ("AMES", "UDP", "Failed to send packet", err) pure False Right () -> do - logTrace $ displayShow ("AMES", "UDP", "Packet sent.") + logDebug $ displayShow ("AMES", "UDP", "Packet sent.") pure True where go byt = do @@ -137,7 +137,7 @@ recvPacket sok = do -} fakeUdpServ :: HasLogFunc e => RIO e UdpServ fakeUdpServ = do - logTrace $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.") + logDebug $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.") pure UdpServ { .. } where usSend = \_ _ -> pure () @@ -153,7 +153,7 @@ fakeUdpServ = do realUdpServ :: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ realUdpServ por hos = do - logTrace $ displayShow ("AMES", "UDP", "Starting real UDP server.") + logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.") env <- ask @@ -173,7 +173,7 @@ realUdpServ por hos = do -} let signalBrokenSocket :: Socket -> RIO e () signalBrokenSocket sock = do - logTrace $ displayShow ("AMES", "UDP" + logDebug $ displayShow ("AMES", "UDP" , "Socket broken. Requesting new socket" ) atomically $ do @@ -200,7 +200,7 @@ realUdpServ por hos = do sk <- forceBind por hos atomically (writeTVar vSock (Just sk)) broken <- atomically (takeTMVar vFail) - logTrace "AMES: UDP: Closing broken socket." + logWarn "AMES: UDP: Closing broken socket." io (close broken) tSend <- async $ forever $ join $ atomically $ do @@ -223,15 +223,15 @@ realUdpServ por hos = do logError "AMES: UDP: Dropping non-ipv4 packet" pure () Right (Just (b, p, a)) -> do - logTrace "AMES: UDP: Received packet." + logDebug "AMES: UDP: Received packet." enqueueRecvPacket p a b let shutdown = do - logTrace "AMES: UDP: Shutting down. (killing threads)" + logDebug "AMES: UDP: Shutting down. (killing threads)" cancel tOpen cancel tSend cancel tRecv - logTrace "AMES: UDP: Shutting down. (closing socket)" + logDebug "AMES: UDP: Shutting down. (closing socket)" io $ join $ atomically $ do res <- readTVar vSock <&> maybe (pure ()) close writeTVar vSock Nothing diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs index 4f69a4888..2aeb33f63 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs @@ -165,7 +165,7 @@ execRespActs :: HasLogFunc e => Drv -> Ship -> Word64 -> HttpEvent -> RIO e () execRespActs (Drv v) who reqId ev = readMVar v >>= \case Nothing -> logError "Got a response to a request that does not exist." Just sv -> do - logTrace $ displayShow ev + logDebug $ displayShow ev for_ (parseHttpEvent ev) $ \act -> do atomically (routeRespAct who (sLiveReqs sv) reqId act) @@ -178,7 +178,7 @@ startServ -> (EvErr -> STM ()) -> RIO e Serv startServ multi who isFake conf plan = do - logTrace (displayShow ("EYRE", "startServ")) + logDebug (displayShow ("EYRE", "startServ")) let vLive = meaLive multi @@ -219,11 +219,11 @@ startServ multi who isFake conf plan = do let onKilReq :: Ship -> Word64 -> STM () onKilReq _ship = plan . cancelEv srvId . fromIntegral - logTrace (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre)) + logDebug (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre)) atomically (joinMultiEyre multi who mCre onReq onKilReq) - logTrace $ displayShow ("EYRE", "Starting loopback server") + logDebug $ displayShow ("EYRE", "Starting loopback server") lop <- serv vLive $ ServConf { scHost = soHost (pttLop ptt) , scPort = soWhich (pttLop ptt) @@ -235,7 +235,7 @@ startServ multi who isFake conf plan = do } } - logTrace $ displayShow ("EYRE", "Starting insecure server") + logDebug $ displayShow ("EYRE", "Starting insecure server") ins <- serv vLive $ ServConf { scHost = soHost (pttIns ptt) , scPort = soWhich (pttIns ptt) @@ -248,7 +248,7 @@ startServ multi who isFake conf plan = do } mSec <- for mTls $ \tls -> do - logTrace "Starting secure server" + logDebug "Starting secure server" serv vLive $ ServConf { scHost = soHost (pttSec ptt) , scPort = soWhich (pttSec ptt) @@ -269,7 +269,7 @@ startServ multi who isFake conf plan = do let por = Ports secPor insPor lopPor fil = pierPath <> "/.http.ports" - logTrace $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil) + logDebug $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil) pure (Serv srvId conf lop ins mSec por fil vLive) diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs index 30b0298b8..706afb8f3 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Multi.hs @@ -72,7 +72,7 @@ leaveMultiEyre MultiEyreApi {..} who = do multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi multiEyre conf@MultiEyreConf {..} = do - logTrace (displayShow ("EYRE", "MULTI", conf)) + logDebug (displayShow ("EYRE", "MULTI", conf)) vLive <- io emptyLiveReqs >>= newTVarIO vPlan <- newTVarIO mempty @@ -96,7 +96,7 @@ multiEyre conf@MultiEyreConf {..} = do Just cb -> cb who reqId mIns <- for mecHttpPort $ \por -> do - logTrace (displayShow ("EYRE", "MULTI", "HTTP", por)) + logDebug (displayShow ("EYRE", "MULTI", "HTTP", por)) serv vLive $ ServConf { scHost = host , scPort = SPChoices $ singleton $ fromIntegral por @@ -109,7 +109,7 @@ multiEyre conf@MultiEyreConf {..} = do } mSec <- for mecHttpsPort $ \por -> do - logTrace (displayShow ("EYRE", "MULTI", "HTTPS", por)) + logDebug (displayShow ("EYRE", "MULTI", "HTTPS", por)) serv vLive $ ServConf { scHost = host , scPort = SPChoices $ singleton $ fromIntegral por diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs index a105befae..e007d6331 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs @@ -150,7 +150,7 @@ retry :: HasLogFunc e => RIO e (Either IOError a) -> RIO e a retry act = act >>= \case Right res -> pure res Left exn -> do - logTr ctx ("Failed to open ports. Waiting 5s, then trying again.", exn) + logDbg ctx ("Failed to open ports. Waiting 5s, then trying again.", exn) threadDelay 5_000_000 retry act where @@ -164,7 +164,7 @@ tryOpenChoices tryOpenChoices hos = go where go (p :| ps) = do - logTrace (displayShow ("EYRE", "Trying to open port.", p)) + logDebug (displayShow ("EYRE", "Trying to open port.", p)) io (tryOpen hos p) >>= \case Left err -> do logError (displayShow ("EYRE", "Failed to open port.", p)) @@ -178,14 +178,14 @@ tryOpenAny :: HasLogFunc e => String -> RIO e (Either IOError (W.Port, Net.Socket)) tryOpenAny hos = do let ctx = ["EYRE", "SERV", "tryOpenAny"] - logTr ctx "Asking the OS for any free port." + logDbg ctx "Asking the OS for any free port." io (openFreePort hos) >>= \case Left exn -> pure (Left exn) Right (p, s) -> do pure (Right (p, s)) -logTr :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e () -logTr ctx msg = logTrace (prefix <> suffix) +logDbg :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e () +logDbg ctx msg = logDebug (prefix <> suffix) where prefix = display (concat $ fmap (<> ": ") ctx) suffix = displayShow msg @@ -202,11 +202,11 @@ forceOpenSocket hos por = mkRAcquire opn kil opn = do let ctx = ["EYRE", "SERV", "forceOpenSocket"] - logTr ctx (hos, por) + logDbg ctx (hos, por) (p, s) <- retry $ case por of SPAnyPort -> tryOpenAny bind SPChoices ps -> tryOpenChoices bind ps - logTr ctx ("Opened port.", p) + logDbg ctx ("Opened port.", p) pure (p, s) bind = case hos of @@ -230,11 +230,11 @@ onSniHdr :: HasLogFunc e => e -> MultiTlsConfig -> Maybe String -> IO Credentials onSniHdr env (MTC mtls) mHos = do tabl <- atomically (readTVar mtls) - runRIO env $ logTr ctx (tabl, mHos) + runRIO env $ logDbg ctx (tabl, mHos) ship <- hostShip (encodeUtf8 . pack <$> mHos) - runRIO env $ logTr ctx ship + runRIO env $ logDbg ctx ship tcfg <- lookup ship tabl & maybe (notRunning ship) (pure . snd) - runRIO env $ logTr ctx tcfg + runRIO env $ logDbg ctx tcfg pure (Credentials [tcfg]) where notRunning ship = error ("Ship not running: ~" <> show ship) @@ -293,9 +293,9 @@ startServer typ hos por sok red vLive = do let app = \req resp -> do - runRIO envir $ logTr ctx "Got request" + runRIO envir $ logDbg ctx "Got request" who <- reqShip req - runRIO envir $ logTr ctx ("Parsed HOST", who) + runRIO envir $ logDbg ctx ("Parsed HOST", who) runAppl who (rcReq api who) (rcKil api who) req resp io (W.runTLSSocket tlsMany opts sok app) @@ -312,7 +312,7 @@ configCreds TlsConfig {..} = fakeServ :: HasLogFunc e => ServConf -> RIO e ServApi fakeServ conf = do let por = fakePort (scPort conf) - logTrace (displayShow ("EYRE", "SERV", "Running Fake Server", por)) + logDebug (displayShow ("EYRE", "SERV", "Running Fake Server", por)) pure $ ServApi { saKil = pure () , saPor = pure por @@ -331,7 +331,7 @@ getFirstTlsConfig (MTC var) = do realServ :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi realServ vLive conf@ServConf {..} = do - logTrace (displayShow ("EYRE", "SERV", "Running Real Server")) + logDebug (displayShow ("EYRE", "SERV", "Running Real Server")) kil <- newEmptyTMVarIO por <- newEmptyTMVarIO @@ -344,7 +344,7 @@ realServ vLive conf@ServConf {..} = do } where runServ vPort = do - logTrace (displayShow ("EYRE", "SERV", "runServ")) + logDebug (displayShow ("EYRE", "SERV", "runServ")) rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do atomically (putTMVar vPort por) startServer scType scHost por sok scRedi vLive diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs index 568f03d8c..4d075875d 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Pier.hs @@ -343,7 +343,7 @@ pier (serf, log) vSlog startedSig multi = do RunSwap _ _ _ _ _ -> putMVar okaySig () RunBail _ -> inject (n + 1) - logTrace ("Boot Event" <> displayShow ev) + -- logTrace ("[BOOT EVENT]: " <> display (summarizeEvent ev)) io (inject 0) let slog :: Text -> IO () @@ -493,13 +493,17 @@ router slog waitFx Drivers {..} = do -- Compute (Serf) Thread ------------------------------------------------------- logEvent :: HasLogFunc e => Ev -> RIO e () -logEvent ev = logDebug $ display $ "[EVENT]\n" <> pretty +logEvent ev = do + logTrace $ "<- " <> display (summarizeEvent ev) + logDebug $ "[EVENT]\n" <> display pretty where pretty :: Text pretty = pack $ unlines $ fmap ("\t" <>) $ lines $ ppShow ev logEffect :: HasLogFunc e => Lenient Ef -> RIO e () -logEffect ef = logDebug $ display $ "[EFFECT]\n" <> pretty ef +logEffect ef = do + logTrace $ " -> " <> display (summarizeEffect ef) + logDebug $ display $ "[EFFECT]\n" <> pretty ef where pretty :: Lenient Ef -> Text pretty = \case diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs index 2b73b2b8e..e03512883 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Serf.hs @@ -40,7 +40,7 @@ withSerf config = mkRAcquire startup kill where startup = do (serf, st) <- io $ start config - logTrace (displayShow st) + logDebug (displayShow ("serf state", st)) pure serf kill serf = do void $ rio $ stop serf @@ -58,7 +58,7 @@ execReplay serf log last = do where doBoot :: RIO e (Either PlayBail Word) doBoot = do - logTrace "Beginning boot sequence" + logDebug "Beginning boot sequence" let bootSeqLen = lifecycleLen (Log.identity log) @@ -72,14 +72,14 @@ execReplay serf log last = do when (numEvs /= bootSeqLen) $ do throwIO (MissingBootEventsInEventLog numEvs bootSeqLen) - logTrace $ display ("Sending " <> tshow numEvs <> " boot events to serf") + logDebug $ display ("Sending " <> tshow numEvs <> " boot events to serf") io (boot serf evs) >>= \case Just err -> do - logTrace "Error on replay, exiting" + logDebug "Error on replay, exiting" pure (Left err) Nothing -> do - logTrace "Finished boot events, moving on to more events from log." + logDebug "Finished boot events, moving on to more events from log." doReplay <&> \case Left err -> Left err Right num -> Right (num + numEvs)