diff options
Diffstat (limited to 'src/Erebos/Object')
| -rw-r--r-- | src/Erebos/Object/Deferred.hs | 108 | ||||
| -rw-r--r-- | src/Erebos/Object/Internal.hs | 395 |
2 files changed, 364 insertions, 139 deletions
diff --git a/src/Erebos/Object/Deferred.hs b/src/Erebos/Object/Deferred.hs new file mode 100644 index 0000000..31ff0f9 --- /dev/null +++ b/src/Erebos/Object/Deferred.hs @@ -0,0 +1,108 @@ +module Erebos.Object.Deferred ( + Deferred, + DeferredSize(..), + DeferredResult(..), + + deferredRef, + deferredLoad, + deferredWait, + deferredCheck, + + deferLoadWithServer, +) where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class + +import Data.Word + +import Erebos.Identity +import Erebos.Network +import Erebos.Object +import Erebos.Storable + + +-- | Deffered value, which can be loaded on request. Holds a reference (digest) +-- to an object and information about suitable network peers, from which the +-- data can be requested. +data Deferred a = Deferred + { deferredRef_ :: RefDigest + , deferredSize :: DeferredSize + , deferredServer :: Server + , deferredPeers :: [ RefDigest ] + , deferredStatus :: MVar (Maybe (MVar (DeferredResult a))) + } + +-- | Size constraint for the deferred object. +data DeferredSize + = DeferredExactSize Word64 -- ^ Component size of the referred data must be exactly the given value. + | DeferredMaximumSize Word64 -- ^ Component size of the referred data must not exceed the given value. + +-- | Result of the deferred load request. +data DeferredResult a + = DeferredLoaded (Stored a) -- ^ Deferred object was sucessfully loaded. + | DeferredInvalid -- ^ Deferred object was (partially) loaded, but failed to meet the size constraint or was an invalid object. + | DeferredFailed -- ^ Failure to load the object, e.g. no suitable peer was found. + +-- | Get the digest of the deferred object. +deferredRef :: Deferred a -> RefDigest +deferredRef = deferredRef_ + +-- | Request the deferred object to be loaded. Does nothing if that was already +-- requested before. The result can be received using `deferredWait` or +-- `deferredCheck` functions. +deferredLoad :: (Storable a, MonadIO m) => Deferred a -> m () +deferredLoad Deferred {..} = liftIO $ do + modifyMVar_ deferredStatus $ \case + Nothing -> do + mvar <- newEmptyMVar + let matchPeer peer = + getPeerIdentity peer >>= \case + PeerIdentityFull pid -> do + return $ any (`elem` identityDigests pid) deferredPeers + _ -> return False + + liftIO (findPeer deferredServer matchPeer) >>= \case + Just peer -> do + let bound = case deferredSize of + DeferredExactSize s -> s + DeferredMaximumSize s -> s + + checkSize ref = case deferredSize of + DeferredExactSize s -> componentSize ref == s + DeferredMaximumSize s -> componentSize ref <= s + + requestDataFromPeer peer deferredRef_ bound $ liftIO . \case + DataRequestFulfilled ref + | checkSize ref -> putMVar mvar $ DeferredLoaded $ wrappedLoad ref + | otherwise -> putMVar mvar DeferredInvalid + DataRequestRejected -> putMVar mvar DeferredFailed + DataRequestBrokenBound -> putMVar mvar DeferredInvalid + + Nothing -> putMVar mvar DeferredFailed + return $ Just mvar + cur@Just {} -> return cur + +-- | Wait for a `Deferred` value to be loaded and return the result. Requests +-- the value to be loaded if that was not already done. +deferredWait :: (Storable a, MonadIO m) => Deferred a -> m (DeferredResult a) +deferredWait d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case + Nothing -> deferredLoad d >> deferredWait d + Just mvar -> readMVar mvar + +-- | Check if a `Deferred` value has already been loaded and return it in +-- `Just` if so, otherwise return `Nothing`. Requests the value to be loaded if +-- that was not already done. +deferredCheck :: (Storable a, MonadIO m) => Deferred a -> m (Maybe (DeferredResult a)) +deferredCheck d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case + Nothing -> deferredLoad d >> deferredCheck d + Just mvar -> tryReadMVar mvar + +deferLoadWithServer :: (Storable a, MonadIO m) => RefDigest -> DeferredSize -> Server -> [ RefDigest ] -> m (Deferred a) +deferLoadWithServer deferredRef_ deferredSize deferredServer deferredPeers = do + deferredStatus <- liftIO $ newMVar Nothing + return Deferred {..} + + +identityDigests :: Foldable f => Identity f -> [ RefDigest ] +identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 4bca49c..b624d1c 100644 --- a/src/Erebos/Object/Internal.hs +++ b/src/Erebos/Object/Internal.hs @@ -1,20 +1,22 @@ module Erebos.Object.Internal ( Storage, PartialStorage, StorageCompleteness, - Ref, PartialRef, RefDigest, - refDigest, - readRef, showRef, showRefDigest, + Ref, PartialRef, RefDigest, Ref'(..), + refDigest, refFromDigest, + refStorage, + readRef, showRef, + readRefDigest, showRefDigest, refDigestFromByteString, hashToRefDigest, - copyRef, partialRef, partialRefFromDigest, + copyRef, copyRef', partialRef, partialRefFromDigest, + zeroRef, - Object, PartialObject, Object'(..), RecItem, RecItem'(..), + Object, PartialObject, Object'(..), + RecItem, RecItem'(..), + DirItem(..), serializeObject, deserializeObject, deserializeObjects, ioLoadObject, ioLoadBytes, storeRawBytes, lazyLoadBytes, storeObject, - collectObjects, collectStoredObjects, - - MonadStorage(..), Storable(..), ZeroStorable(..), StorableText(..), StorableDate(..), StorableUUID(..), @@ -22,9 +24,9 @@ module Erebos.Object.Internal ( Store, StoreRec, evalStore, evalStoreObject, storeBlob, storeRec, storeZero, - storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, - storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, - storeZRef, + storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeWeak, storeRawWeak, + storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeMbWeak, storeMbRawWeak, + storeZRef, storeZWeak, storeRecItems, Load, LoadRec, @@ -33,19 +35,15 @@ module Erebos.Object.Internal ( loadRecCurrentRef, loadRecItems, loadBlob, loadRec, loadZero, - loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, - loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, - loadTexts, loadBinaries, loadRefs, loadRawRefs, + loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, loadRawWeak, + loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak, + loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks, loadZRef, - - Stored, - fromStored, storedRef, - wrappedStore, wrappedLoad, - copyStored, - unsafeMapStored, ) where import Control.Applicative +import Control.DeepSeq +import Control.Exception import Control.Monad import Control.Monad.Except import Control.Monad.Reader @@ -54,34 +52,62 @@ import Control.Monad.Writer import Crypto.Hash import Data.Bifunctor +import Data.ByteArray qualified as BA import Data.ByteString (ByteString) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC +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.Char import Data.Function +import Data.Hashable import Data.Maybe import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as S import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime -import Data.UUID (UUID) -import qualified Data.UUID as U +import Data.Word import System.IO.Unsafe import Erebos.Error import Erebos.Storage.Internal +import Erebos.UUID (UUID) +import Erebos.UUID qualified as U +import Erebos.Util + + +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 + +instance Show (Ref' c) where + show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref) +instance BA.ByteArrayAccess (Ref' c) where + length (Ref _ dgst) = BA.length dgst + withByteArray (Ref _ dgst) = BA.withByteArray dgst + +instance Hashable (Ref' c) where + hashWithSalt salt = hashWithSalt salt . refDigest + +refStorage :: Ref' c -> Storage' c +refStorage (Ref st _) = st + +refDigest :: Ref' c -> RefDigest +refDigest (Ref _ dgst) = dgst + +showRef :: Ref' c -> ByteString +showRef = showRefDigest . refDigest zeroRef :: Storage' c -> Ref' c zeroRef s = Ref s (RefDigest h) @@ -121,11 +147,15 @@ copyRecItem' st = \case RecDate x -> return $ return $ RecDate x RecUUID x -> return $ return $ RecUUID x RecRef x -> fmap RecRef <$> copyRef' st x + RecWeak x -> return $ return $ RecWeak x RecUnknown t x -> return $ return $ RecUnknown t x copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) copyObject' _ (Blob bs) = return $ return $ Blob bs copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs +copyObject' _ (OnDemand size dgst) = return $ return $ OnDemand size dgst +copyObject' _ (Chunked size dgsts) = return $ return $ Chunked size dgsts +copyObject' _ (Dir items) = return $ return $ Dir items copyObject' _ ZeroObject = return $ return ZeroObject copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content @@ -147,7 +177,10 @@ partialRefFromDigest st dgst = Ref st dgst data Object' c = Blob ByteString - | Rec [(ByteString, RecItem' c)] + | Rec [ ( ByteString, RecItem' c ) ] + | OnDemand Word64 RefDigest + | Chunked Word64 [ RefDigest ] + | Dir [ DirItem ] | ZeroObject | UnknownObject ByteString ByteString deriving (Show) @@ -164,16 +197,35 @@ data RecItem' c | RecDate ZonedTime | RecUUID UUID | RecRef (Ref' c) + | RecWeak RefDigest | RecUnknown ByteString ByteString deriving (Show) type RecItem = RecItem' Complete +data DirItem = DirItem + { dirItemData :: RefDigest + , dirItemMetadata :: RefDigest + , dirItemFilename :: Text + } + deriving (Show) + + serializeObject :: Object' c -> BL.ByteString serializeObject = \case Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec - in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt + Rec rec -> + let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec + in BL.fromChunks [ BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n' ] `BL.append` cnt + OnDemand size dgst -> + let cnt = BC.unlines [ BC.pack (show size), showRefDigest dgst ] + in BL.fromChunks [ BC.pack "ondemand ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] + Chunked size dgsts -> + let cnt = BC.unlines $ BC.pack (show size) : map showRefDigest dgsts + in BL.fromChunks [ BC.pack "chunked ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] + Dir items -> + let cnt = BL.fromChunks $ map (\(DirItem d m f) -> BC.concat [ showRefDigest d, BC.singleton ' ', showRefDigest m, BC.singleton ' ', serializeText f, BC.singleton '\n' ]) items + in BL.fromChunks [ BC.pack "dir ", BC.pack (show $ BL.length cnt), BC.singleton '\n' ] `BL.append` cnt ZeroObject -> BL.empty UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] @@ -190,20 +242,30 @@ storeObject = unsafeStoreObject storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef storeRawBytes = unsafeStoreRawBytes +unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c) +unsafeStoreRawBytes st@Storage {..} raw = do + dgst <- evaluate $ force $ hashToRefDigest raw + backendStoreBytes stBackend dgst raw + return $ Ref st dgst + serializeRecItem :: ByteString -> RecItem' c -> [ByteString] serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] -serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] - where escaped = BC.concatMap escape $ encodeUtf8 x - escape '\n' = BC.pack "\n\t" - escape c = BC.singleton c +serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', serializeText x, BC.singleton '\n'] serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n'] serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n'] +serializeRecItem name (RecWeak x) = [name, BC.pack ":w ", showRefDigest x, BC.singleton '\n'] serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ] +serializeText :: Text -> ByteString +serializeText = BC.concatMap escape . encodeUtf8 + where + escape '\n' = BC.pack "\n\t" + escape c = BC.singleton c + lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject @@ -224,6 +286,9 @@ lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.By lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref +ioLoadBytes :: StorageCompleteness c => Ref' c -> IO (c BL.ByteString) +ioLoadBytes (Ref st dgst) = unsafeLoadBytes st dgst + unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString) unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) unsafeDeserializeObject st bytes = @@ -231,45 +296,108 @@ unsafeDeserializeObject st bytes = (line, rest) | Just (otype, len) <- splitObjPrefix line -> do let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest guard $ B.length content == len - (,next) <$> case otype of - _ | otype == BC.pack "blob" -> return $ Blob content - | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ") - (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content - | otherwise -> return $ UnknownObject otype content + (, next) <$> if + | otype == BC.pack "blob" + -> return $ Blob content + | otype == BC.pack "rec" + , Just ritems <- parseRecordBody st content + -> return $ Rec ritems + | otype == BC.pack "ondemand" + , Just ondemand <- parseOnDemand st content + -> return ondemand + | otype == BC.pack "chunked" + , Just chunked <- parseChunked st content + -> return chunked + | otype == BC.pack "dir" + , Just dir <- parseDir st content + -> return dir + | otherwise + -> return $ UnknownObject otype content _ -> throwOtherError $ "malformed object" - where splitObjPrefix line = do - [otype, tlen] <- return $ BLC.words line - (len, rest) <- BLC.readInt tlen - guard $ BL.null rest - return (BL.toStrict otype, len) - - mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest) - mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest - mergeCont _ [] = [] - - parseRecLine line = do - colon <- BC.elemIndex ':' line - space <- BC.elemIndex ' ' line - guard $ colon < space - let name = B.take colon line - itype = B.take (space-colon-1) $ B.drop (colon+1) line - content = B.drop (space+1) line - - let val = fromMaybe (RecUnknown itype content) $ - case BC.unpack itype of - "e" -> do guard $ B.null content - return RecEmpty - "i" -> do (num, rest) <- BC.readInteger content - guard $ B.null rest - return $ RecInt num - "n" -> RecNum <$> parseRatio content - "t" -> return $ RecText $ decodeUtf8With lenientDecode content - "b" -> RecBinary <$> readHex content - "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) - "u" -> RecUUID <$> U.fromASCIIBytes content - "r" -> RecRef . Ref st <$> readRefDigest content - _ -> Nothing - return (name, val) + where + splitObjPrefix line = do + [ otype, tlen ] <- return $ BLC.words line + ( len, rest ) <- BLC.readInt tlen + guard $ BL.null rest + return ( BL.toStrict otype, len ) + +parseRecordBody :: Storage' c -> ByteString -> Maybe [ ( ByteString, RecItem' c ) ] +parseRecordBody _ body | B.null body = Just [] +parseRecordBody st body = do + colon <- BC.elemIndex ':' body + space <- BC.elemIndex ' ' $ B.drop (colon + 1) body + let name = B.take colon body + itype = B.take space $ B.drop (colon + 1) body + ( content, remainingBody ) <- parseTabEscapedLines $ B.drop (space + colon + 2) body + + let val = fromMaybe (RecUnknown itype content) $ + case BC.unpack itype of + "e" -> do guard $ B.null content + return RecEmpty + "i" -> do ( num, rest ) <- BC.readInteger content + guard $ B.null rest + return $ RecInt num + "n" -> RecNum <$> parseRatio content + "t" -> return $ RecText $ decodeUtf8With lenientDecode content + "b" -> RecBinary <$> readHex content + "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) + "u" -> RecUUID <$> U.fromASCIIBytes content + "r" -> RecRef . Ref st <$> readRefDigest content + "w" -> RecWeak <$> readRefDigest content + _ -> Nothing + (( name, val ) :) <$> parseRecordBody st remainingBody + +-- Split given ByteString on the first newline not preceded by tab; replace +-- "\t\n" in the first part with "\n". +parseTabEscapedLines :: ByteString -> Maybe ( ByteString, ByteString ) +parseTabEscapedLines = parseLines [] + where + parseLines linesReversed cur = do + newline <- BC.elemIndex '\n' cur + case ( BC.length cur > newline + 1, BC.index cur (newline + 1) ) of + ( True, '\t' ) -> parseLines (B.take (newline + 1) cur : linesReversed) (B.drop (newline + 2) cur) + _ -> Just ( BC.concat $ reverse $ B.take newline cur : linesReversed, B.drop (newline + 1) cur ) + +parseOnDemand :: Storage' c -> ByteString -> Maybe (Object' c) +parseOnDemand _ body = do + newline1 <- BC.elemIndex '\n' body + newline2 <- BC.elemIndex '\n' $ B.drop (newline1 + 1) body + guard (newline1 + newline2 + 2 == B.length body) + ( size, sizeRest ) <- BC.readInt (B.take newline1 body) + guard (B.null sizeRest) + dgst <- readRefDigest $ B.take newline2 $ B.drop (newline1 + 1) body + return $ OnDemand (fromIntegral size) dgst + +parseChunked :: Storage' c -> ByteString -> Maybe (Object' c) +parseChunked _ body = do + tsize : trefs <- strictLines body + ( size, sizeRest ) <- BC.readInt tsize + guard (B.null sizeRest) + dgsts <- mapM readRefDigest trefs + return $ Chunked (fromIntegral size) dgsts + where + strictLines bs + | B.null bs = Just [] + | otherwise = do + newline <- BC.elemIndex '\n' bs + (B.take newline bs :) <$> strictLines (B.drop (newline + 1) bs) + +parseDir :: Storage' c -> ByteString -> Maybe (Object' c) +parseDir st body = Dir <$> parseDirBody st body + +parseDirBody :: Storage' c -> ByteString -> Maybe [ DirItem ] +parseDirBody _ body | B.null body = Just [] +parseDirBody st body = do + space1 <- BC.elemIndex ' ' body + space2 <- BC.elemIndex ' ' $ B.drop (space1 + 1) body + ( filenameB, remainingBody ) <- parseTabEscapedLines $ B.drop (space1 + space2 + 2) body + let dataRefB = B.take space1 body + metaRefB = B.take space2 $ B.drop (space1 + 1) body + filename = decodeUtf8With lenientDecode filenameB + dataRef <- readRefDigest dataRefB + metaRef <- readRefDigest metaRefB + (DirItem dataRef metaRef filename :) <$> parseDirBody st remainingBody + deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject @@ -280,40 +408,10 @@ deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes (obj:) <$> deserializeObjects st rest -collectObjects :: Object -> [Object] -collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) - -collectStoredObjects :: Stored Object -> [Stored Object] -collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) - -collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) -collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items - where helper (RecRef ref) (xs, s) | r <- refDigest ref - , r `S.notMember` s - = let o = wrappedLoad ref - (xs', s') = collectOtherStored (S.insert r s) $ fromStored o - in ((o : xs') ++ xs, s') - helper _ (xs, s) = (xs, s) -collectOtherStored seen _ = ([], seen) - - deriving instance StorableUUID HeadID deriving instance StorableUUID HeadTypeID -class Monad m => MonadStorage m where - getStorage :: m Storage - mstore :: Storable a => a -> m (Stored a) - - default mstore :: MonadIO m => Storable a => a -> m (Stored a) - mstore x = do - st <- getStorage - wrappedStore st x - -instance MonadIO m => MonadStorage (ReaderT Storage m) where - getStorage = ask - - class Storable a where store' :: a -> Store load' :: Load a @@ -326,10 +424,14 @@ class Storable a where class Storable a => ZeroStorable a where fromZero :: Storage -> a -data Store = StoreBlob ByteString - | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) - | StoreZero - | StoreUnknown ByteString ByteString +data Store + = StoreBlob ByteString + | StoreRec (forall c. StorageCompleteness c => Storage' c -> [ IO [ ( ByteString, RecItem' c ) ]]) + | StoreOnDemand Word64 RefDigest + | StoreChunked Word64 [ RefDigest ] + | StoreDir [ DirItem ] + | StoreZero + | StoreUnknown ByteString ByteString evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) evalStore st = unsafeStoreObject st <=< evalStoreObject st @@ -337,10 +439,13 @@ evalStore st = unsafeStoreObject st <=< evalStoreObject st evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) evalStoreObject _ (StoreBlob x) = return $ Blob x evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) +evalStoreObject _ (StoreOnDemand size dgst) = return $ OnDemand size dgst +evalStoreObject _ (StoreChunked size dgsts) = return $ Chunked size dgsts +evalStoreObject _ (StoreDir items) = return $ Dir items evalStoreObject _ StoreZero = return ZeroObject evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content -newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a) +newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [ IO [ ( ByteString, RecItem' c ) ]]) a) deriving (Functor, Applicative, Monad) type StoreRec c = StoreRecM c () @@ -373,6 +478,9 @@ instance Storable Object where store' (Rec xs) = StoreRec $ \st -> return $ do Rec xs' <- copyObject st (Rec xs) return xs' + store' (OnDemand size dgst) = StoreOnDemand size dgst + store' (Chunked size dgsts) = StoreChunked size dgsts + store' (Dir items) = StoreDir items store' ZeroObject = StoreZero store' (UnknownObject otype content) = StoreUnknown otype content @@ -518,6 +626,33 @@ storeZRef name x = StoreRecM $ do return $ if isZeroRef ref then [] else [(BC.pack name, RecRef ref)] +storeWeak :: Storable a => StorageCompleteness c => String -> a -> StoreRec c +storeWeak name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return [ ( BC.pack name, RecWeak $ refDigest ref ) ] + +storeMbWeak :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c +storeMbWeak name = maybe (return ()) (storeWeak name) + +storeRawWeak :: StorageCompleteness c => String -> RefDigest -> StoreRec c +storeRawWeak name dgst = StoreRecM $ do + tell $ (:[]) $ do + return [ ( BC.pack name, RecWeak dgst ) ] + +storeMbRawWeak :: StorageCompleteness c => String -> Maybe RefDigest -> StoreRec c +storeMbRawWeak name = maybe (return ()) (storeRawWeak name) + +storeZWeak :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c +storeZWeak name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return $ if isZeroRef ref then [] + else [ ( BC.pack name, RecWeak $ refDigest ref ) ] + + storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c storeRecItems items = StoreRecM $ do st <- ask @@ -654,37 +789,19 @@ loadZRef name = loadMbRef name >>= \case return $ fromZero st Just x -> return x +loadRawWeak :: String -> LoadRec RefDigest +loadRawWeak name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawWeak name -type Stored a = Stored' Complete a - -instance Storable a => Storable (Stored a) where - store st = copyRef st . storedRef - store' (Stored _ x) = store' x - load' = Stored <$> loadCurrentRef <*> load' - -instance ZeroStorable a => ZeroStorable (Stored a) where - fromZero st = Stored (zeroRef st) $ fromZero st - -fromStored :: Stored a -> a -fromStored (Stored _ x) = x +loadMbRawWeak :: String -> LoadRec (Maybe RefDigest) +loadMbRawWeak name = listToMaybe <$> loadRawWeaks name -storedRef :: Stored a -> Ref -storedRef (Stored ref _) = ref - -wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a) -wrappedStore st x = do ref <- liftIO $ store st x - return $ Stored ref x - -wrappedLoad :: Storable a => Ref -> Stored a -wrappedLoad ref = Stored ref (load ref) - -copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => - Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) -copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' - --- |Passed function needs to preserve the object representation to be safe -unsafeMapStored :: (a -> b) -> Stored a -> Stored b -unsafeMapStored f (Stored ref x) = Stored ref (f x) +loadRawWeaks :: String -> LoadRec [ RefDigest ] +loadRawWeaks name = mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecRef x ) | name' == bname = Just (refDigest x) + p ( name', RecWeak x ) | name' == bname = Just x + p _ = Nothing showRatio :: Rational -> String |