From 5c8229ac0306ab5e13c2b0289486b177e07866d9 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 16 Apr 2014 14:55:44 +0300
Subject: [PATCH] fileStore: atomic writes

---
 Data/BlobStore.hs | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/Data/BlobStore.hs b/Data/BlobStore.hs
index 327953d..c4be8fa 100644
--- a/Data/BlobStore.hs
+++ b/Data/BlobStore.hs
@@ -13,6 +13,7 @@ import qualified Filesystem as F
 import Control.Monad.Reader (MonadReader, ask)
 import Control.Monad.Trans.Resource (release)
 import qualified Aws
+import qualified System.IO as IO
 
 data BlobStore key = BlobStore
     { storeWrite'  :: !(forall m. MonadIO m => key -> Acquire (Sink ByteString m ()))
@@ -60,13 +61,20 @@ fileStore :: ToPath key
           => FilePath -- ^ root
           -> BlobStore key
 fileStore root = BlobStore
-    { storeWrite' = \key -> sinkHandle <$> mkAcquire
-        -- FIXME should be rewritten to allow for atomic writing
+    { storeWrite' = \key -> (sinkHandle . snd) <$> mkAcquireType
         (do
             let fp = toFP key
             F.createTree $ directory fp
-            F.openFile fp F.WriteMode)
-        hClose
+            IO.openBinaryTempFile
+                (fpToString $ directory fp)
+                (fpToString $ filename fp))
+        (\(fp, h) rt ->
+            case rt of
+                ReleaseException -> do
+                    hClose h `finally` F.removeFile (fpFromString fp)
+                _ -> do
+                    hClose h
+                    F.rename (fpFromString fp) (toFP key))
     , storeRead' = \key -> (fmap sourceHandle) <$> mkAcquire
         ((Just <$> F.openFile (toFP key) F.ReadMode)
             `catch` \e ->