wip

hbs2-core/lib/HBS2/Base58.hs

@@ -6,7 +6,7 @@ import Data.ByteString.Char8 (ByteString)
 
 import Prettyprinter
 
-newtype AsBase58 a = AsBase58 a
+newtype AsBase58 a = AsBase58 { unAsBase58 :: a }
 
 alphabet :: Alphabet
 alphabet = bitcoinAlphabet

hbs2-core/lib/HBS2/Data/Types/Refs.hs

@@ -66,6 +66,9 @@ data RefGenesis e = RefGenesis
   , refName :: !Text
   , refMeta :: !AnnMetaData
   }
+  deriving stock (Generic)
+
+instance (Serialise (PubKey 'Sign e)) => Serialise (RefGenesis e)
 
 data RefForm
   = LinearRef
@@ -92,7 +95,7 @@ data instance MutableRef e 'LinearRef
   -- , lrefMTree :: !(MTreeAnn [Hash HbSync])
   , lrefVal :: !(Hash HbSync)
   }
-  deriving stock (Generic)
+  deriving stock (Generic, Show)
 
 instance Serialise (MutableRef e 'LinearRef)
 
@@ -115,8 +118,8 @@ instance Serialise (Signature e) =>
 data instance Signed 'SignatureVerified (MutableRef e 'LinearRef)
   = LinearMutableRefSignatureVerified
   { signature :: Signature e
-  , signer :: PubKey 'Sign e
   , signedRef :: MutableRef e 'LinearRef
+  , signer :: PubKey 'Sign e
   }
   deriving stock (Generic)
 

hbs2-core/lib/HBS2/Hash.hs

@@ -6,7 +6,7 @@ module HBS2.Hash
   where
 
 import HBS2.Base58
-import HBS2.Prelude (FromStringMaybe(..))
+import HBS2.Prelude (FromStringMaybe(..), ToByteString(..), FromByteString(..))
 
 import Codec.Serialise
 import Crypto.Hash hiding (SHA1)
@@ -78,6 +78,12 @@ instance FromStringMaybe (Hash HbSync) where
 instance Pretty (Hash HbSync) where
   pretty (HbSyncHash s) = pretty @String [qc|{toBase58 s}|]
 
+instance ToByteString (AsBase58 (Hash HbSync)) where
+  toByteString (AsBase58 (HbSyncHash s)) = toBase58 s
+
+instance FromByteString (AsBase58 (Hash HbSync)) where
+  fromByteString = fmap (AsBase58 . HbSyncHash) . fromBase58
+
 
 instance FromJSON (Hash HbSync) where
   parseJSON = \case

hbs2-core/lib/HBS2/Prelude.hs

@@ -11,9 +11,12 @@ module HBS2.Prelude
   , FromStringMaybe(..)
   , none
   , module Prettyprinter
+  , ToByteString(..)
+  , FromByteString(..)
   , Text.Text
   ) where
 
+import Data.ByteString (ByteString)
 import Data.String (IsString(..))
 import Safe
 import Control.Monad.IO.Class (MonadIO(..))
@@ -47,4 +50,8 @@ instance Pretty a => Pretty (AsFileName a) where
 class FromStringMaybe a where
   fromStringMay :: String -> Maybe a
 
+class ToByteString a where
+  toByteString :: a -> ByteString
 
+class FromByteString a where
+  fromByteString :: ByteString -> Maybe a

hbs2-storage-simple/lib/HBS2/Storage/Simple.hs

@@ -307,6 +307,7 @@ spawnAndWait s act = do
 
 simpleWriteLinkRaw :: forall h . ( IsSimpleStorageKey h
                                  , Hashed h LBS.ByteString
+                                 , ToByteString (AsBase58 (Hash h))
                                  )
                    => SimpleStorage h
                    -> Hash h
@@ -319,7 +320,7 @@ simpleWriteLinkRaw ss h lbs = do
   runMaybeT $ do
     r <- MaybeT $ putBlock ss lbs
     MaybeT $ liftIO $ spawnAndWait ss $ do
-      writeFile fnr (show (pretty r))
+      BS.writeFile fnr (toByteString (AsBase58 r))
       pure h
 
 simpleReadLinkRaw :: IsKey h
