Add request logging

app/Main.hs

@@ -11,7 +11,7 @@ import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
 import Data.Proxy (Proxy (..))
 import Data.Time (Day, toGregorian)
 import Network.HTTP.Media ((//), (/:))
-import Network.HTTP.Types (status200)
+import Network.HTTP.Types (Status (..), status200)
 import Servant
   ( Accept (..)
   , Capture
@@ -32,7 +32,7 @@ import Text.Printf (printf)
 import qualified Data.ByteString.Char8 as BS8
 import qualified Data.Text as Text
 import qualified Database.PostgreSQL.Opium as Opium
-import Network.Wai (responseFile)
+import Network.Wai (Request (..), responseFile)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
@@ -41,6 +41,7 @@ import Yore.DB (DayFile (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
 import qualified Yore.DB as DB
+import qualified Yore.Log as Log
 
 instance Exception Opium.ConnectionError
 
@@ -55,10 +56,20 @@ main = do
         Opium.close
         10
         maxResources
-  Warp.run 3000 $ serve (Proxy :: Proxy API) $ server connPool
+  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server connPool
   where
     unsafeConnect s = either throwIO pure =<< Opium.connect s
 
+    settings = Warp.setLogger logger Warp.defaultSettings
+
+    logger req status _ = do
+      Log.info $
+        printf
+          "%d %s %s"
+          (statusCode status)
+          (BS8.unpack $ requestMethod req)
+          (BS8.unpack $ rawPathInfo req <> rawQueryString req)
+
 type API =
   Get '[HTML] RootModel
     :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel

src/Yore/Log.hs

@@ -0,0 +1,19 @@
+module Yore.Log (info) where
+
+import Data.Time (getZonedTime)
+import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)
+import Text.Printf (printf)
+
+info :: (HasCallStack) => String -> IO ()
+info = doLog "INF"
+
+doLog :: (HasCallStack) => String -> String -> IO ()
+doLog level msg = do
+  now <- getZonedTime
+  let location = getLocation $ getCallStack callStack
+  printf "(%s) (%s) (%s) %s\n" (show now) location level msg
+  where
+    getLocation :: [(String, SrcLoc)] -> String
+    -- First entry is always a function from this module, skip it
+    getLocation (_ : (_, srcLoc) : _) = printf "%s:%d" (srcLocFile srcLoc) (srcLocStartLine srcLoc)
+    getLocation _ = ""

yore.cabal

@@ -36,6 +36,7 @@ library
       Yore.DB
     , Yore.Download
     , Yore.Index
+    , Yore.Log
     , Yore.Repl
     , Yore.Scrape
     , Yore.Time