From e51286039a0413cfbc456b0a9386c8ea369fdce3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Wed, 23 Oct 2024 21:37:38 +0200
Subject: Handle concurrent calls to openStorage
---
src/Erebos/Storage.hs | 39 +++++++++++++++++++++++----------------
1 file changed, 23 insertions(+), 16 deletions(-)
(limited to 'src/Erebos')
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs
index cae333d..2cef6c0 100644
--- a/src/Erebos/Storage.hs
+++ b/src/Erebos/Storage.hs
@@ -122,24 +122,31 @@ openStorage :: FilePath -> IO Storage
openStorage path = modifyIOError annotate $ do
let versionFileName = "erebos-storage"
let versionPath = path </> versionFileName
- let writeVersionFile = writeFile versionPath $ storageVersion <> "\n"
-
- doesDirectoryExist path >>= \case
- True -> do
- listDirectory path >>= \case
- files@(_:_)
- | versionFileName `elem` files -> do
- readFile versionPath >>= \case
- content | (ver:_) <- lines content, ver == storageVersion -> return ()
- | otherwise -> fail "unsupported storage version"
-
- | "objects" `notElem` files || "heads" `notElem` files -> do
- fail "directory is neither empty, nor an existing erebos storage"
-
- _ -> writeVersionFile
- False -> do
+ let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n"
+
+ maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+ Just <$> readFile versionPath
+ version <- case maybeVersion of
+ Just versionContent -> do
+ return $ takeWhile (/= '\n') versionContent
+
+ Nothing -> do
+ files <- handleJust (guard . isDoesNotExistError) (const $ return []) $
+ listDirectory path
+ when (not $ or
+ [ null files
+ , versionFileName `elem` files
+ , (versionFileName ++ ".lock") `elem` files
+ , "objects" `elem` files && "heads" `elem` files
+ ]) $ do
+ fail "directory is neither empty, nor an existing erebos storage"
+
createDirectoryIfMissing True $ path
writeVersionFile
+ takeWhile (/= '\n') <$> readFile versionPath
+
+ when (version /= storageVersion) $ do
+ fail $ "unsupported storage version " <> version
createDirectoryIfMissing True $ path </> "objects"
createDirectoryIfMissing True $ path </> "heads"
--
cgit v1.2.3