@@ -337,6 +338,26 @@ simpleReadLinkRaw ss hash = do
 
   pure $ fromMaybe Nothing rs
 
+
+simpleReadLinkVal :: ( IsKey h
+                     , IsSimpleStorageKey h
+                     , Hashed h LBS.ByteString
+                     , FromByteString (AsBase58 (Hash h))
+                     )
+                  => SimpleStorage h
+                  -> Hash h
+                  -> IO (Maybe LBS.ByteString)
+
+simpleReadLinkVal ss hash = do
+  let fn = simpleRefFileName ss hash
+  rs <- spawnAndWait ss $ do
+    r <- tryJust (guard . isDoesNotExistError) (BS.readFile fn)
+    case r of
+      Right bh -> pure (Just bh)
+      Left  _  -> pure Nothing
+  runMaybeT do
+      MaybeT . getBlock ss . unAsBase58 =<< MaybeT (pure (fromByteString =<< join rs))
+
 -- instance Hashed hash LBS.ByteString => Hashed hash LBS.ByteString where
 --   hashObject s = hashObject s
 

hbs2/Main.hs

@@ -156,7 +156,7 @@ runCat opts ss = do
 
                   blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth)
                   recipientKeys :: [(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)]
-                    <- pure ((either (const Nothing) Just . deserialiseOrFail) blkc)
+                    <- pure (deserialiseMay blkc)
                       `orDie` "can not deserialise access key"
 
                   (ourkr, box)
@@ -231,7 +231,7 @@ runStore opts ss = do
                 & S.mapM (fmap LBS.fromStrict . Encrypt.boxSeal (recipientPk gk) . LBS.toStrict)
 
         mhash <- putAsMerkle ss encryptedChunks
-        mtree <- ((either (const Nothing) Just . deserialiseOrFail =<<) <$> getBlock ss (fromMerkleHash mhash))
+        mtree <- (mdeserialiseMay <$> getBlock ss (fromMerkleHash mhash))
             `orDie` "merkle tree was not stored properly with `putAsMerkle`"
 
         mannh <- maybe (die "can not store MerkleAnn") pure
@@ -314,54 +314,136 @@ runDumpACB inFile = do
   acb <- LBS.hGetContents inf <&> deserialise @(ACBSimple UDP)
   print $ pretty (AsSyntax (DefineACB "a1" acb))
 
-runNewLRef :: FilePath -> FilePath -> Text -> IO ()
+---
-runNewLRef nf uf refName = do
+
-  hPrint stderr $ "adding a new linear ref" <+> pretty nf <+> pretty uf
+runNewLRef :: FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO ()
+runNewLRef nf uf refName ss = do
+  hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf
   nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf)
       `orDie` "bad node keyring file"
   ownerCred <- (parseCredentials @MerkleEncryptionType . AsCredFile <$> BS.readFile uf)
       `orDie` "bad ref owner keyring file"
-
+  -- FIXME: extract reusable functions
-  -- FIXME:
-  -- lrh <- создать блок с nodeLinearRefsRef (_ nodeCred)
   -- полученный хэш будет хэшем ссылки на список референсов ноды
-  -- попытаться прочитать эту ссылку
+  lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @[HashRef] (_peerSignPk nodeCred))
-  -- h <- создать блок с RefGenesis (_ ownerCred) refName NoMetaData
+      `orDie` "can not create node refs genesis"
-  -- полученный хэш будет хэшем ссылки - канала владельца cownerCred
+  -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred
-  -- modifyNodeLiearRefList lrh nodeCred $ Set.toList . Set.insert h . Set.fromList
+  chh <- (putBlock ss . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData)
+      `orDie` "can not put channel genesis block"
+  modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList
+  print $ "channel ref:" <+> pretty chh
 
-  undefined
+modifyNodeLinearRefList :: (Signatures e, Serialise (Signature e))
+    => SimpleStorage HbSync -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO ()
+modifyNodeLinearRefList ss kr chh f =
+    modifyLinearRef ss kr chh \mh -> do
+        v <- case mh of
+            Nothing -> pure mempty
+            Just h -> fromMaybe mempty . mdeserialiseMay <$> getBlock ss h
+        (putBlock ss . serialise) (f v)
+            `orDie` "can not put new node channel list block"
 
