logging

.gitignore

@@ -4,3 +4,5 @@ templates/
 website/
 user-data/
 out/
+notes/
+fedi.log

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
 
 -----------------------
 

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=<FILE>"
       , " - FEDI_CONN_STRING=<SQLITE_CONN_STR>"
       , " - FEDI_AUTH=<user>,<password>"
+      , " - 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 $
+  Log.logInfo $
-    unwords
+    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

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
+                    Log.logDebug (Fedi.pShow result)
-                    pure $ Fedi.jsonLD "{}"
+                    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)
+                Log.logInfo ("deleted follower: " <> Fedi.pShow deletedId)
-                pure $ Fedi.jsonLD "{}"
+                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)

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

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 :: MonadIO m => MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
-
-verifyPub :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
 verifyPub pubkeypem sig message = do
-  -- traceShowM ("pubkeypem", pubkeypem)
+  Log.logDebug $ "Verifying signature: " <> pShow
-  -- traceShowM ("sig", sig)
+    [ ("pubkeypem", pubkeypem)
-  -- traceShowM ("mssage", message)
+    , ("sig", sig)
+    , ("message", message)
+    ]
 
   pubkey <-
     case Crypto.readPubKeyFileFromMemory pubkeypem of

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

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 <-
+    response <-
-      Req.req
+      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

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"

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