Enable NounServ logging, terminal logs to ~/.urbit/king.log

pkg/king/app/Main.hs

@@ -72,7 +72,8 @@ import Control.Concurrent   (myThreadId, runInBoundThread)
 import Control.Exception    (AsyncException(UserInterrupt))
 import Control.Lens         ((&))
 import Data.Default         (def)
-import King.App             (runApp, runPierApp, HasConfigDir(..))
+import King.App             (runApp, runAppLogFile, runPierApp)
+import King.App             (HasConfigDir(..))
 import System.Environment   (getProgName)
 import System.Exit          (exitSuccess)
 import System.Posix.Signals (Handler(Catch), installHandler, sigTERM)
@@ -487,7 +488,7 @@ main = do
         CLI.CmdBug (CLI.ValidateFX pax f l)     -> runApp $ checkFx  pax f l
         CLI.CmdBug (CLI.CheckDawn pax)          -> runApp $ checkDawn pax
         CLI.CmdBug CLI.CheckComet               -> runApp $ checkComet
-        CLI.CmdCon pier                         -> runApp $ connTerm pier
+        CLI.CmdCon pier                         -> runAppLogFile $ connTerm pier
 
 
 --------------------------------------------------------------------------------

pkg/king/lib/King/App.hs

@@ -1,6 +1,8 @@
 module King.App
     ( App
     , runApp
+    , runAppLogFile
+    , runAppLogHandle
     , runPierApp
     , HasConfigDir(..)
     ) where
@@ -8,6 +10,8 @@ module King.App
 import Config
 import UrbitPrelude
 
+import System.Directory (createDirectoryIfMissing, getHomeDirectory)
+
 --------------------------------------------------------------------------------
 
 class HasConfigDir a where
@@ -22,9 +26,9 @@ makeLenses ''App
 instance HasLogFunc App where
     logFuncL = appLogFunc
 
-runApp :: RIO App a -> IO a
-runApp inner = do
-    logOptions <- logOptionsHandle stderr True
+runAppLogHandle :: Handle -> RIO App a -> IO a
+runAppLogHandle logHandle inner = do
+    logOptions <- logOptionsHandle logHandle True
         <&> setLogUseTime True
         <&> setLogUseLoc False
 
@@ -33,6 +37,21 @@ runApp inner = do
   where
     go app = runRIO app inner
 
+runApp :: RIO App a -> IO a
+runApp = runAppLogHandle stdout
+
+runAppLogFile :: RIO App a -> IO a
+runAppLogFile inner = withLogFileHandle (\h -> runAppLogHandle h inner)
+  where
+    withLogFileHandle :: (Handle -> IO a) -> IO a
+    withLogFileHandle act = do
+        home <- getHomeDirectory
+        let logDir = home </> ".urbit"
+        createDirectoryIfMissing True logDir
+        withFile (logDir </> "king.log") AppendMode $ \handle -> do
+            hSetBuffering handle LineBuffering
+            act handle
+
 
 --------------------------------------------------------------------------------
 
@@ -59,7 +78,7 @@ instance HasConfigDir PierApp where
 
 runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> IO a
 runPierApp pierConfig networkConfig inner = do
-    logOptions <- logOptionsHandle stderr True
+    logOptions <- logOptionsHandle stdout True
         <&> setLogUseTime True
         <&> setLogUseLoc False
 

pkg/king/lib/KingApp.hs

@@ -0,0 +1,92 @@
+module KingApp
+    ( App
+    , runApp
+    , runPierApp
+    , HasAppName(..)
+    ) where
+
+import Config
+import RIO.Directory
+import UrbitPrelude
+
+--------------------------------------------------------------------------------
+
+class HasAppName env where
+    appNameL :: Lens' env Utf8Builder
+
+data App = App
+    { _appLogFunc :: !LogFunc
+    , _appName    :: !Utf8Builder
+    }
+
+makeLenses ''App
+
+instance HasLogFunc App where
+    logFuncL = appLogFunc
+
+instance HasAppName App where
+    appNameL = appName
+
+withLogFileHandle :: (Handle -> IO a) -> IO a
+withLogFileHandle act = do
+    home <- getHomeDirectory
+    let logDir = home <> "/log"
+    createDirectoryIfMissing True logDir
+    withTempFile logDir "king-" $ \_tmpFile handle -> do
+        hSetBuffering handle LineBuffering
+        act handle
+
+runApp :: RIO App a -> IO a
+runApp inner = do
+    withLogFileHandle $ \logFile -> do
+        logOptions <- logOptionsHandle stderr True
+            <&> setLogUseTime True
+            <&> setLogUseLoc False
+
+        withLogFunc logOptions $ \logFunc ->
+            go $ App { _appLogFunc = logFunc
+                     , _appName    = "Vere"
+                     }
+  where
+    go app = runRIO app inner
+
+
+--------------------------------------------------------------------------------
+
+-- A PierApp is like an App, except that it also provides a PierConfig
+data PierApp = PierApp
+    { _shipAppLogFunc       :: !LogFunc
+    , _shipAppName          :: !Utf8Builder
+    , _shipAppPierConfig    :: !PierConfig
+    , _shipAppNetworkConfig :: !NetworkConfig
+    }
+
+makeLenses ''PierApp
+
+instance HasLogFunc PierApp where
+    logFuncL = shipAppLogFunc
+
+instance HasAppName PierApp where
+    appNameL = shipAppName
+
+instance HasPierConfig PierApp where
+    pierConfigL = shipAppPierConfig
+
+instance HasNetworkConfig PierApp where
+    networkConfigL = shipAppNetworkConfig
+
+runPierApp :: PierConfig -> NetworkConfig -> RIO PierApp a -> IO a
+runPierApp pierConfig networkConfig inner = do
+    withLogFileHandle $ \logFile -> do
+        logOptions <- logOptionsHandle stderr True
+            <&> setLogUseTime True
+            <&> setLogUseLoc False
+
+        withLogFunc logOptions $ \logFunc ->
+            go $ PierApp { _shipAppLogFunc = logFunc
+                         , _shipAppName    = "Vere"
+                         , _shipAppPierConfig = pierConfig
+                         , _shipAppNetworkConfig = networkConfig
+                         }
+  where
+    go app = runRIO app inner

