mirror of
https://github.com/ilyakooo0/urbit.git
synced 2025-01-01 11:32:22 +03:00
Less verbose log output.
This commit is contained in:
~siprel
parent
674c794bab
commit
eb81f5ca14
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user