diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Erebos/Storage.hs | 131 | ||||
-rw-r--r-- | src/Erebos/Storage/Internal.hs | 4 | ||||
-rw-r--r-- | src/windows/Erebos/Storage/Platform.hs | 13 |
3 files changed, 93 insertions, 55 deletions
diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index 034ed04..2e6653a 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -21,9 +21,11 @@ module Erebos.Storage ( headId, headStorage, headRef, headObject, headStoredObject, loadHeads, loadHead, reloadHead, storeHead, replaceHead, updateHead, updateHead_, + loadHeadRaw, storeHeadRaw, replaceHeadRaw, WatchedHead, watchHead, watchHeadWith, unwatchHead, + watchHeadRaw, MonadStorage(..), @@ -62,7 +64,6 @@ module Erebos.Storage ( ) where import Control.Applicative -import Control.Arrow import Control.Concurrent import Control.Exception import Control.Monad @@ -72,6 +73,7 @@ import Control.Monad.Writer import Crypto.Hash +import Data.Bifunctor import Data.ByteString (ByteString) import qualified Data.ByteArray as BA import qualified Data.ByteString as B @@ -101,8 +103,8 @@ import qualified Data.UUID as U import qualified Data.UUID.V4 as U import System.Directory +import System.FSNotify import System.FilePath -import System.INotify import System.IO.Error import System.IO.Unsafe @@ -117,25 +119,30 @@ storageVersion = "0.1" openStorage :: FilePath -> IO Storage openStorage path = modifyIOError annotate $ do - let versionPath = path </> "erebos-storage" - doesFileExist versionPath >>= \case - True -> readFile versionPath >>= \case - content | (ver:_) <- lines content, ver == storageVersion -> return () - | otherwise -> fail "unsupported storage version" + 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 - doesDirectoryExist path >>= \case - True -> do - listDirectory path >>= \case - contents@(_:_) | "objects" `notElem` contents || "heads" `notElem` contents - -> fail "directory is neither empty, nor an existing erebos storage" - _ -> return () - False -> do - createDirectoryIfMissing True $ path - writeFile versionPath $ storageVersion <> "\n" + createDirectoryIfMissing True $ path + writeVersionFile createDirectoryIfMissing True $ path </> "objects" createDirectoryIfMissing True $ path </> "heads" - watchers <- newMVar ([], WatchList 1 []) + watchers <- newMVar (Nothing, [], WatchList 1 []) refgen <- newMVar =<< HT.new refroots <- newMVar =<< HT.new return $ Storage @@ -431,57 +438,70 @@ loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ catMaybes . map toHead <$> readMVar theads loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) -loadHead s@(Storage { stBacking = StorageDir { dirPath = spath }}) hid = liftIO $ do +loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid + +loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref) +loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do - (h:_) <- BC.lines <$> B.readFile (headPath spath (headTypeID @a Proxy) hid) + (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) Just ref <- readRef s h - return $ Just $ Head hid $ wrappedLoad ref -loadHead Storage { stBacking = StorageMemory { memHeads = theads } } hid = liftIO $ do - fmap (Head hid . wrappedLoad) . lookup (headTypeID @a Proxy, hid) <$> readMVar theads + return $ Just ref +loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do + lookup (tid, hid) <$> readMVar theads reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) -storeHead st obj = liftIO $ do +storeHead st obj = do let tid = headTypeID @a Proxy - hid <- HeadID <$> U.nextRandom stored <- wrappedStore st obj + hid <- storeHeadRaw st tid (storedRef stored) + return $ Head hid stored + +storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID +storeHeadRaw st tid ref = liftIO $ do + hid <- HeadID <$> U.nextRandom case stBacking st of StorageDir { dirPath = spath } -> do Right () <- writeFileChecked (headPath spath tid hid) Nothing $ - showRef (storedRef stored) `B.append` BC.singleton '\n' + showRef ref `B.append` BC.singleton '\n' return () StorageMemory { memHeads = theads } -> do - modifyMVar_ theads $ return . (((tid, hid), storedRef stored) :) - return $ Head hid stored + modifyMVar_ theads $ return . (((tid, hid), ref) :) + return hid replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) replaceHead prev@(Head hid pobj) stored' = liftIO $ do let st = headStorage prev tid = headTypeID @a Proxy stored <- copyStored st stored' + bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> + replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) + +replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref) +replaceHeadRaw st tid hid prev new = liftIO $ do case stBacking st of StorageDir { dirPath = spath } -> do let filename = headPath spath tid hid showRefL r = showRef r `B.append` BC.singleton '\n' - writeFileChecked filename (Just $ showRefL $ headRef prev) (showRefL $ storedRef stored) >>= \case + writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case Left Nothing -> return $ Left Nothing Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs - return $ Left $ Just $ Head hid $ wrappedLoad oref - Right () -> return $ Right $ Head hid stored + return $ Left $ Just oref + Right () -> return $ Right new StorageMemory { memHeads = theads, memWatchers = twatch } -> do res <- modifyMVar theads $ \hs -> do ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch return $ case partition ((==(tid, hid)) . fst) hs of ([] , _ ) -> (hs, Left Nothing) - ((_, r):_, hs') | r == storedRef pobj -> (((tid, hid), storedRef stored) : hs', - Right (Head hid stored, ws)) - | otherwise -> (hs, Left $ Just $ Head hid $ wrappedLoad r) + ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', + Right (new, ws)) + | otherwise -> (hs, Left $ Just r) case res of - Right (h, ws) -> mapM_ ($ headRef h) ws >> return (Right h) + Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) Left x -> return $ Left x updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) @@ -502,41 +522,46 @@ watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHe watchHead h = watchHeadWith h id watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadWith oh@(Head hid (Stored (Ref st _) _)) sel cb = do +watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do + watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb + +watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead +watchHeadRaw st tid hid sel cb = do memo <- newEmptyMVar - let tid = headTypeID @a Proxy - addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) + let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) where wl' = wl { wlNext = wlNext wl + 1 , wlList = WatchListItem { wlID = wlNext wl , wlHead = (tid, hid) , wlFun = \r -> do - let x = sel $ Head hid $ wrappedLoad r + let x = sel r modifyMVar_ memo $ \prev -> do - when (x /= prev) $ cb x - return x + when (Just x /= prev) $ cb x + return $ Just x } : wlList wl } watched <- case stBacking st of - StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(ilist, wl) -> do - ilist' <- case lookup tid ilist of - Just _ -> return ilist - Nothing -> do - inotify <- initINotify - void $ addWatch inotify [Move] (BC.pack $ headTypePath spath tid) $ \case - MovedIn { filePath = fpath } | Just ihid <- HeadID <$> U.fromASCIIBytes fpath -> do - loadHead @a st ihid >>= \case - Just h -> mapM_ ($ headRef h) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList . snd =<< readMVar mvar + StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do + manager <- maybe startManager return mbmanager + ilist' <- case tid `elem` ilist of + True -> return ilist + False -> do + void $ watchDir manager (headTypePath spath tid) (const True) $ \case + Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do + loadHeadRaw st tid ihid >>= \case + Just ref -> do + (_, _, iwl) <- readMVar mvar + mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl Nothing -> return () _ -> return () - return $ (tid, inotify) : ilist - return $ first (ilist',) $ addWatcher wl + return $ tid : ilist + return $ first ( Just manager, ilist', ) $ addWatcher wl StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher - cur <- sel . maybe oh id <$> reloadHead oh - cb cur + cur <- fmap sel <$> loadHeadRaw st tid hid + maybe (return ()) cb cur putMVar memo cur return watched diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs index 116d7fa..d419a5e 100644 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -31,8 +31,8 @@ import Data.UUID (UUID) import Foreign.Storable (peek) import System.Directory +import System.FSNotify (WatchManager) import System.FilePath -import System.INotify (INotify) import System.IO import System.IO.Error import System.IO.Unsafe (unsafePerformIO) @@ -60,7 +60,7 @@ showParentStorage Storage { stParent = Just st } = "@" ++ show st data StorageBacking c = StorageDir { dirPath :: FilePath - , dirWatchers :: MVar ([(HeadTypeID, INotify)], WatchList c) + , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList c ) } | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)] , memObjs :: MVar (Map RefDigest BL.ByteString) diff --git a/src/windows/Erebos/Storage/Platform.hs b/src/windows/Erebos/Storage/Platform.hs new file mode 100644 index 0000000..76c940b --- /dev/null +++ b/src/windows/Erebos/Storage/Platform.hs @@ -0,0 +1,13 @@ +module Erebos.Storage.Platform ( + createFileExclusive, +) where + +import Data.Bits + +import System.IO +import System.Win32.File +import System.Win32.Types + +createFileExclusive :: FilePath -> IO Handle +createFileExclusive path = do + hANDLEToHandle =<< createFile path gENERIC_WRITE (fILE_SHARE_READ .|. fILE_SHARE_DELETE) Nothing cREATE_NEW fILE_ATTRIBUTE_NORMAL Nothing |