Implement logging for SSH using monad-logger and fast-logger

src/Vervis/Application.hs

@@ -47,6 +47,7 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                              mkRequestLogger, outputFormat)
 import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
+import Yesod.Default.Main                   (LogFunc)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -64,6 +65,9 @@ import Vervis.Ssh (runSsh)
 -- comments there for more details.
 mkYesodDispatch "App" resourcesApp
 
+loggingFunction :: App -> LogFunc
+loggingFunction app = messageLoggerSource app (appLogger app)
+
 -- | This function allocates resources (such as a database connection pool),
 -- performs initialization and returns a foundation datatype value. This is also
 -- the place to put your migrate statements to have automatic database
@@ -88,7 +92,7 @@ makeFoundation appSettings = do
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
         tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
-        logFunc = messageLoggerSource tempFoundation appLogger
+        logFunc = loggingFunction tempFoundation
 
     -- Create the database connection pool
     pool <- flip runLoggingT logFunc $ createPostgresqlPool
@@ -130,9 +134,8 @@ warpSettings foundation =
       setPort (appPort $ appSettings foundation)
     $ setHost (appHost $ appSettings foundation)
     $ setOnException (\_req e ->
-        when (defaultShouldDisplayException e) $ messageLoggerSource
+        when (defaultShouldDisplayException e) $ loggingFunction
             foundation
-            (appLogger foundation)
             $(qLocation >>= liftLoc)
             "yesod"
             LevelError
@@ -155,6 +158,13 @@ getAppSettings = loadAppSettings [configSettingsYml] [] useEnv
 develMain :: IO ()
 develMain = develMainHelper getApplicationDev
 
+sshServer :: App -> IO ()
+sshServer foundation =
+    runSsh
+        (appSettings foundation)
+        (appConnPool foundation)
+        (loggingFunction foundation)
+
 -- | The @main@ function for an executable running this site.
 appMain :: IO ()
 appMain = do
@@ -174,7 +184,7 @@ appMain = do
     app <- makeApplication foundation
 
     -- [experimental] Run SSH server and pray
-    forkIO $ runSsh settings (appConnPool foundation)
+    forkIO $ sshServer foundation
 
     -- Run the application with Warp
     runSettings (warpSettings foundation) app

src/Vervis/Field/Key.hs

@@ -87,8 +87,5 @@ checkContent =
             Left s  -> Left $ T.pack s
             Right b -> Right b
 
---TODO make the above work over ByteString and when passes the check, apply
---base64 conversion. delete my rel4 key from the DB and re-insert...
-
 contentField :: Field Handler ByteString
 contentField = checkContent bsField

src/Vervis/Ssh.hs

@@ -22,24 +22,32 @@ import Prelude
 
 import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Logger
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
 import Data.ByteString.Char8 (ByteString, unpack)
 import Data.ByteString.Lazy (fromStrict)
 import Data.Foldable (find)
-import Data.Text (pack)
+import Data.Text (Text, pack)
 import Database.Persist
 import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool)
 import Network.SSH
 import Network.SSH.Channel
 import Network.SSH.Crypto
 import Network.SSH.Session
+import Yesod.Default.Main (LogFunc)
 
 import Vervis.Model
 import Vervis.Settings
 
-type ChannelB = ReaderT ConnectionPool IO
-type SessionB = ReaderT ConnectionPool IO
+-- TODO:
+-- [x] Implement serious logging (info, warning, error, etc.) with
+--     monad-logger, maybe see how loggin works in the scaffolding
+-- [ ] See which git commands darcsden SSH supports and see if I can implement
+--     them with Hit (i think it was git upload-pack)
+
+type ChannelB = LoggingT (ReaderT ConnectionPool IO)
+type SessionB = LoggingT (ReaderT ConnectionPool IO)
 type Backend = SqlBackend
 
 type Channel = ChannelT ChannelB
@@ -47,14 +55,17 @@ type Session = SessionT SessionB ChannelB
 type SshChanDB = ReaderT Backend Channel
 type SshSessDB = ReaderT Backend Session
 
+src :: Text
+src = "SSH"
+
 runChanDB :: SshChanDB a -> Channel a
 runChanDB action = do
-    pool <- lift ask
+    pool <- lift . lift $ ask
     runSqlPool action pool
 
 runSessDB :: SshSessDB a -> Session a
 runSessDB action = do
-    pool <- lift ask
+    pool <- lift . lift $ ask
     runSqlPool action pool
 
 chanFail :: Bool -> ByteString -> Channel ()
@@ -73,7 +84,7 @@ authorize (PublicKey name key) = do
                 fmap Just $ selectList [SshKeyPerson ==. pid] []
     case mkeys of
         Nothing -> do
-            liftIO $ putStrLn "[SSH] auth failed: invalid user"
+            $logInfoS src "Auth failed: Invalid user"
             return False
         Just keys -> do
             let eValue (Entity _ v) = v
@@ -81,11 +92,10 @@ authorize (PublicKey name key) = do
                     (== key) . blobToKey . fromStrict . sshKeyContent . eValue
             case find matches keys of
                 Nothing -> do
-                    liftIO $
-                        putStrLn "[SSH] auth failed: no matching key found"
+                    $logInfoS src "Auth failed: No matching key found"
                     return False
                 Just match -> do
-                    liftIO $ putStrLn "[SSH] auth succeeded"
+                    $logInfoS src "Auth succeeded"
                     return True
 
 handle :: Bool -> ChannelRequest -> Channel ()
@@ -93,28 +103,34 @@ handle wantReply request = do
     liftIO $ print request
     chanFail wantReply "I don't execute any commands yet, come back later"
 
-ready :: IO ()
-ready = putStrLn "SSH server component running"
+ready :: LogFunc -> IO ()
+ready = runLoggingT $ $logInfoS src "SSH server component starting"
 
-mkConfig :: AppSettings -> ConnectionPool -> IO (Config SessionB ChannelB)
-mkConfig settings pool = do
+mkConfig
+    :: AppSettings
+    -> ConnectionPool
+    -> LogFunc
+    -> IO (Config SessionB ChannelB)
+mkConfig settings pool logFunc = do
     keyPair <- keyPairFromFile $ appSshKeyFile settings
     return $ Config
         { cSession     = SessionConfig
             { scAuthMethods  = ["publickey"]
             , scAuthorize    = authorize
             , scKeyPair      = keyPair
-            , scRunBaseMonad = flip runReaderT pool
+            , scRunBaseMonad =
+                flip runReaderT pool . flip runLoggingT logFunc
             }
         , cChannel     = ChannelConfig
             { ccRequestHandler = handle
-            , ccRunBaseMonad   = flip runReaderT pool
+            , ccRunBaseMonad   =
+                flip runReaderT pool . flip runLoggingT logFunc
             }
         , cPort        = fromIntegral $ appSshPort settings
-        , cReadyAction = ready
+        , cReadyAction = ready logFunc
         }
 
-runSsh :: AppSettings -> ConnectionPool -> IO ()
-runSsh settings pool = do
-    config <- mkConfig settings pool
+runSsh :: AppSettings -> ConnectionPool -> LogFunc -> IO ()
+runSsh settings pool logFunc = do
+    config <- mkConfig settings pool logFunc
     startConfig config