1 files changed, 128 insertions, 114 deletions
diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs
index 8b794d8..6df1410 100644
--- a/src/Erebos/Storage/Internal.hs
+++ b/src/Erebos/Storage/Internal.hs
@@ -1,7 +1,5 @@
 module Erebos.Storage.Internal where
 
-import Codec.Compression.Zlib
-
 import Control.Arrow
 import Control.Concurrent
 import Control.DeepSeq
@@ -13,76 +11,145 @@ import Crypto.Hash
 
 import Data.Bits
 import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
-import qualified Data.ByteArray as BA
+import Data.ByteArray qualified as BA
 import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy as BL
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
 import Data.Char
-import Data.Function
+import Data.HashTable.IO qualified as HT
 import Data.Hashable
-import qualified Data.HashTable.IO as HT
 import Data.Kind
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Typeable
 import Data.UUID (UUID)
 
 import Foreign.Storable (peek)
 
-import System.Directory
-import System.FSNotify (WatchManager)
-import System.FilePath
-import System.IO
-import System.IO.Error
 import System.IO.Unsafe (unsafePerformIO)
 
-import Erebos.Storage.Platform
-
 
-data Storage' c = Storage
-    { stBacking :: StorageBacking c
-    , stParent :: Maybe (Storage' Identity)
+data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage
+    { stBackend :: bck
     , stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
     , stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
     }
 
+type Storage = Storage' Complete
+type PartialStorage = Storage' Partial
+
 instance Eq (Storage' c) where
-    (==) = (==) `on` (stBacking &&& stParent)
+    Storage { stBackend = b } == Storage { stBackend = b' }
+        | Just b'' <- cast b' =  b == b''
+        | otherwise           =  False
 
 instance Show (Storage' c) where
-    show st@(Storage { stBacking = StorageDir { dirPath = path }}) = "dir" ++ showParentStorage st ++ ":" ++ path
-    show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st
-
-showParentStorage :: Storage' c -> String
-showParentStorage Storage { stParent = Nothing } = ""
-showParentStorage Storage { stParent = Just st } = "@" ++ show st
-
-data StorageBacking c
-         = StorageDir { dirPath :: FilePath
-                      , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList c )
-                      }
-         | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)]
-                         , memObjs :: MVar (Map RefDigest BL.ByteString)
-                         , memKeys :: MVar (Map RefDigest ScrubbedBytes)
-                         , memWatchers :: MVar (WatchList c)
-                         }
-    deriving (Eq)
+    show Storage { stBackend = b } = show b ++ showParentStorage b
+
+showParentStorage :: StorageBackend bck => bck -> String
+showParentStorage bck
+    | Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st
+    | Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st
+    | otherwise = ""
+
+
+class (Eq bck, Show bck, Typeable bck, Typeable (BackendParent bck)) => StorageBackend bck where
+    type BackendCompleteness bck :: Type -> Type
+    type BackendCompleteness bck = Complete
+
+    type BackendParent bck :: Type
+    type BackendParent bck = ()
+    backendParent :: bck -> BackendParent bck
+    default backendParent :: BackendParent bck ~ () => bck -> BackendParent bck
+    backendParent _ = ()
+
+
+    backendLoadBytes :: bck -> RefDigest -> IO (Maybe BL.ByteString)
+    default backendLoadBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe BL.ByteString)
+    backendLoadBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadBytes bck'
+
+    backendStoreBytes :: bck -> RefDigest -> BL.ByteString -> IO ()
+    default backendStoreBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> BL.ByteString -> IO ()
+    backendStoreBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreBytes bck'
+
+
+    backendLoadHeads :: bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
+    default backendLoadHeads :: BackendParent bck ~ Storage => bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
+    backendLoadHeads bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHeads bck'
+
+    backendLoadHead :: bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
+    default backendLoadHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
+    backendLoadHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHead bck'
+
+    backendStoreHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
+    default backendStoreHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
+    backendStoreHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreHead bck'
+
+    backendReplaceHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
+    default backendReplaceHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
+    backendReplaceHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendReplaceHead bck'
+
+    backendWatchHead :: bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
+    default backendWatchHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
+    backendWatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendWatchHead bck'
+
+    backendUnwatchHead :: bck -> WatchID -> IO ()
+    default backendUnwatchHead :: BackendParent bck ~ Storage => bck -> WatchID -> IO ()
+    backendUnwatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendUnwatchHead bck'
+
+
+    backendListKeys :: bck -> IO [ RefDigest ]
+    default backendListKeys :: BackendParent bck ~ Storage => bck -> IO [ RefDigest ]
+    backendListKeys bck = case backendParent bck of Storage { stBackend = bck' } -> backendListKeys bck'
+
+    backendLoadKey :: bck -> RefDigest -> IO (Maybe ScrubbedBytes)
+    default backendLoadKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe ScrubbedBytes)
+    backendLoadKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadKey bck'
+
+    backendStoreKey :: bck -> RefDigest -> ScrubbedBytes -> IO ()
+    default backendStoreKey :: BackendParent bck ~ Storage => bck -> RefDigest -> ScrubbedBytes -> IO ()
+    backendStoreKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreKey bck'
+
+    backendRemoveKey :: bck -> RefDigest -> IO ()
+    default backendRemoveKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO ()
+    backendRemoveKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendRemoveKey bck'
+
+
 
 newtype WatchID = WatchID Int
