Add errors for multiple writes to the same file

See #1000
jaspervdj · Sep 1, 2023 · 55e96c4 · 55e96c4
1 parent 832e3c1
commit 55e96c4
Show file tree

Hide file tree

Showing 2 changed files with 57 additions and 3 deletions.
diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs
@@ -137,6 +137,9 @@ data Scheduler = Scheduler
       schedulerDone      :: !(Set Identifier)
     , -- | Any snapshots stored.
       schedulerSnapshots :: !(Set (Identifier, Snapshot))
+    , -- | Any files and who wrote them.  This is used to detect multiple writes
+      -- to the same file, which can yield inconsistent results.
+      schedulerRoutes    :: !(Map FilePath Identifier)
     , -- | Currently blocked compilers.
       schedulerBlocked   :: !(Set Identifier)
     , -- | Compilers that may resume on triggers
@@ -160,6 +163,7 @@ emptyScheduler = Scheduler {..}
     schedulerQueue     = Seq.empty
     schedulerWorking   = Set.empty
     schedulerSnapshots = Set.empty
+    schedulerRoutes    = Map.empty
     schedulerBlocked   = Set.empty
     schedulerTriggers  = Map.empty
     schedulerStarved   = 0
@@ -344,6 +348,25 @@ schedulerWrite identifier depFacts scheduler0@Scheduler {..} =
         _                   -> (scheduler2, step)
 
 
+--------------------------------------------------------------------------------
+-- | Record that a specific identifier was routed to a specific filepath.
+-- This is used to detect multiple (inconsistent) writes to the same file.
+schedulerRoute
+    :: Identifier
+    -> FilePath
+    -> Scheduler
+    -> (Scheduler, ())
+schedulerRoute identifier path scheduler0@Scheduler {..} =
+    case Map.lookup path schedulerRoutes of
+        Nothing ->
+            let routes = Map.insert path identifier schedulerRoutes in
+            (scheduler0 {schedulerRoutes = routes}, ())
+        Just otherIdentifier ->
+            let msg = "multiple writes for route " ++ path ++ ": " ++
+                    show identifier ++ " and " ++ show otherIdentifier in
+                schedulerError (Just identifier) msg scheduler0
+
+
 --------------------------------------------------------------------------------
 build :: RunMode -> ReaderT RuntimeRead IO ()
 build mode = do
@@ -479,6 +502,8 @@ work id' compiler = do
             case mroute of
                 Nothing    -> return ()
                 Just route -> do
+                    liftIO . IORef.atomicModifyIORef' scheduler $
+                        schedulerRoute id' route
                     let path = destinationDirectory config </> route
                     liftIO $ makeDirectories path
                     liftIO $ write path item

diff --git a/tests/Hakyll/Core/Runtime/Tests.hs b/tests/Hakyll/Core/Runtime/Tests.hs
@@ -12,7 +12,7 @@ import           Data.List           (isInfixOf)
 import           System.Exit         (ExitCode (..))
 import           System.FilePath     ((</>))
 import           Test.Tasty          (TestTree, testGroup)
-import           Test.Tasty.HUnit    (Assertion, (@?=))
+import           Test.Tasty.HUnit    (Assertion, assertBool, (@?=))
 
 
 --------------------------------------------------------------------------------
@@ -24,8 +24,15 @@ import           TestSuite.Util
 
 --------------------------------------------------------------------------------
 tests :: TestTree
-tests = testGroup "Hakyll.Core.Runtime.Tests" $
-    fromAssertions "run" [case01, case02, case03, case04, case05, case06]
+tests = testGroup "Hakyll.Core.Runtime.Tests" $ fromAssertions "run"
+    [ case01
+    , case02
+    , case03
+    , case04
+    , case05
+    , case06
+    , issue1000
+    ]
 
 
 --------------------------------------------------------------------------------
@@ -232,3 +239,25 @@ case06 = do
     ec @?= ExitSuccess
 
     cleanTestEnv
+
+
+--------------------------------------------------------------------------------
+issue1000 :: Assertion
+issue1000 = do
+    (logger, inMemLog) <- Logger.newInMem
+    (ec, _)            <- run RunModeNormal testConfiguration logger $ do
+        match "*.md" $ do
+            route $ setExtension "html"
+            compile getResourceBody
+        match "*.md" $ version "nav" $ do
+            route $ setExtension "html"
+            compile $ getResourceBody >>= traverse (pure . reverse)
+
+    ec @?= ExitFailure 1
+    msgs <- inMemLog
+    assertBool "missing 'multiple writes' errors" $ not $ null $
+        [ msg
+        | (Logger.Error, msg) <- msgs, "multiple writes" `isInfixOf` msg
+        ]
+
+    cleanTestEnv