StorageBackend type class

Changelog: API: Added `StorageBackend` type class to allow custom storage implementation

1 files changed, 230 insertions, 0 deletions

diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs
new file mode 100644
index 0000000..01821f7
--- /dev/null
+++ b/src/Erebos/Storage/Disk.hs
@@ -0,0 +1,230 @@
+module Erebos.Storage.Disk (
+    openStorage,
+) where
+
+import Codec.Compression.Zlib
+
+import Control.Arrow
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+import Data.ByteArray qualified as BA
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.UUID qualified as U
+
+import System.Directory
+import System.FSNotify
+import System.FilePath
+import System.IO
+import System.IO.Error
+
+import Erebos.Object
+import Erebos.Storage.Backend
+import Erebos.Storage.Head
+import Erebos.Storage.Internal
+import Erebos.Storage.Platform
+
+
+data DiskStorage = StorageDir
+    { dirPath :: FilePath
+    , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList )
+    }
+
+instance Eq DiskStorage where
+    (==) = (==) `on` dirPath
+
+instance Show DiskStorage where
+    show StorageDir { dirPath = path } = "dir:" ++ path
+
+instance StorageBackend DiskStorage where
+    backendLoadBytes StorageDir {..} dgst =
+        handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
+              Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath dirPath dgst)
+    backendStoreBytes StorageDir {..} dgst = writeFileOnce (refPath dirPath dgst) . compress
+
+
+    backendLoadHeads StorageDir {..} tid = do
+        let hpath = headTypePath dirPath tid
+
+        files <- filterM (doesFileExist . (hpath </>)) =<<
+            handleJust (\e -> guard (isDoesNotExistError e)) (const $ return [])
+            (getDirectoryContents hpath)
+        fmap catMaybes $ forM files $ \hname -> do
+            case U.fromString hname of
+                 Just hid -> do
+                     content <- B.readFile (hpath </> hname)
+                     return $ do
+                         (h : _) <- Just (BC.lines content)
+                         dgst <- readRefDigest h
+                         Just $ ( HeadID hid, dgst )
+                 Nothing -> return Nothing
+
+    backendLoadHead StorageDir {..} tid hid = do
+        handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do
+            (h:_) <- BC.lines <$> B.readFile (headPath dirPath tid hid)
+            return $ readRefDigest h
+
+    backendStoreHead StorageDir {..} tid hid dgst = do
+         Right () <- writeFileChecked (headPath dirPath tid hid) Nothing $
+             showRefDigest dgst `B.append` BC.singleton '\n'
+         return ()
+
+    backendReplaceHead StorageDir {..} tid hid expected new = do
+         let filename = headPath dirPath tid hid
+             showDgstL r = showRefDigest r `B.append` BC.singleton '\n'
+
+         writeFileChecked filename (Just $ showDgstL expected) (showDgstL new) >>= \case
+             Left Nothing -> return $ Left Nothing
+             Left (Just bs) -> do Just cur <- return $ readRefDigest $ BC.takeWhile (/='\n') bs
+                                  return $ Left $ Just cur
+             Right () -> return $ Right new
+
+    backendWatchHead st@StorageDir {..} tid hid cb = do
+        modifyMVar dirWatchers $ \( mbmanager, ilist, wl ) -> do
+            manager <- maybe startManager return mbmanager
+            ilist' <- case tid `elem` ilist of
+                True -> return ilist
+                False -> do
+                    void $ watchDir manager (headTypePath dirPath tid) (const True) $ \case
+                        Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
+                            backendLoadHead st tid ihid >>= \case
+                                Just dgst -> do
+                                    (_, _, iwl) <- readMVar dirWatchers
+                                    mapM_ ($ dgst) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl
+                                Nothing -> return ()
+                        _ -> return ()
+                    return $ tid : ilist
+            return $ first ( Just manager, ilist', ) $ watchListAdd tid hid cb wl
+
+    backendUnwatchHead StorageDir {..} wid = do
+        modifyMVar_ dirWatchers $ \( mbmanager, ilist, wl ) -> do
+            return ( mbmanager, ilist, watchListDel wid wl )
+
+
+    backendListKeys StorageDir {..} = do
+        catMaybes . map (readRefDigest . BC.pack) <$>
+            listDirectory (keyDirPath dirPath)
+
+    backendLoadKey StorageDir {..} dgst = do
+        tryIOError (BC.readFile (keyFilePath dirPath dgst)) >>= \case
+            Right kdata -> return $ Just $ BA.convert kdata
+            Left _ -> return Nothing
+
+    backendStoreKey StorageDir {..} dgst key = do
+        writeFileOnce (keyFilePath dirPath dgst) (BL.fromStrict $ BA.convert key)
+
+    backendRemoveKey StorageDir {..} dgst = do
+        void $ tryIOError (removeFile $ keyFilePath dirPath dgst)
+
+
+storageVersion :: String
+storageVersion = "0.1"
+
+openStorage :: FilePath -> IO Storage
+openStorage path = modifyIOError annotate $ do
+    let versionFileName = "erebos-storage"
+    let versionPath = path </> versionFileName
+    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"
+    watchers <- newMVar ( Nothing, [], WatchList startWatchID [] )
+    newStorage $ StorageDir path watchers
+  where
+    annotate e = annotateIOError e "failed to open storage" Nothing (Just path)
+
+
+refPath :: FilePath -> RefDigest -> FilePath
+refPath spath rdgst = intercalate "/" [ spath, "objects", BC.unpack alg, pref, rest ]
+    where (alg, dgst) = showRefDigestParts rdgst
+          (pref, rest) = splitAt 2 $ BC.unpack dgst
+
+headTypePath :: FilePath -> HeadTypeID -> FilePath
+headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid
+
+headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath
+headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid
+
+keyDirPath :: FilePath -> FilePath
+keyDirPath sdir = sdir </> "keys"
+
+keyFilePath :: FilePath -> RefDigest -> FilePath
+keyFilePath sdir dgst = keyDirPath sdir </> (BC.unpack $ showRefDigest dgst)
+
+
+openLockFile :: FilePath -> IO Handle
+openLockFile path = do
+    createDirectoryIfMissing True (takeDirectory path)
+    retry 10 $ createFileExclusive path
+  where
+    retry :: Int -> IO a -> IO a
+    retry 0 act = act
+    retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing)
+                      act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act)
+
+writeFileOnce :: FilePath -> BL.ByteString -> IO ()
+writeFileOnce file content = bracket (openLockFile locked)
+    hClose $ \h -> do
+        doesFileExist file >>= \case
+            True  -> removeFile locked
+            False -> do BL.hPut h content
+                        hClose h
+                        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,) <$> doesFileExist file >>= \case
+            (Nothing, True) -> do
+                current <- B.readFile file
+                removeFile locked
+                return $ Left $ Just current
+            (Nothing, False) -> do B.hPut h content
+                                   hClose h
+                                   renameFile locked file
+                                   return $ Right ()
+            (Just expected, True) -> do
+                current <- B.readFile file
+                if current == expected then do B.hPut h content
+                                               hClose h
+                                               renameFile locked file
+                                               return $ return ()
+                                       else do removeFile locked
+                                               return $ Left $ Just current
+            (Just _, False) -> do
+                removeFile locked
+                return $ Left Nothing
+    where locked = file ++ ".lock"