read objects by ref

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
 

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
 
 
 

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

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" )

hbs2/hbs2.cabal

@@ -85,6 +85,7 @@ executable hbs2
                     , text
                     , transformers
                     , uniplate
+                    , uuid
 
 
     hs-source-dirs:   .