diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 94666bce..f43f19c5 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -1,8 +1,11 @@ -module HBS2.Data.Types.Refs where +module HBS2.Data.Types.Refs + ( module HBS2.Data.Types.Refs + , serialise + ) where import HBS2.Hash -import Codec.Serialise() +import Codec.Serialise(serialise) import Data.Data import Data.String(IsString) import GHC.Generics @@ -36,8 +39,10 @@ data AnnotatedHashRef = deriving stock (Data,Generic) +instance Serialise AnnotatedHashRef instance Serialise HashRef -instance Serialise HashRefObject instance Serialise HashRefMetadata - +instance Serialise HashRefObject +instance Serialise HashRefPrevState +instance Serialise HashRefType diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index b95f59e8..bd646be8 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -1,9 +1,11 @@ module HBS2.Prelude ( module Data.String + , module Safe -- , module HBS2.Prelude ) where import Data.String (IsString(..)) +import Safe diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 7b917a56..1c758ca5 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs @@ -1,4 +1,5 @@ {-# Language TemplateHaskell #-} +{-# Language ScopedTypeVariables #-} module HBS2.Storage.Simple where import Control.Concurrent @@ -319,19 +320,46 @@ simpleBlockExists :: IsKey h simpleBlockExists ss hash = doesFileExist $ simpleBlockFileName ss hash -simpleWriteLinkRaw :: IsKey h +spawnAndWait :: SimpleStorage h -> IO a -> IO (Maybe a) +spawnAndWait s act = do + doneQ <- TBMQ.newTBMQueueIO 1 + simpleAddTask s (act >>= \r -> atomically (TBMQ.writeTBMQueue doneQ r)) + atomically $ TBMQ.readTBMQueue doneQ + + + +simpleWriteLinkRaw :: forall h . ( IsKey h + , Key h ~ Hash h + , Hashed h LBS.ByteString + ) => SimpleStorage h -> Hash h -> Raw LBS.ByteString - -> IO () + -> IO (Maybe (Hash h)) -simpleWriteLinkRaw ss hash (Raw lbs) = do +simpleWriteLinkRaw ss h (Raw lbs) = do + let fnr = simpleRefFileName ss h + + runMaybeT $ do + r <- MaybeT $ putBlock ss lbs + MaybeT $ liftIO $ spawnAndWait ss $ do + writeFile fnr (show (pretty r)) + pure h + +simpleReadLinkRaw :: IsKey h + => SimpleStorage h + -> Hash h + -> IO (Maybe LBS.ByteString) + +simpleReadLinkRaw ss hash = do let fn = simpleRefFileName ss hash - simpleAddTask ss $ do - LBS.writeFile fn lbs + rs <- spawnAndWait ss $ do + r <- tryJust (guard . isDoesNotExistError) (LBS.readFile fn) + case r of + Right bs -> pure (Just bs) + Left _ -> pure Nothing -simpleReadLinkRaw :: SimpleStorage h -> Hash h -> IO (Maybe LBS.ByteString) -simpleReadLinkRaw s k = undefined + pure $ fromMaybe Nothing rs instance Hashed hash LBS.ByteString => Hashed hash (Raw LBS.ByteString) where hashObject (Raw s) = hashObject s diff --git a/hbs2/Main.hs b/hbs2/Main.hs index ee38ba0d..2caefacc 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -15,6 +15,10 @@ import Prettyprinter import System.Directory -- import System.FilePath.Posix import System.IO +import Data.UUID.V4 qualified as UUID +import Data.UUID qualified as UUID + +import Codec.Serialise import Streaming.Prelude qualified as S -- import Streaming qualified as S @@ -60,6 +64,12 @@ data CatOpts = deriving stock (Data) +newtype NewRefOpts = + NewRefOpts + { newRefMerkle :: Bool + } + deriving stock (Data) + readChunked :: MonadIO m => Handle -> Int -> S.Stream (S.Of ByteString) m () readChunked handle size = fuu where @@ -80,7 +90,18 @@ runCat opts ss = do mhash <- MaybeT $ pure $ uniLastMay @MerkleHash opts <&> fromMerkleHash - liftIO $ walkMerkle mhash (getBlock ss) $ \(hr :: [HashRef]) -> do + some <- MaybeT $ getBlock ss mhash + + let mbLink = deserialiseOrFail @AnnotatedHashRef some + + realHash <- MaybeT $ case mbLink of + Left _ -> pure $ Just mhash + Right lnk -> do + pure $ headMay [ h + | HashRefMerkle (HashRefObject (HashRef h) _) <- universeBi lnk + ] + + liftIO $ walkMerkle realHash (getBlock ss) $ \(hr :: [HashRef]) -> do forM_ hr $ \(HashRef h) -> do if honly then do print $ pretty h @@ -117,6 +138,15 @@ runStore opts ss = do print $ "merkle-root: " <+> pretty root +runNewRef :: Data opts => opts -> MerkleHash -> SimpleStorage HbSync -> IO () +runNewRef opts mhash ss = do + uuid <- UUID.nextRandom <&> (hashObject @HbSync . UUID.toASCIIBytes) + let href = HashRef (fromMerkleHash mhash) + let mref = HashRefMerkle (HashRefObject href Nothing) + let ref = AnnotatedHashRef Nothing mref + res <- simpleWriteLinkRaw ss uuid (Raw (serialise ref)) + print (pretty res) + withStore :: Data opts => opts -> ( SimpleStorage HbSync -> IO () ) -> IO () withStore opts f = do xdg <- getXdgDirectory XdgData defStorePath <&> fromString @@ -143,13 +173,20 @@ main = join . customExecParser (prefs showHelpOnError) $ ) where parser :: Parser (IO ()) - parser = hsubparser ( command "store" (info pStore (progDesc "store block")) - <> command "cat" (info pCat (progDesc "cat block")) + parser = hsubparser ( command "store" (info pStore (progDesc "store block")) + <> command "new-ref" (info pNewRef (progDesc "creates reference")) + <> command "cat" (info pCat (progDesc "cat block")) ) common = do pure () + pNewRef = do + o <- common + merkle <- flag' True ( long "merkle-tree" <> help "it's a merkle-tree reference" ) + hash <- strArgument ( metavar "HASH" ) + pure $ withStore o (runNewRef (NewRefOpts merkle) hash) + pStore = do o <- common file <- optional $ strArgument ( metavar "FILE" ) diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index e9e68cba..93fe6920 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -85,6 +85,7 @@ executable hbs2 , text , transformers , uniplate + , uuid hs-source-dirs: .