haskell/stackage-server
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage-server.git synced 2026-01-28 20:00:24 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

fileStore: atomic writes

Browse Source
This commit is contained in:
Michael Snoyman 2014-04-16 14:55:44 +03:00
parent 51532cd4ee
commit 5c8229ac03
1 changed files with 12 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
Data/BlobStore.hs
View File

@ -13,6 +13,7 @@ import qualified Filesystem as F
import Control.Monad.Reader (MonadReader, ask) import Control.Monad.Reader (MonadReader, ask)
import Control.Monad.Trans.Resource (release) import Control.Monad.Trans.Resource (release)
import qualified Aws import qualified Aws
import qualified System.IO as IO
data BlobStore key = BlobStore data BlobStore key = BlobStore
{ storeWrite' :: !(forall m. MonadIO m => key -> Acquire (Sink ByteString m ())) { storeWrite' :: !(forall m. MonadIO m => key -> Acquire (Sink ByteString m ()))
@ -60,13 +61,20 @@ fileStore :: ToPath key
=> FilePath -- ^ root => FilePath -- ^ root
-> BlobStore key -> BlobStore key
fileStore root = BlobStore fileStore root = BlobStore
{ storeWrite' = \key -> sinkHandle <$> mkAcquire { storeWrite' = \key -> (sinkHandle . snd) <$> mkAcquireType
-- FIXME should be rewritten to allow for atomic writing
(do (do
let fp = toFP key let fp = toFP key
F.createTree $ directory fp F.createTree $ directory fp
F.openFile fp F.WriteMode) IO.openBinaryTempFile
hClose (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 , storeRead' = \key -> (fmap sourceHandle) <$> mkAcquire
((Just <$> F.openFile (toFP key) F.ReadMode) ((Just <$> F.openFile (toFP key) F.ReadMode)
`catch` \e -> `catch` \e ->