diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +Version 0.0.4.0 2017-09-07 by luispedro + * Add atomicConduitUseFile + Version 0.0.3.0 2017-07-29 by luispedro * Fix issue with creating files in separate directories diff --git a/Data/Conduit/SafeWrite.hs b/Data/Conduit/SafeWrite.hs --- a/Data/Conduit/SafeWrite.hs +++ b/Data/Conduit/SafeWrite.hs @@ -1,19 +1,18 @@ module Data.Conduit.SafeWrite ( safeSinkFile + , atomicConduitUseFile ) where +import qualified Data.ByteString as B import qualified Data.Conduit as C import qualified Data.Conduit.Combinators as CC -import qualified Data.ByteString as B -import Data.IORef (newIORef, writeIORef, readIORef) -import System.FilePath (takeDirectory, takeBaseName) -import System.IO (hClose, openTempFile) -import System.Directory (renameFile, removeFile) -import Control.Monad (unless) +import Data.IORef (newIORef, writeIORef, readIORef, IORef) +import System.IO (Handle) import Control.Monad.Trans.Resource -import Control.Monad.IO.Class (liftIO) +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO, MonadIO(..)) -import System.IO.SafeWrite (syncFile) +import System.IO.SafeWrite (allocateTempFile, finalizeTempFile) -- | Write to file |finalname| using a temporary file and atomic move. -- @@ -22,25 +21,29 @@ safeSinkFile :: (MonadResource m) => FilePath -- ^ Final filename -> C.Sink B.ByteString m () -safeSinkFile finalname = C.bracketP +safeSinkFile finalname = atomicConduitUseFile finalname CC.sinkHandle + +-- | Conduit using a Handle in an atomic way +atomicConduitUseFile :: (MonadResource m) => + FilePath -- ^ Final filename + -> (Handle -> C.ConduitM i o m a) -- ^ Conduit which uses a Handle + -> C.ConduitM i o m a +atomicConduitUseFile finalname cond = C.bracketP acquire deleteTempOnError - writeMove + action where - acquire = do - (tname, th) <- openTempFile (takeDirectory finalname) (takeBaseName finalname) - completed <- newIORef False - return (tname, th, completed) - writeMove (tname, th, completed) = do - CC.sinkHandle th + acquire :: IO ((FilePath, Handle), IORef Bool) + acquire = ((,) <$> allocateTempFile finalname <*> newIORef False) + action (tdata@(_, th), completed) = do + r <- cond th liftIO $ do - hClose th - syncFile tname - renameFile tname finalname + finalizeTempFile finalname True tdata writeIORef completed True - deleteTempOnError (tname, th, completed) = do - completed' <- readIORef completed - unless completed' $ do - hClose th - removeFile tname + return r + deleteTempOnError :: ((FilePath, Handle), IORef Bool) -> IO () + deleteTempOnError (tdata, completed) = do + unlessM (readIORef completed) $ + liftIO $ finalizeTempFile finalname False tdata + unlessM c act = c >>= flip unless act diff --git a/System/IO/SafeWrite.hs b/System/IO/SafeWrite.hs --- a/System/IO/SafeWrite.hs +++ b/System/IO/SafeWrite.hs @@ -1,12 +1,14 @@ module System.IO.SafeWrite ( withOutputFile , syncFile + , allocateTempFile + , finalizeTempFile ) where import System.FilePath (takeDirectory, takeBaseName) import System.Posix.IO (openFd, defaultFileFlags, closeFd, OpenMode(..)) import System.Posix.Unistd (fileSynchronise) -import Control.Exception (bracket, onException) +import Control.Exception (bracket, bracketOnError) import System.IO (Handle, hClose, openTempFile) import System.Directory (renameFile, removeFile) @@ -37,12 +39,25 @@ FilePath -- ^ Final desired file path -> (Handle -> IO a) -- ^ action to execute -> IO a -withOutputFile finalname act = do - (tname, th) <- openTempFile (takeDirectory finalname) (takeBaseName finalname) - (do - r <- act th +withOutputFile finalname act = + bracketOnError + (allocateTempFile finalname) + (finalizeTempFile finalname False) + (\tdata@(_, th) -> do + r <- act th + finalizeTempFile finalname True tdata + return r) + +allocateTempFile :: FilePath -> IO (FilePath, Handle) +allocateTempFile finalname = openTempFile (takeDirectory finalname) (takeBaseName finalname) + +finalizeTempFile :: FilePath -> Bool -> (FilePath, Handle) -> IO () +finalizeTempFile finalname ok (tname, th) + | ok = do hClose th syncFile tname renameFile tname finalname - return r) `onException` (hClose th >> removeFile tname) + | otherwise = do + hClose th + removeFile tname diff --git a/System/IO/SafeWrite/Tests.hs b/System/IO/SafeWrite/Tests.hs --- a/System/IO/SafeWrite/Tests.hs +++ b/System/IO/SafeWrite/Tests.hs @@ -6,7 +6,9 @@ import Test.HUnit import Test.Framework.Providers.HUnit +import qualified Data.ByteString as B import qualified Data.Conduit as C +import qualified Data.Conduit.Combinators as CC import Data.Conduit ((.|)) import Control.Monad.IO.Class (liftIO) import Control.Exception (throwIO) @@ -68,6 +70,18 @@ (doesFileExist outname) >>= assertBool "Output file was not created" removeFile outname +case_conduit_create_output_pass = do + C.runConduitRes $ + C.yield "Hello World" + .| atomicConduitUseFile outname writeout + .| CC.sinkNull + (doesFileExist outname) >>= assertBool "Output file was not created" + removeFile outname + where + writeout h = C.awaitForever $ \line -> do + C.yield line + liftIO $ B.hPutStrLn h (B.take 8 line) + case_conduit_not_create_on_exception = do (C.runConduitRes $ (do @@ -76,6 +90,7 @@ ) .| safeSinkFile outname ) `catchIOError` \_ -> return () (not <$> doesFileExist outname) >>= assertBool "Output file was created despite exception being raised" + case_conduit_no_intermediate_output = do C.runConduitRes $ diff --git a/safeio.cabal b/safeio.cabal --- a/safeio.cabal +++ b/safeio.cabal @@ -1,5 +1,5 @@ name: safeio -version: 0.0.3.0 +version: 0.0.4.0 synopsis: Write output to disk atomically description: This package implements utilities to perform atomic output so as to avoid the problem of partial intermediate files. @@ -32,7 +32,9 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: System/IO/SafeWrite/Tests.hs - other-modules: System.IO.SafeWrite + other-modules: + System.IO.SafeWrite + Data.Conduit.SafeWrite ghc-options: -Wall hs-source-dirs: . build-depends: