Make logger more testable

jaspervdj · jaspervdj · Aug 23, 2023 · Aug 3, 2022 · Aug 3, 2022 · Aug 3, 2022
commit 5c70f28643c718368a1eafb3d10f801efd5a7ede
diff --git a/lib/Hakyll/Core/Logger.hs b/lib/Hakyll/Core/Logger.hs
@@ -1,5 +1,6 @@
 --------------------------------------------------------------------------------
 -- | Produce pretty, thread-safe logs
+{-# LANGUAGE Rank2Types #-}
 module Hakyll.Core.Logger
     ( Verbosity (..)
     , Logger
@@ -9,15 +10,19 @@ module Hakyll.Core.Logger
     , header
     , message
     , debug
+
+    -- * Testing utilities
+    , newInMem
     ) where
 
 
 --------------------------------------------------------------------------------
 import           Control.Concurrent      (forkIO)
-import           Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
-import           Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
-import           Control.Monad           (forever)
+import           Control.Concurrent.Chan (newChan, readChan, writeChan)
+import           Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import           Control.Monad           (forever, when)
 import           Control.Monad.Trans     (MonadIO, liftIO)
+import qualified Data.IORef              as IORef
 import           Data.List               (intercalate)
 import           Prelude                 hiding (error)
 
@@ -31,51 +36,34 @@ data Verbosity
 
 
 --------------------------------------------------------------------------------
--- | Logger structure. Very complicated.
 data Logger = Logger
-    { loggerChan      :: Chan (Maybe String)  -- ^ Nothing marks the end
-    , loggerSync      :: MVar ()              -- ^ Used for sync on quit
-    , loggerSink      :: String -> IO ()      -- ^ Out sink
-    , loggerVerbosity :: Verbosity            -- ^ Verbosity
+    { -- | Flush the logger (blocks until flushed)
+      flush  :: forall m. MonadIO m => m ()
+    , string :: forall m. MonadIO m => Verbosity -> String -> m ()
     }
 
 
 --------------------------------------------------------------------------------
 -- | Create a new logger
 new :: Verbosity -> IO Logger
 new vbty = do
-    logger <- Logger <$>
-        newChan <*> newEmptyMVar <*> pure putStrLn <*> pure vbty
-    _      <- forkIO $ loggerThread logger
-    return logger
-  where
-    loggerThread logger = forever $ do
-        msg <- readChan $ loggerChan logger
+    chan <- newChan
+    sync <- newEmptyMVar
+    _    <- forkIO $ forever $ do
+        msg <- readChan chan
         case msg of
             -- Stop: sync
-            Nothing -> putMVar (loggerSync logger) ()
+            Nothing -> putMVar sync ()
             -- Print and continue
-            Just m  -> loggerSink logger m
-
-
---------------------------------------------------------------------------------
--- | Flush the logger (blocks until flushed)
-flush :: Logger -> IO ()
-flush logger = do
-    writeChan (loggerChan logger) Nothing
-    () <- takeMVar $ loggerSync logger
-    return ()
-
-
---------------------------------------------------------------------------------
-string :: MonadIO m
-       => Logger     -- ^ Logger
-       -> Verbosity  -- ^ Verbosity of the string
-       -> String     -- ^ Section name
-       -> m ()       -- ^ No result
-string l v m
-    | loggerVerbosity l >= v = liftIO $ writeChan (loggerChan l) (Just m)
-    | otherwise              = return ()
+            Just m  -> putStrLn m
+    return $ Logger
+        { flush = liftIO $ do
+            writeChan chan Nothing
+            () <- takeMVar sync
+            return ()
+        , string = \v m -> when (vbty >= v) $
+            liftIO $ writeChan chan (Just m)
+        }
 
 
 --------------------------------------------------------------------------------
@@ -101,3 +89,19 @@ debug l m = string l Debug $ "  [DEBUG] " ++ indent m
 --------------------------------------------------------------------------------
 indent :: String -> String
 indent = intercalate "\n    " . lines
+
+
+--------------------------------------------------------------------------------
+-- | Create a new logger that just stores all the messages, useful for writing
+-- tests.
+newInMem :: IO (Logger, IO [(Verbosity, String)])
+newInMem = do
+    ref <- IORef.newIORef []
+    pure
+        ( Logger
+            { string = \vbty msg -> liftIO $ IORef.atomicModifyIORef' ref $
+                \msgs -> ((vbty, msg) : msgs, ())
+            , flush  = pure ()
+            }
+        , reverse <$> IORef.readIORef ref
+        )
diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs
@@ -102,7 +102,7 @@ case02 = do
 -- Test that dependency cycles are correctly identified
 case03 :: Assertion
 case03 = do
-    logger  <- Logger.new Logger.Error
+    (logger, inMemLog) <- Logger.newInMem
     (ec, _) <- run RunModeNormal testConfiguration logger $ do
 
         create ["partial.html.out1"] $ do
@@ -119,8 +119,8 @@ case03 = do
                 makeItem example
                     >>= loadAndApplyTemplate "partial.html" defaultContext
 
-
     ec @?= ExitFailure 1
+    inMemLog >>= print
 
     cleanTestEnv
 
@@ -221,4 +221,4 @@ case06 = do
 
     ec @?= ExitSuccess
 
-    cleanTestEnv
+    cleanTestEnv