Write cached responses atomically

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
 

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