diff --git a/hbs2-core/lib/HBS2/Base58.hs b/hbs2-core/lib/HBS2/Base58.hs index cc67bce6..060ea813 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index afd63b5f..f39e6e2a 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/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 + } diff --git a/hbs2-core/lib/HBS2/Hash.hs b/hbs2-core/lib/HBS2/Hash.hs index 12cf96d9..f58cb187 100644 --- 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 diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index 115def9c..601e6f41 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/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 diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs b/hbs2-storage-simple/lib/HBS2/Storage/Simple.hs index 798b9408..2568336f 100644 --- 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 diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 75753377..cdede0f5 100644 --- a/hbs2/Main.hs +++ b/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)