From d1c41bf6f87b0743201d27cbd9b1db446b2e30c5 Mon Sep 17 00:00:00 2001
From: Thomas Honeyman <admin@thomashoneyman.com>
Date: Mon, 6 Jul 2026 12:51:16 -0400
Subject: [PATCH] Write cached responses atomically

Every request that renders a cacheable page writes the response body to the
same cache file, so under concurrent requests for one page the losers fail
with "resource busy (file is locked)" and are served a 500 - the behaviour
reported in #482, where a homepage flood turned a third of responses into
errors. A half-written file was also briefly visible to nginx, which serves
the cache directory directly.

The response is now written to a temporary file (suffixed with the writing
thread's id, so concurrent writers cannot collide on that name either) and
renamed into place, which is atomic. Under the same 400-connection homepage
flood, every response is now a 200.
---
 CHANGELOG.md         |  9 +++++++++
 src/Handler/Utils.hs | 21 +++++++++++++++++++--
 2 files changed, 28 insertions(+), 2 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 0ee496a..f404f2c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -15,6 +15,15 @@ the most up-to-date version of this file.
 - The package and module badges on search results are now links to the
   package page and module docs page (#424, @joprice). Builtin modules such
   as Prim have no package page, so their package badge remains plain text.
+- Write cached responses atomically (@thomashoneyman)
+
+  Every request that renders a cacheable page writes the response body to
+  the same cache file, so concurrent requests for one page raced on it: the
+  losers failed with "resource busy (file is locked)" and were served a 500
+  (#482 - under a 400-connection homepage flood, a third of responses), and
+  a half-written file was briefly visible to nginx, which serves the cache
+  directory directly. Responses are now written to a temporary file and
+  renamed into place, which is atomic; the same flood now returns no errors.
 
 ## v0.9.11
 
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index bd19e42..2ffe65c 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -8,7 +8,9 @@ import qualified Data.Conduit.Zlib as Zlib
 import Data.Streaming.Zlib (ZlibException(..))
 import qualified Data.Conduit.Attoparsec as Attoparsec
 import Web.Cookie (setCookieName, setCookieValue, setCookieMaxAge)
-import System.Directory (createDirectoryIfMissing, removeFile,
+import Control.Concurrent (myThreadId)
+import Data.Char (isDigit)
+import System.Directory (createDirectoryIfMissing, removeFile, renameFile,
                         getDirectoryContents, getModificationTime)
 import System.FilePath (takeDirectory)
 
@@ -37,10 +39,25 @@ catchDoesNotExist act =
     | isDoesNotExistErrorType (ioeGetErrorType e) = Just ()
     | otherwise = Nothing
 
+-- | Write a file, creating parent directories as necessary. The contents are
+-- written to a temporary file which is then renamed into place: cacheable
+-- responses are written by every request that renders them, so concurrent
+-- requests for the same page otherwise race on the destination - the losers
+-- fail with "resource busy (file is locked)" - and a reader (nginx serves
+-- the cache directory directly) could observe a partially written file.
+-- The temporary name includes the writer's thread id, which is unique among
+-- live threads, so concurrent writers cannot collide on it either.
 writeFileWithParents :: MonadIO m => FilePath -> ByteString -> m ()
 writeFileWithParents file contents = liftIO $ do
   createDirectoryIfMissing True (takeDirectory file)
-  writeFile file contents
+  tid <- myThreadId
+  let tmp = file ++ ".tmp" ++ filter isDigit (show tid)
+  bracketOnError
+    (return tmp)
+    (void . catchDoesNotExist . removeFile)
+    (\t -> do
+      writeFile t contents
+      renameFile t file)
 
 deleteFilesOlderThan :: forall m.
   (MonadIO m, MonadUnliftIO m, MonadLogger m) =>