mirror of
https://github.com/urbit/shrub.git
synced 2025-01-03 10:02:32 +03:00
king: move most things from debug log level to info
This commit is contained in:
pilfer-pandex
parent
0a3fe85c06
commit
ba79aa713a
@ -194,9 +194,9 @@ tryBootFromPill oExit pill lite ship boot = do
|
||||
where
|
||||
bootedPier vSlog = do
|
||||
view pierPathL >>= lockFile
|
||||
rio $ logDebug "Starting boot"
|
||||
rio $ logInfo "Starting boot"
|
||||
sls <- Pier.booted vSlog pill lite ship boot
|
||||
rio $ logDebug "Completed boot"
|
||||
rio $ logInfo "Completed boot"
|
||||
pure sls
|
||||
|
||||
runOrExitImmediately
|
||||
@ -210,9 +210,9 @@ runOrExitImmediately vSlog getPier oExit mStart = do
|
||||
where
|
||||
shutdownImmediately :: (Serf, Log.EventLog) -> RIO PierEnv ()
|
||||
shutdownImmediately (serf, log) = do
|
||||
logDebug "Sending shutdown signal"
|
||||
logInfo "Sending shutdown signal"
|
||||
Serf.stop serf
|
||||
logDebug "Shutdown!"
|
||||
logInfo "Shutdown!"
|
||||
|
||||
runPier :: (Serf, Log.EventLog) -> RIO PierEnv ()
|
||||
runPier serfLog = do
|
||||
@ -231,9 +231,9 @@ tryPlayShip exitImmediately fullReplay playFrom mStart = do
|
||||
where
|
||||
wipeSnapshot = do
|
||||
shipPath <- view pierPathL
|
||||
logDebug "wipeSnapshot"
|
||||
logDebug $ display $ pack @Text ("Wiping " <> north shipPath)
|
||||
logDebug $ display $ pack @Text ("Wiping " <> south shipPath)
|
||||
logInfo "wipeSnapshot"
|
||||
logInfo $ display $ pack @Text ("Wiping " <> north shipPath)
|
||||
logInfo $ display $ pack @Text ("Wiping " <> south shipPath)
|
||||
removeFileIfExists (north shipPath)
|
||||
removeFileIfExists (south shipPath)
|
||||
|
||||
@ -243,9 +243,9 @@ tryPlayShip exitImmediately fullReplay playFrom mStart = do
|
||||
resumeShip :: TVar (Text -> IO ()) -> RAcquire PierEnv (Serf, Log.EventLog)
|
||||
resumeShip vSlog = do
|
||||
view pierPathL >>= lockFile
|
||||
rio $ logDebug "RESUMING SHIP"
|
||||
rio $ logInfo "RESUMING SHIP"
|
||||
sls <- Pier.resumed vSlog playFrom
|
||||
rio $ logDebug "SHIP RESUMED"
|
||||
rio $ logInfo "SHIP RESUMED"
|
||||
pure sls
|
||||
|
||||
runRAcquire :: (MonadUnliftIO (m e), MonadIO (m e), MonadReader e (m e))
|
||||
@ -260,7 +260,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 }
|
||||
logDebug (displayShow ident)
|
||||
logInfo (displayShow ident)
|
||||
|
||||
last <- atomically $ Log.lastEv log <&> \lastReal -> min last lastReal
|
||||
|
||||
@ -285,7 +285,7 @@ checkEvs pierPath first last = do
|
||||
showEvents pb eId cycle = await >>= \case
|
||||
Nothing -> do
|
||||
lift $ PB.killProgressBar pb
|
||||
lift $ logDebug "Everything checks out."
|
||||
lift $ logInfo "Everything checks out."
|
||||
Just bs -> do
|
||||
lift $ PB.incProgress pb 1
|
||||
lift $ do
|
||||
@ -314,10 +314,10 @@ collectAllFx = error "TODO"
|
||||
-}
|
||||
collectAllFx :: FilePath -> RIO KingEnv ()
|
||||
collectAllFx top = do
|
||||
logDebug $ display $ pack @Text top
|
||||
logInfo $ display $ pack @Text top
|
||||
vSlog <- logSlogs
|
||||
rwith (collectedFX vSlog) $ \() ->
|
||||
logDebug "Done collecting effects!"
|
||||
logInfo "Done collecting effects!"
|
||||
where
|
||||
tmpDir :: FilePath
|
||||
tmpDir = top </> ".tmpdir"
|
||||
@ -338,10 +338,10 @@ collectAllFx top = do
|
||||
|
||||
replayPartEvs :: FilePath -> Word64 -> RIO KingEnv ()
|
||||
replayPartEvs top last = do
|
||||
logDebug $ display $ pack @Text top
|
||||
logInfo $ display $ pack @Text top
|
||||
fetchSnapshot
|
||||
rwith replayedEvs $ \() ->
|
||||
logDebug "Done replaying events!"
|
||||
logInfo "Done replaying events!"
|
||||
where
|
||||
fetchSnapshot :: RIO KingEnv ()
|
||||
fetchSnapshot = do
|
||||
@ -384,57 +384,57 @@ replayPartEvs top last = do
|
||||
-}
|
||||
testPill :: HasLogFunc e => FilePath -> Bool -> Bool -> RIO e ()
|
||||
testPill pax showPil showSeq = do
|
||||
logDebug "Reading pill file."
|
||||
logInfo "Reading pill file."
|
||||
pillBytes <- readFile pax
|
||||
|
||||
logDebug "Cueing pill file."
|
||||
logInfo "Cueing pill file."
|
||||
pillNoun <- io $ cueBS pillBytes & either throwIO pure
|
||||
|
||||
logDebug "Parsing pill file."
|
||||
logInfo "Parsing pill file."
|
||||
pill <- fromNounErr pillNoun & either (throwIO . uncurry ParseErr) pure
|
||||
|
||||
logDebug "Using pill to generate boot sequence."
|
||||
logInfo "Using pill to generate boot sequence."
|
||||
bootSeq <- genBootSeq (Ship 0) pill False (Fake (Ship 0))
|
||||
|
||||
logDebug "Validate jam/cue and toNoun/fromNoun on pill value"
|
||||
logInfo "Validate jam/cue and toNoun/fromNoun on pill value"
|
||||
reJam <- validateNounVal pill
|
||||
|
||||
logDebug "Checking if round-trip matches input file:"
|
||||
logInfo "Checking if round-trip matches input file:"
|
||||
unless (reJam == pillBytes) $ do
|
||||
logDebug " Our jam does not match the file...\n"
|
||||
logDebug " This is surprising, but it is probably okay."
|
||||
logInfo " Our jam does not match the file...\n"
|
||||
logInfo " This is surprising, but it is probably okay."
|
||||
|
||||
when showPil $ do
|
||||
logDebug "\n\n== Pill ==\n"
|
||||
logInfo "\n\n== Pill ==\n"
|
||||
io $ pPrint pill
|
||||
|
||||
when showSeq $ do
|
||||
logDebug "\n\n== Boot Sequence ==\n"
|
||||
logInfo "\n\n== Boot Sequence ==\n"
|
||||
io $ pPrint bootSeq
|
||||
|
||||
validateNounVal :: (HasLogFunc e, Eq a, ToNoun a, FromNoun a)
|
||||
=> a -> RIO e ByteString
|
||||
validateNounVal inpVal = do
|
||||
logDebug " jam"
|
||||
logInfo " jam"
|
||||
inpByt <- evaluate $ jamBS $ toNoun inpVal
|
||||
|
||||
logDebug " cue"
|
||||
logInfo " cue"
|
||||
outNon <- cueBS inpByt & either throwIO pure
|
||||
|
||||
logDebug " fromNoun"
|
||||
logInfo " fromNoun"
|
||||
outVal <- fromNounErr outNon & either (throwIO . uncurry ParseErr) pure
|
||||
|
||||
logDebug " toNoun"
|
||||
logInfo " toNoun"
|
||||
outNon <- evaluate (toNoun outVal)
|
||||
|
||||
logDebug " jam"
|
||||
logInfo " jam"
|
||||
outByt <- evaluate $ jamBS outNon
|
||||
|
||||
logDebug "Checking if: x == cue (jam x)"
|
||||
logInfo "Checking if: x == cue (jam x)"
|
||||
unless (inpVal == outVal) $
|
||||
error "Value fails test: x == cue (jam x)"
|
||||
|
||||
logDebug "Checking if: jam x == jam (cue (jam x))"
|
||||
logInfo "Checking if: jam x == jam (cue (jam x))"
|
||||
unless (inpByt == outByt) $
|
||||
error "Value fails test: jam x == jam (cue (jam x))"
|
||||
|
||||
@ -446,11 +446,11 @@ validateNounVal inpVal = do
|
||||
pillFrom :: CLI.PillSource -> RIO HostEnv Pill
|
||||
pillFrom = \case
|
||||
CLI.PillSourceFile pillPath -> do
|
||||
logDebug $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
|
||||
logInfo $ display $ "boot: reading pill from " ++ (pack pillPath :: Text)
|
||||
io (loadFile pillPath >>= either throwIO pure)
|
||||
|
||||
CLI.PillSourceURL url -> do
|
||||
logDebug $ display $ "boot: retrieving pill from " ++ (pack url :: Text)
|
||||
logInfo $ 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
|
||||
@ -729,7 +729,7 @@ runShipRestarting r o = do
|
||||
logTrace $ display (pier <> " shutdown requested")
|
||||
race_ (wait tid) $ do
|
||||
threadDelay 5_000_000
|
||||
logDebug $ display (pier <> " not down after 5s, killing with fire.")
|
||||
logInfo $ display (pier <> " not down after 5s, killing with fire.")
|
||||
cancel tid
|
||||
logTrace $ display ("Ship terminated: " <> pier)
|
||||
|
||||
|
||||
@ -131,11 +131,11 @@ doResolv gal (prevWen, prevIP) turfs stderr = do
|
||||
io (resolv gal turfs) >>= \case
|
||||
Nothing -> do
|
||||
stderr $ "ames: czar at " ++ galStr ++ ": not found"
|
||||
logDebug $ displayShow ("(ames) Failed to lookup IP for ", gal)
|
||||
logInfo $ displayShow ("(ames) Failed to lookup IP for ", gal)
|
||||
pure (prevIP, tim)
|
||||
Just (turf, host, port, addr) -> do
|
||||
when (Just addr /= prevIP) (printCzar addr)
|
||||
logDebug $ displayShow ("(ames) Looked up ", host, port, turf, addr)
|
||||
logInfo $ displayShow ("(ames) Looked up ", host, port, turf, addr)
|
||||
pure (Just addr, tim)
|
||||
where
|
||||
galStr = renderGalaxy gal
|
||||
@ -155,7 +155,7 @@ resolvWorker
|
||||
resolvWorker gal vTurfs vLast waitMsg send stderr = async (forever go)
|
||||
where
|
||||
logDrop =
|
||||
logDebug $ displayShow ("(ames) Dropping packet; no ip for galaxy ", gal)
|
||||
logInfo $ displayShow ("(ames) Dropping packet; no ip for galaxy ", gal)
|
||||
|
||||
go :: RIO e ()
|
||||
go = do
|
||||
|
||||
@ -80,14 +80,14 @@ forceBind :: HasLogFunc e => PortNumber -> HostAddress -> RIO e Socket
|
||||
forceBind por hos = go
|
||||
where
|
||||
go = do
|
||||
logDebug (display ("AMES: UDP: Opening socket on port " <> tshow por))
|
||||
logInfo (display ("AMES: UDP: Opening socket on port " <> tshow por))
|
||||
io (doBind por hos) >>= \case
|
||||
Right sk -> do
|
||||
logDebug (display ("AMES: UDP: Opened socket on port " <> tshow por))
|
||||
logInfo (display ("AMES: UDP: Opened socket on port " <> tshow por))
|
||||
pure sk
|
||||
Left err -> do
|
||||
logDebug (display ("AMES: UDP: " <> tshow err))
|
||||
logDebug ("AMES: UDP: Failed to open UDP socket. Waiting")
|
||||
logInfo (display ("AMES: UDP: " <> tshow err))
|
||||
logInfo ("AMES: UDP: Failed to open UDP socket. Waiting")
|
||||
threadDelay 250_000
|
||||
go
|
||||
|
||||
@ -138,7 +138,7 @@ recvPacket sok = do
|
||||
-}
|
||||
fakeUdpServ :: HasLogFunc e => RIO e UdpServ
|
||||
fakeUdpServ = do
|
||||
logDebug $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
|
||||
logInfo $ displayShow ("AMES", "UDP", "\"Starting\" fake UDP server.")
|
||||
pure UdpServ { .. }
|
||||
where
|
||||
usSend = \_ _ -> pure ()
|
||||
@ -158,7 +158,7 @@ realUdpServ
|
||||
-> HostAddress
|
||||
-> RIO e UdpServ
|
||||
realUdpServ por hos = do
|
||||
logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.")
|
||||
logInfo $ displayShow ("AMES", "UDP", "Starting real UDP server.")
|
||||
|
||||
env <- ask
|
||||
|
||||
@ -178,7 +178,7 @@ realUdpServ por hos = do
|
||||
-}
|
||||
let signalBrokenSocket :: Socket -> RIO e ()
|
||||
signalBrokenSocket sock = do
|
||||
logDebug $ displayShow ("AMES", "UDP"
|
||||
logInfo $ displayShow ("AMES", "UDP"
|
||||
, "Socket broken. Requesting new socket"
|
||||
)
|
||||
atomically $ do
|
||||
@ -242,11 +242,11 @@ realUdpServ por hos = do
|
||||
enqueueRecvPacket p a b
|
||||
|
||||
let shutdown = do
|
||||
logDebug "AMES: UDP: Shutting down. (killing threads)"
|
||||
logInfo "AMES: UDP: Shutting down. (killing threads)"
|
||||
cancel tOpen
|
||||
cancel tSend
|
||||
cancel tRecv
|
||||
logDebug "AMES: UDP: Shutting down. (closing socket)"
|
||||
logInfo "AMES: UDP: Shutting down. (closing socket)"
|
||||
io $ join $ atomically $ do
|
||||
res <- readTVar vSock <&> maybe (pure ()) close
|
||||
writeTVar vSock Nothing
|
||||
|
||||
@ -163,7 +163,7 @@ clay env plan =
|
||||
handleEffect :: ClayDrv -> SyncEf -> IO ()
|
||||
handleEffect cd = runRIO env . \case
|
||||
SyncEfHill _ mountPoints -> do
|
||||
logDebug $ displayShow ("(clay) known mount points:", mountPoints)
|
||||
logInfo $ displayShow ("(clay) known mount points:", mountPoints)
|
||||
pierPath <- view pierPathL
|
||||
mountPairs <- flip mapM mountPoints $ \desk -> do
|
||||
ss <- takeFilesystemSnapshot (pierPath </> (deskToPath desk))
|
||||
@ -171,14 +171,14 @@ clay env plan =
|
||||
atomically $ writeTVar (cdMountPoints cd) (M.fromList mountPairs)
|
||||
|
||||
SyncEfDirk p desk -> do
|
||||
logDebug $ displayShow ("(clay) dirk:", p, desk)
|
||||
logInfo $ displayShow ("(clay) dirk:", p, desk)
|
||||
m <- atomically $ readTVar (cdMountPoints cd)
|
||||
let snapshot = M.findWithDefault M.empty desk m
|
||||
pierPath <- view pierPathL
|
||||
let dir = pierPath </> deskToPath desk
|
||||
actions <- buildActionListFromDifferences dir snapshot
|
||||
|
||||
logDebug $ displayShow ("(clay) dirk actions: ", actions)
|
||||
logInfo $ displayShow ("(clay) dirk actions: ", actions)
|
||||
|
||||
let !intoList = map (actionsToInto dir) actions
|
||||
|
||||
@ -196,7 +196,7 @@ clay env plan =
|
||||
(applyActionsToMountPoints desk actions)
|
||||
|
||||
SyncEfErgo p desk actions -> do
|
||||
logDebug $ displayShow ("(clay) ergo:", p, desk, actions)
|
||||
logInfo $ displayShow ("(clay) ergo:", p, desk, actions)
|
||||
|
||||
m <- atomically $ readTVar (cdMountPoints cd)
|
||||
let mountPoint = M.findWithDefault M.empty desk m
|
||||
@ -211,7 +211,7 @@ clay env plan =
|
||||
(applyActionsToMountPoints desk hashedActions)
|
||||
|
||||
SyncEfOgre p desk -> do
|
||||
logDebug $ displayShow ("(clay) ogre:", p, desk)
|
||||
logInfo $ displayShow ("(clay) ogre:", p, desk)
|
||||
pierPath <- view pierPathL
|
||||
removeDirectoryRecursive $ pierPath </> deskToPath desk
|
||||
atomically $ modifyTVar (cdMountPoints cd) (M.delete desk)
|
||||
@ -229,13 +229,13 @@ clay env plan =
|
||||
performAction :: (Map FilePath Int) -> (FilePath, Maybe (Mime, Int))
|
||||
-> RIO e ()
|
||||
performAction m (fp, Nothing) = do
|
||||
logDebug $ displayShow ("(clay) deleting file ", fp)
|
||||
logInfo $ displayShow ("(clay) deleting file ", fp)
|
||||
removeFile fp
|
||||
performAction m (fp, Just ((Mime _ (File (Octs bs)), hash)))
|
||||
| skip = logDebug $
|
||||
| skip = logInfo $
|
||||
displayShow ("(clay) skipping unchanged file update " , fp)
|
||||
| otherwise = do
|
||||
logDebug $ displayShow ("(clay) updating file " , fp)
|
||||
logInfo $ displayShow ("(clay) updating file " , fp)
|
||||
createDirectoryIfMissing True $ takeDirectory fp
|
||||
writeFile fp bs
|
||||
where
|
||||
|
||||
@ -178,7 +178,7 @@ startServ
|
||||
-> (Text -> RIO e ())
|
||||
-> RIO e Serv
|
||||
startServ who isFake conf plan stderr = do
|
||||
logDebug (displayShow ("EYRE", "startServ"))
|
||||
logInfo (displayShow ("EYRE", "startServ"))
|
||||
|
||||
multi <- view multiEyreApiL
|
||||
|
||||
@ -221,11 +221,11 @@ startServ who isFake conf plan stderr = do
|
||||
let onKilReq :: Ship -> Word64 -> STM ()
|
||||
onKilReq _ship = plan . cancelEv srvId . fromIntegral
|
||||
|
||||
logDebug (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
|
||||
logInfo (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
|
||||
|
||||
atomically (joinMultiEyre multi who mCre onReq onKilReq)
|
||||
|
||||
logDebug $ displayShow ("EYRE", "Starting loopback server")
|
||||
logInfo $ displayShow ("EYRE", "Starting loopback server")
|
||||
lop <- serv vLive $ ServConf
|
||||
{ scHost = soHost (pttLop ptt)
|
||||
, scPort = soWhich (pttLop ptt)
|
||||
@ -237,7 +237,7 @@ startServ who isFake conf plan stderr = do
|
||||
}
|
||||
}
|
||||
|
||||
logDebug $ displayShow ("EYRE", "Starting insecure server")
|
||||
logInfo $ displayShow ("EYRE", "Starting insecure server")
|
||||
ins <- serv vLive $ ServConf
|
||||
{ scHost = soHost (pttIns ptt)
|
||||
, scPort = soWhich (pttIns ptt)
|
||||
@ -250,7 +250,7 @@ startServ who isFake conf plan stderr = do
|
||||
}
|
||||
|
||||
mSec <- for mTls $ \tls -> do
|
||||
logDebug "Starting secure server"
|
||||
logInfo "Starting secure server"
|
||||
serv vLive $ ServConf
|
||||
{ scHost = soHost (pttSec ptt)
|
||||
, scPort = soWhich (pttSec ptt)
|
||||
@ -271,7 +271,7 @@ startServ who isFake conf plan stderr = do
|
||||
let por = Ports secPor insPor lopPor
|
||||
fil = pierPath <> "/.http.ports"
|
||||
|
||||
logDebug $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
|
||||
logInfo $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
|
||||
for secPor $ \p ->
|
||||
stderr ("http: secure web interface live on https://localhost:" <> tshow p)
|
||||
stderr ("http: web interface live on http://localhost:" <> tshow insPor)
|
||||
@ -351,10 +351,10 @@ eyre env who plan isFake stderr = (initialEvents, runHttpServer)
|
||||
|
||||
restart :: Drv -> HttpServerConf -> RIO e Serv
|
||||
restart (Drv var) conf = do
|
||||
logDebug "Restarting http server"
|
||||
logInfo "Restarting http server"
|
||||
let startAct = startServ who isFake conf plan stderr
|
||||
res <- fromEither =<< restartService var startAct kill
|
||||
logDebug "Done restating http server"
|
||||
logInfo "Done restating http server"
|
||||
pure res
|
||||
|
||||
liveFailed _ = pure ()
|
||||
@ -362,11 +362,11 @@ eyre env who plan isFake stderr = (initialEvents, runHttpServer)
|
||||
handleEf :: Drv -> HttpServerEf -> IO ()
|
||||
handleEf drv = runRIO env . \case
|
||||
HSESetConfig (i, ()) conf -> do
|
||||
logDebug (displayShow ("EYRE", "%set-config"))
|
||||
logInfo (displayShow ("EYRE", "%set-config"))
|
||||
Serv {..} <- restart drv conf
|
||||
logDebug (displayShow ("EYRE", "%set-config", "Sending %live"))
|
||||
logInfo (displayShow ("EYRE", "%set-config", "Sending %live"))
|
||||
atomically $ plan (EvErr (liveEv sServId sPorts) liveFailed)
|
||||
logDebug "Write ports file"
|
||||
logInfo "Write ports file"
|
||||
io (writePortsFile sPortsFile sPorts)
|
||||
HSEResponse (i, req, _seq, ()) ev -> do
|
||||
logDebug (displayShow ("EYRE", "%response"))
|
||||
|
||||
@ -72,7 +72,7 @@ leaveMultiEyre MultiEyreApi {..} who = do
|
||||
|
||||
multiEyre :: HasLogFunc e => MultiEyreConf -> RIO e MultiEyreApi
|
||||
multiEyre conf@MultiEyreConf {..} = do
|
||||
logDebug (displayShow ("EYRE", "MULTI", conf))
|
||||
logInfo (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
|
||||
logDebug (displayShow ("EYRE", "MULTI", "HTTP", por))
|
||||
logInfo (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
|
||||
logDebug (displayShow ("EYRE", "MULTI", "HTTPS", por))
|
||||
logInfo (displayShow ("EYRE", "MULTI", "HTTPS", por))
|
||||
serv vLive $ ServConf
|
||||
{ scHost = host
|
||||
, scPort = SPChoices $ singleton $ fromIntegral por
|
||||
|
||||
@ -164,7 +164,7 @@ tryOpenChoices
|
||||
tryOpenChoices hos = go
|
||||
where
|
||||
go (p :| ps) = do
|
||||
logDebug (displayShow ("EYRE", "Trying to open port.", p))
|
||||
logInfo (displayShow ("EYRE", "Trying to open port.", p))
|
||||
io (tryOpen hos p) >>= \case
|
||||
Left err -> do
|
||||
logError (displayShow ("EYRE", "Failed to open port.", p))
|
||||
@ -185,7 +185,7 @@ tryOpenAny hos = do
|
||||
pure (Right (p, s))
|
||||
|
||||
logDbg :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e ()
|
||||
logDbg ctx msg = logDebug (prefix <> suffix)
|
||||
logDbg ctx msg = logInfo (prefix <> suffix)
|
||||
where
|
||||
prefix = display (concat $ fmap (<> ": ") ctx)
|
||||
suffix = displayShow msg
|
||||
@ -312,7 +312,7 @@ configCreds TlsConfig {..} =
|
||||
fakeServ :: HasLogFunc e => ServConf -> RIO e ServApi
|
||||
fakeServ conf = do
|
||||
let por = fakePort (scPort conf)
|
||||
logDebug (displayShow ("EYRE", "SERV", "Running Fake Server", por))
|
||||
logInfo (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
|
||||
logDebug (displayShow ("EYRE", "SERV", "Running Real Server"))
|
||||
logInfo (displayShow ("EYRE", "SERV", "Running Real Server"))
|
||||
kil <- newEmptyTMVarIO
|
||||
por <- newEmptyTMVarIO
|
||||
|
||||
@ -344,7 +344,7 @@ realServ vLive conf@ServConf {..} = do
|
||||
}
|
||||
where
|
||||
runServ vPort = do
|
||||
logDebug (displayShow ("EYRE", "SERV", "runServ"))
|
||||
logInfo (displayShow ("EYRE", "SERV", "runServ"))
|
||||
rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
|
||||
atomically (putTMVar vPort por)
|
||||
startServer scType scHost por sok scRedi vLive
|
||||
|
||||
@ -31,21 +31,21 @@ restartService
|
||||
-> (s -> RIO e ())
|
||||
-> RIO e (Either SomeException s)
|
||||
restartService vServ sstart kkill = do
|
||||
logDebug "restartService"
|
||||
logInfo "restartService"
|
||||
modifyMVar vServ $ \case
|
||||
Nothing -> doStart
|
||||
Just sv -> doRestart sv
|
||||
where
|
||||
doRestart :: s -> RIO e (Maybe s, Either SomeException s)
|
||||
doRestart serv = do
|
||||
logDebug "doStart"
|
||||
logInfo "doStart"
|
||||
try (kkill serv) >>= \case
|
||||
Left exn -> pure (Nothing, Left exn)
|
||||
Right () -> doStart
|
||||
|
||||
doStart :: RIO e (Maybe s, Either SomeException s)
|
||||
doStart = do
|
||||
logDebug "doStart"
|
||||
logInfo "doStart"
|
||||
try sstart <&> \case
|
||||
Right s -> (Just s, Right s)
|
||||
Left exn -> (Nothing, Left exn)
|
||||
@ -59,7 +59,7 @@ stopService
|
||||
-> (s -> RIO e ())
|
||||
-> RIO e (Either SomeException ())
|
||||
stopService vServ kkill = do
|
||||
logDebug "stopService"
|
||||
logInfo "stopService"
|
||||
modifyMVar vServ $ \case
|
||||
Nothing -> pure (Nothing, Right ())
|
||||
Just sv -> do
|
||||
|
||||
@ -179,7 +179,7 @@ streamBlocks env init getAct = send init >> loop
|
||||
|
||||
send "" = pure ()
|
||||
send c = do
|
||||
runRIO env (logInfo (display ("sending chunk " <> tshow c)))
|
||||
runRIO env (logDebug (display ("sending chunk " <> tshow c)))
|
||||
yield $ Chunk $ fromByteString c
|
||||
yield Flush
|
||||
|
||||
|
||||
@ -140,7 +140,7 @@ client env plan = (initialEvents, runHttpClient)
|
||||
runReq HttpClientDrv{..} id req = async $
|
||||
case cvtReq req of
|
||||
Nothing -> do
|
||||
logDebug $ displayShow ("(malformed http client request)", id, req)
|
||||
logInfo $ displayShow ("(malformed http client request)", id, req)
|
||||
planEvent id (Cancel ())
|
||||
Just r -> do
|
||||
logDebug $ displayShow ("(http client request)", id, req)
|
||||
|
||||
@ -226,7 +226,7 @@ readRowsBatch :: ∀e. HasLogFunc e
|
||||
readRowsBatch env dbi first = readRows
|
||||
where
|
||||
readRows = do
|
||||
logDebug $ display ("(readRowsBatch) From: " <> tshow first)
|
||||
logInfo $ display ("(readRowsBatch) From: " <> tshow first)
|
||||
withWordPtr first $ \pIdx ->
|
||||
withKVPtrs' (MDB_val 8 (castPtr pIdx)) nullVal $ \pKey pVal ->
|
||||
rwith (readTxn env) $ \txn ->
|
||||
|
||||
@ -82,7 +82,7 @@ wsConn pre inp out wsc = do
|
||||
|
||||
flip finally cleanup $ do
|
||||
res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
|
||||
logDebug $ displayShow (res :: Either SomeException ())
|
||||
logInfo $ displayShow (res :: Either SomeException ())
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -95,7 +95,7 @@ wsClient pax por = do
|
||||
out <- io $ newTBMChanIO 5
|
||||
con <- pure (mkConn inp out)
|
||||
|
||||
logDebug "NOUNSERV (wsClie) Trying to connect"
|
||||
logInfo "NOUNSERV (wsClie) Trying to connect"
|
||||
|
||||
tid <- io $ async
|
||||
$ WS.runClient "127.0.0.1" por (unpack pax)
|
||||
@ -111,7 +111,7 @@ wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
|
||||
-> WS.PendingConnection
|
||||
-> RIO e ()
|
||||
wsServApp cb pen = do
|
||||
logDebug "NOUNSERV (wsServer) Got connection!"
|
||||
logInfo "NOUNSERV (wsServer) Got connection!"
|
||||
wsc <- io $ WS.acceptRequest pen
|
||||
inp <- io $ newTBMChanIO 5
|
||||
out <- io $ newTBMChanIO 5
|
||||
@ -125,10 +125,10 @@ wsServer = do
|
||||
|
||||
tid <- async $ do
|
||||
env <- ask
|
||||
logDebug "NOUNSERV (wsServer) Starting server"
|
||||
logInfo "NOUNSERV (wsServer) Starting server"
|
||||
io $ WS.runServer "127.0.0.1" 9999
|
||||
$ runRIO env . wsServApp (writeTBMChan con)
|
||||
logDebug "NOUNSERV (wsServer) Server died"
|
||||
logInfo "NOUNSERV (wsServer) Server died"
|
||||
atomically $ closeTBMChan con
|
||||
|
||||
pure $ Server (readTBMChan con) tid 9999
|
||||
|
||||
@ -178,21 +178,21 @@ bootNewShip
|
||||
-> RIO e ()
|
||||
bootNewShip pill lite ship bootEv = do
|
||||
seq@(BootSeq ident x y) <- genBootSeq ship pill lite bootEv
|
||||
logDebug "BootSeq Computed"
|
||||
logInfo "BootSeq Computed"
|
||||
|
||||
pierPath <- view pierPathL
|
||||
|
||||
rio (setupPierDirectory pierPath)
|
||||
logDebug "Directory setup."
|
||||
logInfo "Directory setup."
|
||||
|
||||
let logPath = (pierPath </> ".urb/log")
|
||||
|
||||
rwith (Log.new logPath ident) $ \log -> do
|
||||
logDebug "Event log onitialized."
|
||||
logInfo "Event log onitialized."
|
||||
jobs <- (\now -> bootSeqJobs now seq) <$> io Time.now
|
||||
writeJobs log (fromList jobs)
|
||||
|
||||
logDebug "Finsihed populating event log with boot sequence"
|
||||
logInfo "Finsihed populating event log with boot sequence"
|
||||
|
||||
|
||||
-- Resume an existing ship. ----------------------------------------------------
|
||||
@ -216,16 +216,16 @@ resumed vSlog replayUntil = do
|
||||
serf <- runSerf vSlog tap
|
||||
|
||||
rio $ do
|
||||
logDebug "Replaying events"
|
||||
logInfo "Replaying events"
|
||||
Serf.execReplay serf log replayUntil >>= \case
|
||||
Left err -> error (show err)
|
||||
Right 0 -> do
|
||||
logDebug "No work during replay so no snapshot"
|
||||
logInfo "No work during replay so no snapshot"
|
||||
pure ()
|
||||
Right _ -> do
|
||||
logDebug "Taking snapshot"
|
||||
logInfo "Taking snapshot"
|
||||
io (Serf.snapshot serf)
|
||||
logDebug "SNAPSHOT TAKEN"
|
||||
logInfo "SNAPSHOT TAKEN"
|
||||
|
||||
pure (serf, log)
|
||||
|
||||
@ -251,14 +251,14 @@ acquireWorker :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
|
||||
acquireWorker nam act = mkRAcquire (async act) kill
|
||||
where
|
||||
kill tid = do
|
||||
logDebug ("Killing worker thread: " <> display nam)
|
||||
logInfo ("Killing worker thread: " <> display nam)
|
||||
cancel tid
|
||||
|
||||
acquireWorkerBound :: HasLogFunc e => Text -> RIO e () -> RAcquire e (Async ())
|
||||
acquireWorkerBound nam act = mkRAcquire (asyncBound act) kill
|
||||
where
|
||||
kill tid = do
|
||||
logDebug ("Killing worker thread: " <> display nam)
|
||||
logInfo ("Killing worker thread: " <> display nam)
|
||||
cancel tid
|
||||
|
||||
|
||||
@ -293,11 +293,11 @@ pier (serf, log) vSlog startedSig = do
|
||||
pure (res, Term.useDemux res)
|
||||
|
||||
void $ acquireWorker "TERMSERV Listener" $ forever $ do
|
||||
logDebug "TERMSERV Waiting for external terminal."
|
||||
logInfo "TERMSERV Waiting for external terminal."
|
||||
atomically $ do
|
||||
ext <- Term.connClient <$> readTQueue termApiQ
|
||||
Term.addDemux ext demux
|
||||
logDebug "TERMSERV External terminal connected."
|
||||
logInfo "TERMSERV External terminal connected."
|
||||
|
||||
-- Slogs go to both stderr and to the terminal.
|
||||
env <- ask
|
||||
@ -377,7 +377,7 @@ pier (serf, log) vSlog startedSig = do
|
||||
threadDelay 15_000_000
|
||||
wen <- io Time.now
|
||||
let kal = \mTermNoun -> runRIO env $ do
|
||||
logDebug $ displayShow ("scry result: ", mTermNoun)
|
||||
logInfo $ displayShow ("scry result: ", mTermNoun)
|
||||
let nkt = MkKnot $ tshow $ Time.MkDate wen
|
||||
let pax = Path ["j", "~zod", "life", nkt, "~zod"]
|
||||
atomically $ putTMVar scrySig (wen, Nothing, pax, kal)
|
||||
@ -501,7 +501,7 @@ router slog waitFx Drivers {..} = do
|
||||
|
||||
logEvent :: HasLogFunc e => Ev -> RIO e ()
|
||||
logEvent ev = do
|
||||
logInfo $ "<- " <> display (summarizeEvent ev)
|
||||
--logInfo $ "<- " <> display (summarizeEvent ev)
|
||||
logDebug $ "[EVENT]\n" <> display pretty
|
||||
where
|
||||
pretty :: Text
|
||||
@ -509,7 +509,7 @@ logEvent ev = do
|
||||
|
||||
logEffect :: HasLogFunc e => Lenient Ef -> RIO e ()
|
||||
logEffect ef = do
|
||||
logInfo $ " -> " <> display (summarizeEffect ef)
|
||||
--logInfo $ " -> " <> display (summarizeEffect ef)
|
||||
logDebug $ display $ "[EFFECT]\n" <> pretty ef
|
||||
where
|
||||
pretty :: Lenient Ef -> Text
|
||||
|
||||
@ -40,7 +40,7 @@ withSerf config = mkRAcquire startup kill
|
||||
where
|
||||
startup = do
|
||||
(serf, st) <- io $ start config
|
||||
logDebug (displayShow ("serf state", st))
|
||||
logInfo (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
|
||||
logDebug "Beginning boot sequence"
|
||||
logInfo "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)
|
||||
|
||||
logDebug $ display ("Sending " <> tshow numEvs <> " boot events to serf")
|
||||
logInfo $ display ("Sending " <> tshow numEvs <> " boot events to serf")
|
||||
|
||||
io (boot serf evs) >>= \case
|
||||
Just err -> do
|
||||
logDebug "Error on replay, exiting"
|
||||
logInfo "Error on replay, exiting"
|
||||
pure (Left err)
|
||||
Nothing -> do
|
||||
logDebug "Finished boot events, moving on to more events from log."
|
||||
logInfo "Finished boot events, moving on to more events from log."
|
||||
doReplay <&> \case
|
||||
Left err -> Left err
|
||||
Right num -> Right (num + numEvs)
|
||||
|
||||
@ -472,7 +472,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
|
||||
loop rd
|
||||
else if w == 3 then do
|
||||
-- ETX (^C)
|
||||
logDebug $ displayShow "Ctrl-c interrupt"
|
||||
logInfo $ displayShow "Ctrl-c interrupt"
|
||||
atomically $ do
|
||||
writeTQueue wq [Term.Trace "interrupt\r\n"]
|
||||
writeTQueue rq $ Ctl $ Cord "c"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user