Mutable linear references (#3)

* wip

* 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

@@ -1,14 +1,19 @@
+{-# Language DuplicateRecordFields #-}
+{-# Language UndecidableInstances #-}
 module HBS2.Data.Types.Refs
   ( module HBS2.Data.Types.Refs
   , serialise
   ) where
 
-import HBS2.Prelude
-import HBS2.Hash
 import HBS2.Base58
+import HBS2.Hash
+import HBS2.Merkle
+import HBS2.Net.Auth.Credentials
+import HBS2.Prelude
 
 import Codec.Serialise(serialise)
 import Data.Data
+import Data.Functor.Identity
 import Data.String(IsString)
 import GHC.Generics
 import Prettyprinter
@@ -54,3 +59,75 @@ instance Serialise HashRefObject
 instance Serialise HashRefPrevState
 instance Serialise HashRefType
 
+---
+
+data RefGenesis e = RefGenesis
+  { refOwner :: !(PubKey 'Sign e)
+  , refName :: !Text
+  , refMeta :: !AnnMetaData
+  }
+  deriving stock (Generic)
+
+instance (Serialise (PubKey 'Sign e)) => Serialise (RefGenesis e)
+
+data RefForm
+  = LinearRef
+
+---
+
+data family Refs e ( f :: RefForm )
+
+newtype instance Refs e 'LinearRef
+  -- List of hashes of stored RefGenesis
+  = LinearRefs { unLinearRefs :: [Hash HbSync] }
+  deriving stock (Generic)
+
+instance Serialise (Refs e 'LinearRef)
+
+---
+
+data family MutableRef e ( f :: RefForm )
+
+data instance MutableRef e 'LinearRef
+  = LinearMutableRef
+  { lrefId :: !(Hash HbSync)
+  , lrefHeight :: !Int
+  -- , lrefMTree :: !(MTreeAnn [Hash HbSync])
+  , lrefVal :: !(Hash HbSync)
+  }
+  deriving stock (Generic, Show)
+
+instance Serialise (MutableRef e 'LinearRef)
+
+---
+
+data SignPhase = SignaturePresent | SignatureVerified
+
+data family Signed ( p :: SignPhase ) a
+
+data instance Signed SignaturePresent (MutableRef e 'LinearRef)
+  = LinearMutableRefSigned
+  { signature :: Signature e
+  , signedRef :: MutableRef e 'LinearRef
+  }
+  deriving stock (Generic)
+
+instance Serialise (Signature e) =>
+    Serialise (Signed 'SignaturePresent (MutableRef e 'LinearRef))
+
+data instance Signed 'SignatureVerified (MutableRef e 'LinearRef)
+  = LinearMutableRefSignatureVerified
+  { signature :: Signature e
+  , signedRef :: MutableRef e 'LinearRef
+  , signer :: PubKey 'Sign e
+  }
+  deriving stock (Generic)
+
+---
+
+nodeLinearRefsRef :: PubKey 'Sign e -> RefGenesis e
+nodeLinearRefsRef pk = RefGenesis
+  { refOwner = pk
+  , refName = "List of node linear refs"
+  , refMeta = NoMetaData
+  }

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,8 +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(..))
@@ -46,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

@@ -33,7 +33,7 @@ import Data.Functor
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
 import Data.Monoid qualified as Monoid
-import Data.Text (Text)
+import Data.Set qualified as Set
 import Data.UUID qualified as UUID
 import Data.UUID.V4 qualified as UUID
 import Options.Applicative
@@ -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,6 +314,137 @@ runDumpACB inFile = do
   acb <- LBS.hGetContents inf <&> deserialise @(ACBSimple UDP)
   print $ pretty (AsSyntax (DefineACB "a1" acb))
 
+---
+
+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
+  -- полученный хэш будет хэшем ссылки на список референсов ноды
+  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
+
+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"
+
+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)
+
+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)
+
+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 ()
+
+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
   xdg <- getXdgDirectory XdgData defStorePath <&> fromString
@@ -352,6 +483,11 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> command "groupkey-new"    (info pNewGroupkey (progDesc "generates a new groupkey"))
                         <> 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-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"))
                         )
 
     common = do
@@ -418,3 +554,26 @@ main = join . customExecParser (prefs showHelpOnError) $
       f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" )
       pure (runDumpACB f)
 
+    pNewLRef = do
+      nodeCredFile <- strArgument ( metavar "NODE-KEYRING-FILE" )
+      ownerCredFile <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" )
+      refName <- strArgument ( metavar "REF-NAME" )
+      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)