-    deriving (Eq, Ord, Num)
+    deriving (Eq, Ord)
+
+startWatchID :: WatchID
+startWatchID = WatchID 1
 
-data WatchList c = WatchList
+nextWatchID :: WatchID -> WatchID
+nextWatchID (WatchID n) = WatchID (n + 1)
+
+data WatchList = WatchList
     { wlNext :: WatchID
-    , wlList :: [WatchListItem c]
+    , wlList :: [ WatchListItem ]
     }
 
-data WatchListItem c = WatchListItem
+data WatchListItem = WatchListItem
     { wlID :: WatchID
-    , wlHead :: (HeadTypeID, HeadID)
-    , wlFun :: Ref' c -> IO ()
+    , wlHead :: ( HeadTypeID, HeadID )
+    , wlFun :: RefDigest -> IO ()
     }
 
+watchListAdd :: HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> WatchList -> ( WatchList, WatchID )
+watchListAdd tid hid cb wl = ( wl', wlNext wl )
+  where
+    wl' = wl
+        { wlNext = nextWatchID (wlNext wl)
+        , wlList = WatchListItem
+            { wlID = wlNext wl
+            , wlHead = (tid, hid)
+            , wlFun = cb
+            } : wlList wl
+        }
+
+watchListDel :: WatchID -> WatchList -> WatchList
+watchListDel wid wl = wl { wlList = filter ((/= wid) . wlID) $ wlList wl }
+
 
 newtype RefDigest = RefDigest (Digest Blake2b_256)
     deriving (Eq, Ord, NFData, ByteArrayAccess)
@@ -92,6 +159,9 @@ instance Show RefDigest where
 
 data Ref' c = Ref (Storage' c) RefDigest
 
+type Ref = Ref' Complete
+type PartialRef = Ref' Partial
+
 instance Eq (Ref' c) where
     Ref _ d1 == Ref _ d2  =  d1 == d2
 
@@ -159,12 +229,11 @@ readHex = return . BA.concat <=< readHex'
 newtype Generation = Generation Int
     deriving (Eq, Show)
 
-data Head' c a = Head HeadID (Stored' c a)
-    deriving (Eq, Show)
-
+-- | UUID of individual Erebos storage head.
 newtype HeadID = HeadID UUID
     deriving (Eq, Ord, Show)
 
+-- | UUID of Erebos storage head type.
 newtype HeadTypeID = HeadTypeID UUID
     deriving (Eq, Ord)
 
@@ -184,7 +253,7 @@ storedStorage (Stored (Ref st _) _) = st
 type Complete = Identity
 type Partial = Either RefDigest
 
-class (Traversable compl, Monad compl) => StorageCompleteness compl where
+class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where
     type LoadResult compl a :: Type
     returnLoadResult :: compl a -> LoadResult compl a
     ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)
@@ -201,71 +270,16 @@ instance StorageCompleteness Partial where
     ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
 
 unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st raw = do
-    let dgst = hashToRefDigest raw
-    case stBacking st of
-         StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw
-         StorageMemory { memObjs = tobjs } ->
-             dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
-                 modifyMVar_ tobjs (return . M.insert dgst raw)
+unsafeStoreRawBytes st@Storage {..} raw = do
+    dgst <- evaluate $ force $ hashToRefDigest raw
+    backendStoreBytes stBackend dgst raw
     return $ Ref st dgst
 
 ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
-ioLoadBytesFromStorage st dgst = loadCurrent st >>=
-    \case Just bytes -> return $ Just bytes
-          Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst
-                  | otherwise                  -> return Nothing
-    where loadCurrent Storage { stBacking = StorageDir { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
-              Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath spath dgst)
-          loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs
-
-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
-
-
-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"
+ioLoadBytesFromStorage Storage {..} dgst =
+    backendLoadBytes stBackend dgst >>= \case
+        Just bytes -> return $ Just bytes
+        Nothing
+            | Just (parent :: Storage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
+            | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
+            | otherwise -> return Nothing