summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-06-29 16:39:57 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-06-29 17:58:42 +0200
commit414f810c7c1d9aedeaa45e0998537395e7f4a907 (patch)
treed01b84764ecc32843da60ef6bcb5a311e3ef1be7
parent15f7d82c37cb1b0e12a1eade91e0db2e132d4c60 (diff)
Move platform-specific code to separate directory
-rw-r--r--erebos.cabal9
-rw-r--r--src/Erebos/Storage/Internal.hs35
-rw-r--r--src/unix/Erebos/Storage/Platform.hs20
3 files changed, 39 insertions, 25 deletions
diff --git a/erebos.cabal b/erebos.cabal
index bc3000d..45e6526 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -1,4 +1,4 @@
-Cabal-Version: 2.2
+Cabal-Version: 3.0
Name: erebos
Version: 0.1.4
@@ -117,6 +117,7 @@ library
other-modules:
Erebos.Flow
Erebos.Storage.List
+ Erebos.Storage.Platform
Erebos.Util
c-sources:
@@ -157,10 +158,14 @@ library
stm >=2.5 && <2.6,
text >= 1.2 && <2.2,
time >= 1.8 && <1.14,
- unix >=2.7 && <2.9,
uuid >=1.3 && <1.4,
zlib >=0.6 && <0.8
+ if true
+ hs-source-dirs: src/unix
+ build-depends:
+ unix ^>= { 2.7, 2.8 },
+
executable erebos
import: common
default-language: Haskell2010
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index a61e705..116d7fa 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
module Erebos.Storage.Internal where
import Codec.Compression.Zlib
@@ -38,8 +36,8 @@ import System.INotify (INotify)
import System.IO
import System.IO.Error
import System.IO.Unsafe (unsafePerformIO)
-import System.Posix.Files
-import System.Posix.IO
+
+import Erebos.Storage.Platform
data Storage' c = Storage
@@ -230,16 +228,7 @@ refPath spath rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, re
openLockFile :: FilePath -> IO Handle
openLockFile path = do
createDirectoryIfMissing True (takeDirectory path)
- fd <- retry 10 $
-#if MIN_VERSION_unix(2,8,0)
- openFd path WriteOnly defaultFileFlags
- { creat = Just $ unionFileModes ownerReadMode ownerWriteMode
- , exclusive = True
- }
-#else
- openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })
-#endif
- fdToHandle fd
+ retry 10 $ createFileExclusive path
where
retry :: Int -> IO a -> IO a
retry 0 act = act
@@ -249,34 +238,34 @@ openLockFile path = do
writeFileOnce :: FilePath -> BL.ByteString -> IO ()
writeFileOnce file content = bracket (openLockFile locked)
hClose $ \h -> do
- fileExist file >>= \case
- True -> removeLink locked
+ doesFileExist file >>= \case
+ True -> removeFile locked
False -> do BL.hPut h content
hFlush h
- rename locked file
+ renameFile locked file
where locked = file ++ ".lock"
writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
writeFileChecked file prev content = bracket (openLockFile locked)
hClose $ \h -> do
- (prev,) <$> fileExist file >>= \case
+ (prev,) <$> doesFileExist file >>= \case
(Nothing, True) -> do
current <- B.readFile file
- removeLink locked
+ removeFile locked
return $ Left $ Just current
(Nothing, False) -> do B.hPut h content
hFlush h
- rename locked file
+ renameFile locked file
return $ Right ()
(Just expected, True) -> do
current <- B.readFile file
if current == expected then do B.hPut h content
hFlush h
- rename locked file
+ renameFile locked file
return $ return ()
- else do removeLink locked
+ else do removeFile locked
return $ Left $ Just current
(Just _, False) -> do
- removeLink locked
+ removeFile locked
return $ Left Nothing
where locked = file ++ ".lock"
diff --git a/src/unix/Erebos/Storage/Platform.hs b/src/unix/Erebos/Storage/Platform.hs
new file mode 100644
index 0000000..2198f61
--- /dev/null
+++ b/src/unix/Erebos/Storage/Platform.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE CPP #-}
+
+module Erebos.Storage.Platform (
+ createFileExclusive,
+) where
+
+import System.IO
+import System.Posix.Files
+import System.Posix.IO
+
+createFileExclusive :: FilePath -> IO Handle
+createFileExclusive path = fdToHandle =<< do
+#if MIN_VERSION_unix(2,8,0)
+ openFd path WriteOnly defaultFileFlags
+ { creat = Just $ unionFileModes ownerReadMode ownerWriteMode
+ , exclusive = True
+ }
+#else
+ openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })
+#endif