From 3eee205eaf95bf54a80a71bad21ee4b36a9fa8d2 Mon Sep 17 00:00:00 2001 From: me Date: Thu, 7 Nov 2024 22:22:42 +0200 Subject: [PATCH] logging --- .gitignore | 2 ++ app/DB.hs | 3 +++ app/Main.hs | 19 ++++++++++++------- app/Routes.hs | 18 ++++++++++++------ fedi.cabal | 4 ++++ src/Fedi/Crypto.hs | 14 ++++++++------ src/Fedi/Helpers.hs | 5 +++++ src/Fedi/Requests.hs | 20 ++++++++++++++++---- src/Fedi/Routes/Inbox.hs | 6 ++++-- src/Fedi/Signature/Check.hs | 4 ++-- 10 files changed, 68 insertions(+), 27 deletions(-) diff --git a/.gitignore b/.gitignore index 460286e..3157ceb 100644 --- a/.gitignore +++ b/.gitignore @@ -4,3 +4,5 @@ templates/ website/ user-data/ out/ +notes/ +fedi.log diff --git a/app/DB.hs b/app/DB.hs index f6eac8d..49e58cd 100644 --- a/app/DB.hs +++ b/app/DB.hs @@ -42,12 +42,14 @@ data NoteEntry , name :: Maybe String , url :: Maybe Url } + deriving Show data FollowerEntry = FollowerEntry { followId :: T.Text , actorId :: T.Text } + deriving Show data Follower = Follower @@ -55,6 +57,7 @@ data Follower , followId :: T.Text , actorId :: T.Text } + deriving Show ----------------------- diff --git a/app/Main.hs b/app/Main.hs index 33e0c90..ee791b6 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -16,6 +16,7 @@ import Network.Wai.Middleware.Routed qualified as Wai import Routes import System.Environment (getArgs, lookupEnv) import Web.Twain qualified as Twain +import Control.Logger.Simple qualified as Log data Command = Serve @@ -63,15 +64,18 @@ insertNoteFromFile file = do print note serve :: IO () -serve = do +serve = Log.withGlobalLogging (Log.LogConfig (Just "fedi.log") True) do + logLevel <- maybe Log.LogDebug read <$> lookupEnv "FEDI_LOG_LEVEL" + Log.setLogLevel logLevel + auth <- fmap (T.splitOn "," . T.pack) <$> lookupEnv "FEDI_AUTH" authMiddleware <- case auth of Nothing -> do - putStrLn "Starting server with authentication disabled." + Log.logInfo "Starting server with authentication disabled." pure id Just [user, pass] -> do - putStrLn "Starting server with authentication enabled," + Log.logInfo "Starting server with authentication enabled," let username = secureMemFromByteString $ T.encodeUtf8 user password = secureMemFromByteString $ T.encodeUtf8 pass @@ -87,7 +91,7 @@ serve = do fediPort <- maybe 3001 read <$> lookupEnv "FEDI_PORT" conn <- maybe "/tmp/fediserve_sqlite_db.sqlite" fromString <$> lookupEnv "FEDI_CONN_STRING" - putStrLn $ "and with connection string " <> show (Sqlite.unConnectionString conn) <> "." + Log.logInfo $ "and with connection string " <> Sqlite.unConnectionString conn <> "." runServer fediPort authMiddleware =<< mkFediApp conn @@ -101,15 +105,16 @@ usageError = , " - FEDI_DETAILS=" , " - FEDI_CONN_STRING=" , " - FEDI_AUTH=," + , " - FEDI_LOG=[ LogTrace | LogDebug | LogInfo | LogNote | LogWarn | LogError ]" ] -- | Run server at at specific port. runServer :: Port -> Twain.Middleware -> Twain.Application -> IO () runServer port authMiddleware app = do - putStrLn $ - unwords + Log.logInfo $ + T.unwords [ "Running fedi at" - , "http://localhost:" <> show port + , "http://localhost:" <> T.pack (show port) , "(ctrl-c to quit)" ] auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware diff --git a/app/Routes.hs b/app/Routes.hs index 383604e..75d810c 100644 --- a/app/Routes.hs +++ b/app/Routes.hs @@ -11,6 +11,7 @@ import System.IO.Unsafe (unsafePerformIO) import Web.Twain qualified as Twain import Data.Text qualified as T import Control.Concurrent.Async qualified as Async +import Control.Logger.Simple qualified as Log routes :: DB -> FilePath -> [Twain.Middleware] routes db detailsFile = @@ -48,6 +49,7 @@ routes db detailsFile = , -- Match inbox Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do + Log.logTrace "Inbox" Fedi.handleInbox (handleInbox db detailsFile) , -- Match Create object @@ -128,6 +130,7 @@ noteToCreate note = Fedi.makeCreateNote note handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response handleInbox db detailsFile activity = do details <- liftIO $ fetchUserDetails detailsFile + Log.logDebug (Fedi.pShow activity) case activity of Fedi.ActivityFollow follow -> do let @@ -153,11 +156,12 @@ handleInbox db detailsFile activity = do follow (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId) ) - print result - pure $ Fedi.jsonLD "{}" + Log.logDebug (Fedi.pShow result) + pure $ Twain.text "" ) liftIO do insertFollower db followerEntry callback + <* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry) else Twain.next Nothing -> Twain.next @@ -182,19 +186,21 @@ handleInbox db detailsFile activity = do { actorId = fromString actor.unwrap , followId = fromString id''.unwrap } - print ("deleted follower: " <> show deletedId) - pure $ Fedi.jsonLD "{}" + Log.logInfo ("deleted follower: " <> Fedi.pShow deletedId) + pure $ Twain.text "" else Twain.next Nothing -> Twain.next _ -> do - liftIO (print activity) + Log.logError $ "Unsupported activity: " <> Fedi.pShow activity Twain.next sendFollowers :: Fedi.UserDetails -> DB -> Fedi.AnyActivity -> IO () sendFollowers details db message = do + Log.logDebug $ "Sending to followers: " <> Fedi.pShow message followers <- db.getFollowers Fedi.for_ followers \follower -> do Async.async $ do + Log.logDebug $ "Sending to follower: " <> Fedi.pShow follower.actorId bs <- Fedi.sendPost details (T.unpack follower.actorId <> "/inbox") message - print (follower.actorId, bs) + Log.logDebug $ "Sent to follower: " <> Fedi.pShow (follower.actorId, bs) diff --git a/fedi.cabal b/fedi.cabal index 8d6fb15..4adf968 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -64,6 +64,8 @@ library , raw-strings-qq , case-insensitive , http-types + , simple-logger + , pretty-simple hs-source-dirs: src default-language: GHC2021 @@ -102,6 +104,8 @@ executable fedi , raw-strings-qq , securemem , lucid2 + , simple-logger + , pretty-simple hs-source-dirs: app default-language: GHC2021 diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index 5c4e3ad..e4ec554 100644 --- a/src/Fedi/Crypto.hs +++ b/src/Fedi/Crypto.hs @@ -12,14 +12,16 @@ import Fedi.Helpers import Data.ByteString.Base64 qualified as Base64 import Data.Base64.Types qualified as Base64 import Data.Text qualified as T +import Control.Logger.Simple qualified as Log +import Control.Monad.IO.Class --- import Debug.Trace - -verifyPub :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool +verifyPub :: MonadIO m => MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool verifyPub pubkeypem sig message = do - -- traceShowM ("pubkeypem", pubkeypem) - -- traceShowM ("sig", sig) - -- traceShowM ("mssage", message) + Log.logDebug $ "Verifying signature: " <> pShow + [ ("pubkeypem", pubkeypem) + , ("sig", sig) + , ("message", message) + ] pubkey <- case Crypto.readPubKeyFileFromMemory pubkeypem of diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs index 354973a..72cad65 100644 --- a/src/Fedi/Helpers.hs +++ b/src/Fedi/Helpers.hs @@ -17,6 +17,8 @@ import Control.Monad as Export import Data.Functor as Export import Data.Function as Export import Control.Monad.Catch as Export (throwM, Exception, MonadThrow) +import Text.Pretty.Simple qualified as PS +import Data.Text.Lazy qualified as TL data Error = Error String @@ -24,3 +26,6 @@ data Error throw :: MonadThrow m => String -> m a throw = throwM . Error + +pShow :: Show a => a -> Text +pShow = TL.toStrict . PS.pShow diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs index 9211fd2..960500b 100644 --- a/src/Fedi/Requests.hs +++ b/src/Fedi/Requests.hs @@ -11,6 +11,7 @@ import Network.HTTP.Req qualified as Req import Data.ByteString.Lazy qualified as BSL import Text.URI qualified as URI import Data.Text qualified as T +import Control.Logger.Simple qualified as Log sendPost :: A.ToJSON input @@ -22,10 +23,12 @@ sendPost details url payload = do uri <- URI.mkURI $ fromString url let encoded = BSL.toStrict $ A.encode payload httpSignature <- makeHttpSignature details uri encoded + Log.logDebug $ "http signature: " <> pShow httpSignature + Log.logDebug $ "http signature headers: " <> pShow (makeSigHeaders httpSignature) (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri) Req.runReq Req.defaultHttpConfig do - r <- - Req.req + response <- + Req.reqCb Req.POST url' (Req.ReqBodyBs encoded) @@ -33,7 +36,12 @@ sendPost details url payload = do ( scheme <> sigHeaders httpSignature ) - pure $ Req.responseBody r + (\request -> do + Log.logDebug $ "Sending POST request: " <> pShow request + pure request + ) + Log.logInfo $ "Response: " <> pShow response + pure $ Req.responseBody response makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature makeHttpSignature details uri encoded = do @@ -71,7 +79,7 @@ sendGet url = do Req.runReq Req.defaultHttpConfig do r <- - Req.req + Req.reqCb Req.GET url' Req.NoReqBody @@ -79,4 +87,8 @@ sendGet url = do ( scheme <> Req.header "ContentType" "application/activity+json" ) + (\request -> do + Log.logDebug $ "Sending GET request: " <> pShow request + pure request + ) pure $ Req.responseBody r diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs index b9180db..b259247 100644 --- a/src/Fedi/Routes/Inbox.hs +++ b/src/Fedi/Routes/Inbox.hs @@ -2,12 +2,13 @@ module Fedi.Routes.Inbox where import Prelude hiding (error) import Fedi.Types +import Fedi.Helpers import Fedi.UserDetails import Web.Twain qualified as Twain import Web.Twain.Types qualified as Twain -import Control.Monad.IO.Class (liftIO) import Control.Monad.Catch (catch, displayException, SomeException) import Fedi.Signature.Check +import Control.Logger.Simple qualified as Log -- * Inbox @@ -23,7 +24,8 @@ handleInbox handle = do response <- handle activity Twain.send response handler `catch` \(e :: SomeException) -> do - liftIO $ putStrLn (displayException e) + Log.logError (pShow $ displayException e) Twain.send $ + -- not necessarily 500, but we'll do this for now. Twain.status Twain.status500 $ Twain.text "Internal Server Error 500" diff --git a/src/Fedi/Signature/Check.hs b/src/Fedi/Signature/Check.hs index 5f3d491..ac40e51 100644 --- a/src/Fedi/Signature/Check.hs +++ b/src/Fedi/Signature/Check.hs @@ -17,7 +17,6 @@ import Web.Twain qualified as Twain import Data.Text qualified as T import Network.Wai qualified as Wai import Network.HTTP.Types.URI qualified as HTTP -import Control.Monad.IO.Class (liftIO) import Text.ParserCombinators.ReadP qualified as P import Data.Text.Encoding qualified as T import Data.ByteString qualified as BS @@ -25,6 +24,7 @@ import Data.ByteString.Lazy qualified as BSL import Fedi.Crypto import Fedi.Signature.Types import Data.CaseInsensitive qualified as CI +import Control.Monad.IO.Class -- * Check @@ -83,7 +83,7 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do BS.intercalate "\n" <$> traverse mylookup headers checkSignature - :: MonadThrow m + :: MonadIO m => MonadThrow m => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m () checkSignature personPkid personPublicKey sigheader signatureString digest body = do -- check