--- modifyNodeLiearRefList :: Hash HbSync -> PeerCredentials e -> ([Hash HbSync] -> [Hash HbSync]) -> IO ()
+runListLRef :: FilePath -> SimpleStorage HbSync -> IO ()
--- modifyNodeLiearRefList h kr f = modifyLinearRef h kr (writeBlock . serialiseList . f . parseList =<< readBlock)
+runListLRef nf ss = do
-    -- = LinearMutableRefSigned
+  hPrint stderr $ "listing node channels" <+> pretty nf
-    -- { signature :: Signature e
+  nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf)
-    -- , signedRef :: MutableRef e 'LinearRef
+      `orDie` "bad node keyring file"
+  hs :: [Hash HbSync] <- readNodeLinearRefList ss (_peerSignPk nodeCred)
+  forM_ hs \chh -> do
+      putStrLn ""
+      print $ pretty chh
+      mg <- (mdeserialiseMay @(RefGenesis [Hash HbSync]) <$> getBlock ss chh)
+      forM_ mg \g -> do
+          print $ "owner:" <+> viaShow (refOwner g)
+          print $ "title:" <+> viaShow (refName g)
+          print $ "meta:" <+> viaShow (refMeta g)
+      simpleReadLinkVal ss chh >>= \case
+          Nothing -> do
+              print $ "empty"
+          Just refvalraw -> do
+              LinearMutableRefSigned _ ref
+                  <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw)
+                    `orDie` "can not parse linear ref"
+              print $ "height: " <+> viaShow (lrefHeight ref)
+              print $ "val: " <+> pretty (lrefVal ref)
 
-modifyLinearRef :: Hash HbSync -> PeerCredentials e -> (Hash HbSync -> IO (Hash HbSync)) -> IO ()
+readNodeLinearRefList :: forall e. (e ~ UDP)
-modifyLinearRef h kr modIO = do
+    => SimpleStorage HbSync -> PubKey 'Sign e -> IO [Hash HbSync]
-    -- FIXME:
+readNodeLinearRefList ss pk = do
-    -- read genesis by h
+    -- полученный хэш будет хэшем ссылки на список референсов ноды
-    -- check that owner match pubkey of keyring
+    lrh :: Hash HbSync <- pure do
-    -- read reference with simpleReadLinkRaw
+        (hashObject . serialise) (nodeLinearRefsRef @e pk)
-    -- parse ref as Signed 'SignaturePresent (MutableRef e 'LinearRef)
+    simpleReadLinkVal ss lrh >>= \case
+      Nothing -> pure []
+      Just refvalraw -> do
+          LinearMutableRefSigned _ ref
+              <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef e 'LinearRef)) refvalraw)
+              `orDie` "can not parse channel ref"
+          fromMaybe mempty . mdeserialiseMay <$> getBlock ss (lrefVal ref)
 
