From fc4690324c94f801f54cf44ff82b17356c5cf81c Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 9 Mar 2016 22:27:25 +0000 Subject: [PATCH] Implement logging for SSH using monad-logger and fast-logger --- src/Vervis/Application.hs | 18 ++++++++++--- src/Vervis/Field/Key.hs | 3 --- src/Vervis/Ssh.hs | 54 +++++++++++++++++++++++++-------------- 3 files changed, 49 insertions(+), 26 deletions(-) diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index e8ea9dc..5c07697 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/Field/Key.hs b/src/Vervis/Field/Key.hs index 1b0ffc4..b2f8993 100644 --- a/src/Vervis/Field/Key.hs +++ b/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 diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index b5677bb..24d56b7 100644 --- a/src/Vervis/Ssh.hs +++ b/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