wip

2023-02-25 10:51:13 +04:00 · 2023-02-25 10:51:13 +04:00 · 6ec514ac69
parent e7686c44f5
commit 6ec514ac69
6 changed files with 188 additions and 50 deletions
--- a/hbs2-core/lib/HBS2/Base58.hs
+++ b/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
--- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs
+++ b/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)

--- a/hbs2-core/lib/HBS2/Hash.hs
+++ b/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
--- a/hbs2-core/lib/HBS2/Prelude.hs
+++ b/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
--- a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs
+++ b/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

--- a/hbs2/Main.hs
+++ b/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:
-  -- lrh <- создать блок с nodeLinearRefsRef (_ nodeCred)
+  -- FIXME: extract reusable functions
  -- полученный хэш будет хэшем ссылки на список референсов ноды
-  -- попытаться прочитать эту ссылку
-  -- h <- создать блок с RefGenesis (_ ownerCred) refName NoMetaData
-  -- полученный хэш будет хэшем ссылки - канала владельца cownerCred
-  -- modifyNodeLiearRefList lrh nodeCred $ Set.toList . Set.insert h . Set.fromList
+  lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @[HashRef] (_peerSignPk nodeCred))
+      `orDie` "can not create node refs genesis"
+  -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred
+  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 ()
-- modifyNodeLiearRefList h kr f = modifyLinearRef h kr (writeBlock . serialiseList . f . parseList =<< readBlock)
-    -- = LinearMutableRefSigned
-    -- { signature :: Signature e
-    -- , signedRef :: MutableRef e 'LinearRef
+runListLRef :: FilePath -> SimpleStorage HbSync -> IO ()
+runListLRef nf ss = do
+  hPrint stderr $ "listing node channels" <+> pretty nf
+  nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf)
+      `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 ()
-modifyLinearRef h kr modIO = do
-    -- FIXME:
-    -- read genesis by h
-    -- check that owner match pubkey of keyring
-    -- read reference with simpleReadLinkRaw
-    -- parse ref as Signed 'SignaturePresent (MutableRef e 'LinearRef)
+readNodeLinearRefList :: forall e. (e ~ UDP)
+    => SimpleStorage HbSync -> PubKey 'Sign e -> IO [Hash HbSync]
+readNodeLinearRefList ss pk = do
+    -- полученный хэш будет хэшем ссылки на список референсов ноды
+    lrh :: Hash HbSync <- pure do
+        (hashObject . serialise) (nodeLinearRefsRef @e pk)
+    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
-    -- LinearMutableRefSigned
-    -- { signature :: Signature e
-    -- , signedRef = --:: MutableRef e 'LinearRef
-    --       LinearMutableRef
-    --       { lrefId :: !(Hash HbSync)
-    --       , lrefHeight :: !Int
-    --       , lrefVal :: !(Hash HbSync)
-    --       }
-    -- guard lrefId == h
-    -- update lrefVal with modIO
-    -- increment lrefHeight
-    -- wrap it with LinearMutableRefSigned
-    -- write with simpleWriteLinkRaw h $ serialise
+modifyLinearRef :: forall e. (Signatures e, Serialise (Signature e))
+  => SimpleStorage HbSync
+  -> PeerCredentials e   -- owner keyring
+  -> Hash HbSync         -- channel id
+  -> (Maybe (Hash HbSync) -> IO (Hash HbSync))
+  -> IO ()
+modifyLinearRef ss kr chh modIO = do
+    g :: RefGenesis [Hash HbSync] <- (mdeserialiseMay <$> getBlock ss chh)
+      `orDie` "can not read channel ref genesis"
+    when (refOwner g /= _peerSignPk kr) do
+      (pure Nothing) `orDie` "channel ref owner does not match genesis owner"
+    mrefvalraw <- simpleReadLinkVal ss chh
+    lmr <- case mrefvalraw of
+        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" )
-      uf <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" )
+      nodeCredFile <- strArgument ( metavar "NODE-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)