-    -- given
+modifyLinearRef :: forall e. (Signatures e, Serialise (Signature e))
-    -- LinearMutableRefSigned
+  => SimpleStorage HbSync
-    -- { signature :: Signature e
+  -> PeerCredentials e   -- owner keyring
-    -- , signedRef = --:: MutableRef e 'LinearRef
+  -> Hash HbSync         -- channel id
-    --       LinearMutableRef
+  -> (Maybe (Hash HbSync) -> IO (Hash HbSync))
-    --       { lrefId :: !(Hash HbSync)
+  -> IO ()
-    --       , lrefHeight :: !Int
+modifyLinearRef ss kr chh modIO = do
-    --       , lrefVal :: !(Hash HbSync)
+    g :: RefGenesis [Hash HbSync] <- (mdeserialiseMay <$> getBlock ss chh)
-    --       }
+      `orDie` "can not read channel ref genesis"
-    -- guard lrefId == h
+    when (refOwner g /= _peerSignPk kr) do
-    -- update lrefVal with modIO
+      (pure Nothing) `orDie` "channel ref owner does not match genesis owner"
-    -- increment lrefHeight
+    mrefvalraw <- simpleReadLinkVal ss chh
-    -- wrap it with LinearMutableRefSigned
+    lmr <- case mrefvalraw of
-    -- write with simpleWriteLinkRaw h $ serialise
+        Nothing -> do
+            val <- modIO Nothing
+            pure LinearMutableRef
+                { lrefId = chh
+                , lrefHeight = 0
+                , lrefVal = val
+                }
+        Just refvalraw -> do
+        -- assert lrefId == h
+            LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef)
+                <- pure (deserialiseMay refvalraw)
+                `orDie` "can not parse channel ref"
+            val <- modIO (Just (lrefVal ref))
+            pure LinearMutableRef
+                { lrefId = chh
+                , lrefHeight = lrefHeight ref + 1
+                , lrefVal = val
+                }
+    (simpleWriteLinkRaw ss chh . serialise)
+      (LinearMutableRefSigned @e ((makeSign @e (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr)
+      `orDie` "can not write link"
+    pure ()
 
-    undefined
+runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO ()
+runGetLRef refh ss = do
+    hPrint stderr $ "getting ref value" <+> pretty refh
+    refvalraw <- simpleReadLinkVal ss refh
+        `orDie` "error reading ref val"
+    LinearMutableRefSigned _ ref
+        <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw)
+        `orDie` "can not parse channel ref"
+    hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref)
+    print $ pretty (lrefVal ref)
+
+runUpdateLRef :: FilePath -> Hash HbSync -> Hash HbSync -> SimpleStorage HbSync -> IO ()
+runUpdateLRef uf refh valh ss = do
+  hPrint stderr $ "updating channel" <+> pretty refh <+> "with value" <+> pretty valh
+  ownerCred <- (parseCredentials @MerkleEncryptionType . AsCredFile <$> BS.readFile uf)
+      `orDie` "bad ref owner keyring file"
+  modifyLinearRef ss ownerCred refh \_ -> pure valh
+
+---
+
+deserialiseMay :: Serialise a => ByteString -> Maybe a
+deserialiseMay = either (const Nothing) Just . deserialiseOrFail
+
+mdeserialiseMay :: Serialise a => Maybe ByteString -> Maybe a
+mdeserialiseMay = (deserialiseMay =<<)
+
+---
 
 withStore :: Data opts => opts -> ( SimpleStorage HbSync -> IO () ) -> IO ()
 withStore opts f = do
@@ -402,8 +484,9 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "acb-gen"         (info pACBGen  (progDesc "generates binary ACB from text config"))
                         <> command "acb-dump"        (info pACBDump (progDesc "dumps binary ACB to text config"))
                         <> command "lref-new"        (info pNewLRef (progDesc "generates a new linear ref"))
-                        -- <> command "lref-add"        (info pAddLRef (progDesc "generates a new linear ref"))
+                        <> command "lref-list"       (info pListLRef (progDesc "list node linear refs"))
-                        -- <> command "lref-list"       (info pListLRef (progDesc "list node linear refs"))
+                        <> command "lref-get"        (info pGetLRef (progDesc "get a linear ref"))
+                        <> command "lref-update"     (info pUpdateLRef (progDesc "updates a linear ref"))
                         -- <> command "lref-del"        (info pDelLRef (progDesc "removes a linear ref from node linear ref list"))
                         )
 
@@ -472,7 +555,25 @@ main = join . customExecParser (prefs showHelpOnError) $
       pure (runDumpACB f)
 
     pNewLRef = do
-      nf <- strArgument ( metavar "NODE-KEYRING-FILE" )
+      nodeCredFile <- strArgument ( metavar "NODE-KEYRING-FILE" )
-      uf <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" )
+      ownerCredFile <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" )
       refName <- strArgument ( metavar "REF-NAME" )
-      pure (runNewLRef nf uf refName)
+      o <- common
+      pure $ withStore o (runNewLRef nodeCredFile ownerCredFile refName)
+
+    pListLRef = do
+      nodeCredFile <- strArgument ( metavar "NODE-KEYRING-FILE" )
+      o <- common
+      pure $ withStore o (runListLRef nodeCredFile)
+
+    pGetLRef = do
+      refh <- strArgument ( metavar "REF-ID" )
+      o <- common
+      pure $ withStore o (runGetLRef refh)
+
+    pUpdateLRef = do
+      ownerCredFile <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" )
+      refh <- strArgument ( metavar "REF-ID" )
+      valh <- strArgument ( metavar "HASH" )
+      o <- common
+      pure $ withStore o (runUpdateLRef ownerCredFile refh valh)