pkg/king/lib/Vere/NounServ.hs

@@ -40,7 +40,7 @@ data Server i o a = Server
 
 --------------------------------------------------------------------------------
 
-wsConn :: (FromNoun i, ToNoun o) -- , HasLogFunc e)
+wsConn :: (FromNoun i, ToNoun o, Show i, Show o, HasLogFunc e)
        => Utf8Builder
        -> TBMChan i -> TBMChan o
        -> WS.Connection
@@ -48,29 +48,29 @@ wsConn :: (FromNoun i, ToNoun o) -- , HasLogFunc e)
 wsConn pre inp out wsc = do
     env <- ask
 
-    --  logWarn (pre <> "(wcConn) Connected!")
+    logWarn (pre <> "(wcConn) Connected!")
 
     writer <- io $ async $ runRIO env $ forever $ do
-        --  logWarn (pre <> "(wsConn) Waiting for data.")
+        logWarn (pre <> "(wsConn) Waiting for data.")
         byt <- io $ toStrict <$> WS.receiveData wsc
-        --  logWarn (pre <> "Got data")
+        logWarn (pre <> "Got data")
         dat <- cueBSExn byt >>= fromNounExn
-        --  logWarn (pre <> "(wsConn) Decoded data, writing to chan")
+        logWarn (pre <> "(wsConn) Decoded data, writing to chan")
         atomically $ writeTBMChan inp dat
 
     reader <- io $ async $ runRIO env $ forever $ do
-        --  logWarn (pre <> "Waiting for data from chan")
+        logWarn (pre <> "Waiting for data from chan")
         atomically (readTBMChan out) >>= \case
             Nothing  -> do
-                --  logWarn (pre <> "(wsConn) Connection closed")
+                logWarn (pre <> "(wsConn) Connection closed")
                 error "dead-conn"
             Just msg -> do
-                -- logWarn (pre <> "(wsConn) Got message! " <> displayShow msg)
+                logWarn (pre <> "(wsConn) Got message! " <> displayShow msg)
                 io $ WS.sendBinaryData wsc $ fromStrict $ jamBS $ toNoun msg
 
     res <- atomically (waitCatchSTM writer <|> waitCatchSTM reader)
 
-    --  logWarn $ displayShow (res :: Either SomeException ())
+    logWarn $ displayShow (res :: Either SomeException ())
 
     atomically (closeTBMChan inp >> closeTBMChan out)
 
@@ -79,7 +79,7 @@ wsConn pre inp out wsc = do
 
 --------------------------------------------------------------------------------
 
-wsClient :: ∀i o e. (ToNoun o, FromNoun i, HasLogFunc e)
+wsClient :: ∀i o e. (ToNoun o, FromNoun i, Show o, Show i, HasLogFunc e)
          => Text -> W.Port -> RIO e (Client i o)
 wsClient pax por = do
     env <- ask
@@ -87,7 +87,7 @@ wsClient pax por = do
     out <- io $ newTBMChanIO 5
     con <- pure (mkConn inp out)
 
-    -- logDebug "NOUNSERV (wsClie) Trying to connect"
+    logDebug "NOUNSERV (wsClie) Trying to connect"
 
     tid <- io $ async
               $ WS.runClient "127.0.0.1" por (unpack pax)
@@ -97,7 +97,7 @@ wsClient pax por = do
 
 --------------------------------------------------------------------------------
 
-wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i)
+wsServApp :: (HasLogFunc e, ToNoun o, FromNoun i, Show i, Show o)
           => (Conn i o -> STM ())
           -> WS.PendingConnection
           -> RIO e ()
@@ -109,7 +109,7 @@ wsServApp cb pen = do
     atomically $ cb (mkConn inp out)
     wsConn "NOUNSERV (wsServ) " inp out wsc
 
-wsServer :: ∀i o e. (ToNoun o, FromNoun i, HasLogFunc e)
+wsServer :: ∀i o e. (ToNoun o, FromNoun i, Show i, Show o, HasLogFunc e)
          => RIO e (Server i o W.Port)
 wsServer = do
     con <- io $ newTBMChanIO 5