From 1c8f6b978b48a745eb00977c56bc54b536fbbe76 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 6 Apr 2023 09:22:45 +0300 Subject: [PATCH] merged refactor-crypto-remove-l4-protocol-dependency --- hbs2-core/lib/HBS2/Data/Types/Refs.hs | 56 +++++------ hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs | 88 ++++++++---------- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs | 57 ++++++------ hbs2-core/lib/HBS2/Net/Proto.hs | 1 - hbs2-core/lib/HBS2/Net/Proto/ACB.hs | 50 +++++----- hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 20 ++-- hbs2-core/lib/HBS2/Net/Proto/Peer.hs | 49 +++++----- hbs2-core/lib/HBS2/Net/Proto/RefLog.hs | 99 ++++++++++---------- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 10 +- hbs2-git/lib/HBS2Git/App.hs | 14 ++- hbs2-git/lib/HBS2Git/Import.hs | 2 +- hbs2-git/lib/HBS2Git/Types.hs | 5 +- hbs2-peer/app/HttpWorker.hs | 17 ++-- hbs2-peer/app/PeerMain.hs | 66 +++++++------ hbs2-peer/app/RPC.hs | 22 ++--- hbs2-peer/app/RefLog.hs | 74 ++++++++------- hbs2/Main.hs | 103 +++++++++++---------- 17 files changed, 379 insertions(+), 354 deletions(-) diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 7753fdd2..fee8a49a 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -8,15 +8,13 @@ module HBS2.Data.Types.Refs import HBS2.Base58 import HBS2.Hash import HBS2.Merkle +import HBS2.Net.Proto.Types (Encryption) 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 import Data.Hashable hiding (Hashed) import Data.Maybe (fromMaybe) @@ -65,14 +63,14 @@ instance Serialise HashRefObject --- -data RefGenesis e = RefGenesis - { refOwner :: !(PubKey 'Sign e) +data RefGenesis s = RefGenesis + { refOwner :: !(PubKey 'Sign s) , refName :: !Text , refMeta :: !AnnMetaData } deriving stock (Generic) -instance (Serialise (PubKey 'Sign e)) => Serialise (RefGenesis e) +instance Serialise (PubKey 'Sign s) => Serialise (RefGenesis s) data RefForm = LinearRef @@ -92,7 +90,7 @@ instance Serialise (Refs e 'LinearRef) data family MutableRef e ( f :: RefForm ) -data instance MutableRef e 'LinearRef +data instance MutableRef s 'LinearRef = LinearMutableRef { lrefId :: !(Hash HbSync) , lrefHeight :: !Int @@ -101,7 +99,7 @@ data instance MutableRef e 'LinearRef } deriving stock (Generic, Show) -instance Serialise (MutableRef e 'LinearRef) +instance Serialise (MutableRef s 'LinearRef) --- @@ -109,27 +107,27 @@ data SignPhase = SignaturePresent | SignatureVerified data family Signed ( p :: SignPhase ) a -data instance Signed SignaturePresent (MutableRef e 'LinearRef) +data instance Signed SignaturePresent (MutableRef s 'LinearRef) = LinearMutableRefSigned - { signature :: Signature e - , signedRef :: MutableRef e 'LinearRef + { signature :: Signature s + , signedRef :: MutableRef s 'LinearRef } deriving stock (Generic) -instance Serialise (Signature e) => - Serialise (Signed 'SignaturePresent (MutableRef e 'LinearRef)) +instance Serialise (Signature s) => + Serialise (Signed 'SignaturePresent (MutableRef s 'LinearRef)) -data instance Signed 'SignatureVerified (MutableRef e 'LinearRef) +data instance Signed 'SignatureVerified (MutableRef s 'LinearRef) = LinearMutableRefSignatureVerified - { signature :: Signature e - , signedRef :: MutableRef e 'LinearRef - , signer :: PubKey 'Sign e + { signature :: Signature s + , signedRef :: MutableRef s 'LinearRef + , signer :: PubKey 'Sign s } deriving stock (Generic) --- -nodeLinearRefsRef :: PubKey 'Sign e -> RefGenesis e +nodeLinearRefsRef :: PubKey 'Sign s -> RefGenesis s nodeLinearRefsRef pk = RefGenesis { refOwner = pk , refName = "List of node linear refs" @@ -137,27 +135,33 @@ nodeLinearRefsRef pk = RefGenesis } -newtype RefLogKey e = RefLogKey (PubKey 'Sign e) +type IsRefPubKey s = ( Eq (PubKey 'Sign s) + , Serialise (PubKey 'Sign s) + , FromStringMaybe (PubKey 'Sign s) + , Hashable (PubKey 'Sign s) + ) -deriving stock instance Eq (PubKey 'Sign e) => Eq (RefLogKey e) +newtype RefLogKey s = RefLogKey (PubKey 'Sign s) -instance (Eq (PubKey 'Sign e), Serialise (PubKey 'Sign e)) => Hashable (RefLogKey e) where +deriving stock instance IsRefPubKey s => Eq (RefLogKey s) + +instance IsRefPubKey s => Hashable (RefLogKey s) where hashWithSalt s k = hashWithSalt s (hashObject @HbSync k) -instance Serialise (PubKey 'Sign e) => Hashed HbSync (RefLogKey e) where +instance IsRefPubKey s => Hashed HbSync (RefLogKey s) where hashObject (RefLogKey pk) = hashObject ("reflogkey|" <> serialise pk) -instance FromStringMaybe (PubKey 'Sign e) => FromStringMaybe (RefLogKey e) where +instance IsRefPubKey s => FromStringMaybe (RefLogKey s) where fromStringMay s = RefLogKey <$> fromStringMay s -instance FromStringMaybe (PubKey 'Sign e) => IsString (RefLogKey e) where +instance IsRefPubKey s => IsString (RefLogKey s) where fromString s = fromMaybe (error "bad public key base58") (fromStringMay s) -instance Pretty (AsBase58 (PubKey 'Sign e) ) => Pretty (AsBase58 (RefLogKey e)) where +instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (AsBase58 (RefLogKey s)) where pretty (AsBase58 (RefLogKey k)) = pretty (AsBase58 k) -instance Pretty (AsBase58 (PubKey 'Sign e) ) => Pretty (RefLogKey e) where +instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (RefLogKey s) where pretty (RefLogKey k) = pretty (AsBase58 k) diff --git a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs index adb9c37c..abf84c17 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs @@ -6,34 +6,28 @@ module HBS2.Net.Auth.AccessKey where import HBS2.Base58 -import HBS2.Data.Detect import HBS2.Data.Types -import HBS2.Defaults import HBS2.Merkle import HBS2.Net.Auth.Credentials -import HBS2.Net.Messaging.UDP (UDP) -import HBS2.Net.Proto.Definition() -import HBS2.Net.Proto.Types -import HBS2.OrDie +import HBS2.Net.Proto.Definition import HBS2.Prelude.Plated import Codec.Serialise import Control.Monad ((<=<)) -import Crypto.Saltine.Core.Sign (Keypair(..)) -import Crypto.Saltine.Core.Sign qualified as Sign import Crypto.Saltine.Core.Box qualified as Encrypt import Crypto.Saltine.Class qualified as Crypto -import Crypto.Saltine.Class (IsEncoding) import Data.ByteString.Lazy.Char8 qualified as LBS import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Char8 (ByteString) -import Data.Function import Data.List.Split (chunksOf) -import Data.Text (Text) -import Data.List qualified as List -import Lens.Micro.Platform -import Data.Kind -import Prettyprinter + + +type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s) + , Serialise (PubKey 'Encrypt s) + , Serialise (PubKey 'Sign s) + , Serialise (PrivKey 'Sign s) + , Serialise (PrivKey 'Encrypt s) + ) newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString } @@ -41,32 +35,30 @@ newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString } instance Serialise EncryptedBox -data EncryptionSchema = NaClAsymm - --- -data family AccessKey e ( s :: EncryptionSchema ) +data family AccessKey s -newtype instance AccessKey e 'NaClAsymm = +newtype instance AccessKey s = AccessKeyNaClAsymm - { permitted :: [(PubKey 'Encrypt e, EncryptedBox)] + { permitted :: [(PubKey 'Encrypt s, EncryptedBox)] } deriving stock (Generic) -instance Serialise (AccessKey e 'NaClAsymm) +instance ForAccessKey s => Serialise (AccessKey s) --- -data family GroupKey e ( s :: EncryptionSchema ) +data family GroupKey s -data instance GroupKey e 'NaClAsymm = +data instance GroupKey s = GroupKeyNaClAsymm - { recipientPk :: PubKey 'Encrypt e - , accessKey :: AccessKey e 'NaClAsymm + { recipientPk :: PubKey 'Encrypt s + , accessKey :: AccessKey s } deriving stock (Generic) -instance Serialise (GroupKey e 'NaClAsymm) +instance ForAccessKey s => Serialise (GroupKey s) --- @@ -75,14 +67,14 @@ newtype AsGroupKeyFile a = AsGroupKeyFile a -- FIXME: integration-regression-test-for-groupkey -- Добавить тест: сгенерировали groupkey/распарсили groupkey -parseGroupKey :: forall e . () - => AsGroupKeyFile ByteString -> Maybe (GroupKey e 'NaClAsymm) +parseGroupKey :: forall s . ForAccessKey s + => AsGroupKeyFile ByteString -> Maybe (GroupKey s) parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 bs -instance ( Serialise (GroupKey e s) +instance ( Serialise (GroupKey s) ) - => Pretty (AsBase58 (GroupKey e s)) where + => Pretty (AsBase58 (GroupKey s)) where pretty (AsBase58 c) = pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c @@ -96,28 +88,30 @@ instance Pretty (AsBase58 a) => Pretty (AsGroupKeyFile (AsBase58 a)) where $ pretty pc --- newtype ListGroupKeyKeys e s = ListGroupKeyKeys (GroupKey e s) - --- instance () --- => Pretty (ListGroupKeyKeys e 'NaClAsymm) where --- pretty (ListGroupKeyKeys (GroupKeyNaClAsymm keypair pubkeys)) = --- fill 10 "recipient public keys:" --- <+> vcat (pretty . AsBase58 . Crypto.encode <$> pubkeys) --- <> line --- <> pretty keypair - ---- - -parsePubKeys :: forall e . () - => ByteString -> Maybe [PubKey 'Encrypt e] +parsePubKeys :: forall s . ForAccessKey s + => ByteString + -> Maybe [PubKey 'Encrypt s] parsePubKeys = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines ---- -mkEncryptedKey :: KeyringEntry MerkleEncryptionType -> PubKey 'Encrypt MerkleEncryptionType -> IO EncryptedBox +-- FIXME: public-key-type-hardcode +-- Это нужно переместить в тайпкласс от s, аналогично Signatures +mkEncryptedKey :: forall s . (ForAccessKey s, PubKey 'Encrypt s ~ Encrypt.PublicKey) + => KeyringEntry s + -> PubKey 'Encrypt s + -> IO EncryptedBox + mkEncryptedKey kr pk = EncryptedBox <$> Encrypt.boxSeal pk ((LBS.toStrict . serialise) kr) -openEncryptedKey :: EncryptedBox -> KeyringEntry MerkleEncryptionType -> Maybe (KeyringEntry MerkleEncryptionType) +openEncryptedKey :: forall s . ( ForAccessKey s + , PrivKey 'Encrypt s ~ Encrypt.SecretKey + , PubKey 'Encrypt s ~ Encrypt.PublicKey + ) + => EncryptedBox + -> KeyringEntry s + -> Maybe (KeyringEntry s) + openEncryptedKey (EncryptedBox bs) kr = either (const Nothing) Just . deserialiseOrFail . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs + diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index b4b83a72..cb4502e1 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -6,6 +6,7 @@ module HBS2.Net.Auth.Credentials where import HBS2.Prelude.Plated +import HBS2.Net.Proto.Types import HBS2.Base58 import Codec.Serialise @@ -19,11 +20,10 @@ import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Char8 (ByteString) import Data.Function import Data.List.Split (chunksOf) -import Data.Text (Text) import Data.List qualified as List import Lens.Micro.Platform import Data.Kind -import Prettyprinter + type family EncryptPubKey e :: Type @@ -39,8 +39,8 @@ class Signatures e where verifySign :: PubKey 'Sign e -> Signature e -> ByteString -> Bool -class HasCredentials e m where - getCredentials :: m (PeerCredentials e) +class HasCredentials s m where + getCredentials :: m (PeerCredentials s) data KeyringEntry e = KeyringEntry @@ -53,17 +53,24 @@ data KeyringEntry e = deriving stock instance (Eq (PubKey 'Encrypt e), Eq (PrivKey 'Encrypt e)) => Eq (KeyringEntry e) -data PeerCredentials e = +data PeerCredentials s = PeerCredentials - { _peerSignSk :: PrivKey 'Sign e - , _peerSignPk :: PubKey 'Sign e - , _peerKeyring :: [KeyringEntry e] + { _peerSignSk :: PrivKey 'Sign s + , _peerSignPk :: PubKey 'Sign s + , _peerKeyring :: [KeyringEntry s] } deriving Generic makeLenses 'KeyringEntry makeLenses 'PeerCredentials +type ForHBS2Basic s = ( Signatures s + , PrivKey 'Sign s ~ Sign.SecretKey + , PubKey 'Sign s ~ Sign.PublicKey + , IsEncoding (PubKey 'Encrypt s) + , s ~ HBS2Basic + ) + type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e) , Serialise (PubKey 'Sign e) , Serialise (PubKey 'Encrypt e) @@ -79,24 +86,24 @@ newtype AsCredFile a = AsCredFile a -- FIXME: integration-regression-test-for-keyring -- Добавить тест: сгенерировали keypair/распарсили keypair -newCredentials :: forall e m . ( MonadIO m - , Signatures e - , PrivKey 'Sign e ~ Sign.SecretKey - , PubKey 'Sign e ~ Sign.PublicKey - ) => m (PeerCredentials e) +newCredentials :: forall s m . ( MonadIO m + , Signatures s + , PrivKey 'Sign s ~ Sign.SecretKey + , PubKey 'Sign s ~ Sign.PublicKey + ) => m (PeerCredentials s) newCredentials = do pair <- liftIO Sign.newKeypair - pure $ PeerCredentials @e (secretKey pair) (publicKey pair) mempty + pure $ PeerCredentials @s (secretKey pair) (publicKey pair) mempty -newKeypair :: forall e m . ( MonadIO m - , PrivKey 'Encrypt e ~ Encrypt.SecretKey - , PubKey 'Encrypt e ~ Encrypt.PublicKey +newKeypair :: forall s m . ( MonadIO m + , PrivKey 'Encrypt s ~ Encrypt.SecretKey + , PubKey 'Encrypt s ~ Encrypt.PublicKey ) - => Maybe Text -> m (KeyringEntry e) + => Maybe Text -> m (KeyringEntry s) newKeypair txt = do pair <- liftIO Encrypt.newKeypair - pure $ KeyringEntry @e (Encrypt.publicKey pair) (Encrypt.secretKey pair) txt + pure $ KeyringEntry @s (Encrypt.publicKey pair) (Encrypt.secretKey pair) txt addKeyPair :: forall e m . ( MonadIO m , PrivKey 'Encrypt e ~ Encrypt.SecretKey @@ -109,8 +116,7 @@ addKeyPair txt cred = do pure $ cred & over peerKeyring (List.nub . (<> [kp])) delKeyPair :: forall e m . ( MonadIO m - , PrivKey 'Encrypt e ~ Encrypt.SecretKey - , PubKey 'Encrypt e ~ Encrypt.PublicKey + , ForHBS2Basic e ) => AsBase58 String -> PeerCredentials e -> m (PeerCredentials e) delKeyPair (AsBase58 pks) cred = do @@ -119,12 +125,11 @@ delKeyPair (AsBase58 pks) cred = do let rest = [ e | e <- kring, asStr e /= pks ] pure $ cred & set peerKeyring rest -parseCredentials :: forall e . ( Signatures e - , PrivKey 'Sign e ~ Sign.SecretKey - , PubKey 'Sign e ~ Sign.PublicKey - , SerialisedCredentials e + +parseCredentials :: forall s . ( ForHBS2Basic s + , SerialisedCredentials s ) - => AsCredFile ByteString -> Maybe (PeerCredentials e) + => AsCredFile ByteString -> Maybe (PeerCredentials s) parseCredentials (AsCredFile bs) = parseSerialisableFromBase58 bs parseSerialisableFromBase58 :: Serialise a => ByteString -> Maybe a diff --git a/hbs2-core/lib/HBS2/Net/Proto.hs b/hbs2-core/lib/HBS2/Net/Proto.hs index 79eeb7a8..4cee7cd3 100644 --- a/hbs2-core/lib/HBS2/Net/Proto.hs +++ b/hbs2-core/lib/HBS2/Net/Proto.hs @@ -3,7 +3,6 @@ module HBS2.Net.Proto , module HBS2.Net.Proto.Types ) where -import HBS2.Prelude.Plated import HBS2.Hash import HBS2.Net.Proto.Types diff --git a/hbs2-core/lib/HBS2/Net/Proto/ACB.hs b/hbs2-core/lib/HBS2/Net/Proto/ACB.hs index 0b794b2d..36769094 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/ACB.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/ACB.hs @@ -5,37 +5,31 @@ module HBS2.Net.Proto.ACB where import HBS2.Prelude.Plated import HBS2.Net.Auth.Credentials -import HBS2.Data.Types.Refs (HashRef) import HBS2.Base58 import HBS2.Data.Types -import HBS2.Net.Proto.Definition -import HBS2.Net.Auth.AccessKey import Data.Config.Suckless import Control.Applicative import Lens.Micro.Platform import Codec.Serialise() -import Prettyprinter import Data.List qualified as L import Data.Text qualified as Text -import Data.Text (Text) import Data.Maybe import Data.Either +data family ACB s -data family ACB ( s :: EncryptionSchema ) e +data DefineACB s = DefineACB Text (ACB s) -data DefineACB s e = DefineACB Text (ACB s e) +type ACBSimple s = ACB s -type ACBSimple = ACB 'NaClAsymm - -data instance ACB 'NaClAsymm e = +data instance ACB s = ACB1 - { _acbRoot :: !(Maybe (PubKey 'Sign e)) -- it's monoid. no choice but Maybe - , _acbOwners :: ![PubKey 'Sign e] - , _acbReaders :: ![PubKey 'Encrypt e] - , _acbWriters :: ![PubKey 'Sign e] + { _acbRoot :: !(Maybe (PubKey 'Sign s)) -- it's monoid. no choice but Maybe + , _acbOwners :: ![PubKey 'Sign s] + , _acbReaders :: ![PubKey 'Encrypt s] + , _acbWriters :: ![PubKey 'Sign s] , _acbPrev :: !(Maybe HashRef) } deriving stock (Generic) @@ -43,20 +37,22 @@ data instance ACB 'NaClAsymm e = makeLenses 'ACB1 -type IsACB e = ( Serialise (PubKey 'Sign e) - , Serialise (PubKey 'Encrypt e) - , Eq (PubKey 'Sign e) - , Eq (PubKey 'Encrypt e) - ) +type ForACB e = ( Serialise (PubKey 'Sign e) + , Serialise (PubKey 'Encrypt e) + , Eq (PubKey 'Sign e) + , Eq (PubKey 'Encrypt e) + , FromStringMaybe (PubKey 'Sign e) + , FromStringMaybe (PubKey 'Encrypt e) + ) -deriving instance IsACB e => Eq (ACBSimple e) +deriving instance ForACB e => Eq (ACBSimple e) -instance IsACB e => Serialise (ACBSimple e) +instance ForACB e => Serialise (ACBSimple e) -instance IsACB e => Monoid (ACBSimple e) where +instance ForACB e => Monoid (ACBSimple e) where mempty = ACB1 Nothing mempty mempty mempty Nothing -instance IsACB e => Semigroup (ACBSimple e) where +instance ForACB e => Semigroup (ACBSimple e) where (<>) a b = ACB1 (view acbRoot a <|> view acbRoot b) (L.nub (view acbOwners a <> view acbOwners b)) (L.nub (view acbReaders a <> view acbReaders b)) @@ -64,9 +60,9 @@ instance IsACB e => Semigroup (ACBSimple e) where (view acbPrev a <|> view acbPrev b) -instance ( Pretty (AsBase58 (PubKey 'Sign e)) - , Pretty (AsBase58 (PubKey 'Encrypt e) ) - ) => Pretty (AsSyntax (DefineACB 'NaClAsymm e)) where +instance ( Pretty (AsBase58 (PubKey 'Sign s)) + , Pretty (AsBase58 (PubKey 'Encrypt s) ) + ) => Pretty (AsSyntax (DefineACB s)) where pretty (AsSyntax (DefineACB nacb' acb)) = vcat [ "define-acb" <+> nacb , prev @@ -99,7 +95,7 @@ instance ( Pretty (AsBase58 (PubKey 'Sign e)) pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c] pattern Key n ns <- SymbolVal n : ns -instance FromStringMaybe (ACB 'NaClAsymm e) where +instance ForACB s => FromStringMaybe (ACB s) where fromStringMay s = Just $ ACB1 root owners readers writers prev where diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index b1a95d53..8623b407 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -33,10 +33,13 @@ import Crypto.Saltine.Core.Sign qualified as Sign import Crypto.Saltine.Core.Box qualified as Encrypt -type instance PubKey 'Sign e = Sign.PublicKey -type instance PrivKey 'Sign e = Sign.SecretKey -type instance PubKey 'Encrypt e = Encrypt.PublicKey -type instance PrivKey 'Encrypt e = Encrypt.SecretKey + +type instance Encryption UDP = HBS2Basic + +type instance PubKey 'Sign HBS2Basic = Sign.PublicKey +type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey +type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey +type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey -- FIXME: proper-serialise-for-keys -- Возможно, нужно написать ручные инстансы Serialise @@ -160,13 +163,8 @@ instance MonadIO m => HasNonces () m where instance Serialise Sign.Signature -instance Signatures UDP where - type Signature UDP = Sign.Signature - makeSign = Sign.signDetached - verifySign = Sign.signVerifyDetached - -instance Signatures MerkleEncryptionType where - type Signature MerkleEncryptionType = Sign.Signature +instance Signatures HBS2Basic where + type Signature HBS2Basic = Sign.Signature makeSign = Sign.signDetached verifySign = Sign.signVerifyDetached diff --git a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs index 424fa973..648daa13 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Peer.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Peer.hs @@ -20,12 +20,12 @@ import Data.Hashable import Lens.Micro.Platform import Type.Reflection (someTypeRep) -type PingSign e = Signature e +type PingSign e = Signature (Encryption e) type PingNonce = BS.ByteString data PeerData e = PeerData - { _peerSignKey :: PubKey 'Sign e + { _peerSignKey :: PubKey 'Sign (Encryption e) , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops } deriving stock (Typeable,Generic) @@ -34,7 +34,7 @@ makeLenses 'PeerData data PeerHandshake e = PeerPing PingNonce - | PeerPong PingNonce (Signature e) (PeerData e) + | PeerPong PingNonce (Signature (Encryption e)) (PeerData e) deriving stock (Generic) newtype KnownPeer e = KnownPeer (PeerData e) @@ -91,20 +91,21 @@ newtype PeerHandshakeAdapter e m = } -peerHandShakeProto :: forall e m . ( MonadIO m - , Response e (PeerHandshake e) m - , Request e (PeerHandshake e) m - , Sessions e (PeerHandshake e) m - , Sessions e (KnownPeer e) m - , HasNonces (PeerHandshake e) m - , HasPeerNonce e m - , Nonce (PeerHandshake e) ~ PingNonce - , Signatures e - , Pretty (Peer e) - , HasCredentials e m - , EventEmitter e (PeerHandshake e) m - , EventEmitter e (ConcretePeer e) m - ) +peerHandShakeProto :: forall e s m . ( MonadIO m + , Response e (PeerHandshake e) m + , Request e (PeerHandshake e) m + , Sessions e (PeerHandshake e) m + , Sessions e (KnownPeer e) m + , HasNonces (PeerHandshake e) m + , HasPeerNonce e m + , Nonce (PeerHandshake e) ~ PingNonce + , Pretty (Peer e) + , EventEmitter e (PeerHandshake e) m + , EventEmitter e (ConcretePeer e) m + , HasCredentials s m + , Signatures s + , s ~ Encryption e + ) => PeerHandshakeAdapter e m -> PeerHandshake e -> m () @@ -113,10 +114,10 @@ peerHandShakeProto adapter = PeerPing nonce -> do pip <- thatPeer proto -- взять свои ключи - creds <- getCredentials @e + creds <- getCredentials @s -- подписать нонс - let sign = makeSign @e (view peerSignSk creds) nonce + let sign = makeSign @s (view peerSignSk creds) nonce own <- peerNonce @e @@ -139,7 +140,7 @@ peerHandShakeProto adapter = let pk = view peerSignKey d - let signed = verifySign @e pk sign nonce + let signed = verifySign @s pk sign nonce when signed $ do @@ -205,15 +206,15 @@ instance Hashable (Peer e) => Hashable (SessionKey e (KnownPeer e)) deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e)) instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e)) -instance ( Serialise (PubKey 'Sign e) - , Serialise (Signature e) +instance ( Serialise (PubKey 'Sign (Encryption e)) + , Serialise (Signature (Encryption e)) , Serialise PeerNonce ) => Serialise (PeerData e) -instance ( Serialise (PubKey 'Sign e) - , Serialise (Signature e) +instance ( Serialise (PubKey 'Sign (Encryption e)) + , Serialise (Signature (Encryption e)) , Serialise PeerNonce ) diff --git a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs index beec0a0e..d5a817c6 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/RefLog.hs @@ -12,6 +12,7 @@ import HBS2.Base58 import HBS2.Events import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Sessions +import HBS2.Data.Types.Refs import HBS2.System.Logger.Simple @@ -22,16 +23,16 @@ import Type.Reflection (someTypeRep) import Lens.Micro.Platform data RefLogRequest e = - RefLogRequest (PubKey 'Sign e) - | RefLogResponse (PubKey 'Sign e) (Hash HbSync) + RefLogRequest (PubKey 'Sign (Encryption e)) + | RefLogResponse (PubKey 'Sign (Encryption e)) (Hash HbSync) deriving stock (Generic) data RefLogUpdate e = RefLogUpdate - { _refLogId :: PubKey 'Sign e + { _refLogId :: PubKey 'Sign (Encryption e) , _refLogUpdNonce :: Nonce (RefLogUpdate e) , _refLogUpdData :: ByteString - , _refLogUpdSign :: Signature e + , _refLogUpdSign :: Signature (Encryption e) } deriving stock (Generic) @@ -55,7 +56,7 @@ instance Typeable (RefLogUpdateEv e) => Hashable (EventKey e (RefLogUpdateEv e)) p = Proxy @RefLogUpdateEv newtype instance Event e (RefLogUpdateEv e) = - RefLogUpdateEvData (PubKey 'Sign e, RefLogUpdate e) + RefLogUpdateEvData (PubKey 'Sign (Encryption e), RefLogUpdate e) deriving (Typeable) instance EventType ( Event e (RefLogUpdateEv e) ) where @@ -74,7 +75,7 @@ instance Typeable (RefLogRequestAnswer e) => Hashable (EventKey e (RefLogRequest p = Proxy @(RefLogRequestAnswer e) data instance Event e (RefLogRequestAnswer e) = - RefLogReqAnswerData (PubKey 'Sign e) (Hash HbSync) + RefLogReqAnswerData (PubKey 'Sign (Encryption e)) (Hash HbSync) deriving (Typeable) instance EventType ( Event e (RefLogRequestAnswer e) ) where @@ -83,50 +84,53 @@ instance EventType ( Event e (RefLogRequestAnswer e) ) where instance Expires (EventKey e (RefLogRequestAnswer e)) where expiresIn = const Nothing -makeRefLogUpdate :: forall e m . ( MonadIO m - , HasNonces (RefLogUpdate e) m - , Nonce (RefLogUpdate e) ~ ByteString - , Signatures e - ) - => PubKey 'Sign e - -> PrivKey 'Sign e +makeRefLogUpdate :: forall e s m . ( MonadIO m + , HasNonces (RefLogUpdate e) m + , Nonce (RefLogUpdate e) ~ ByteString + , Signatures s + , s ~ Encryption e + , IsRefPubKey s + ) + => PubKey 'Sign s + -> PrivKey 'Sign s -> ByteString -> m (RefLogUpdate e) makeRefLogUpdate pubk privk bs = do nonce <- newNonce @(RefLogUpdate e) let noncebs = nonce <> bs - let sign = makeSign @e privk noncebs + let sign = makeSign @s privk noncebs pure $ RefLogUpdate pubk nonce bs sign -verifyRefLogUpdate :: forall e m . ( MonadIO m - -- , HasNonces (RefLogUpdate e) m - , Nonce (RefLogUpdate e) ~ ByteString - , Signatures e - ) +verifyRefLogUpdate :: forall e s m . ( MonadIO m + , Nonce (RefLogUpdate e) ~ ByteString + , Signatures s + , s ~ Encryption e + ) => RefLogUpdate e -> m Bool verifyRefLogUpdate msg = do let pubk = view refLogId msg let noncebs = view refLogUpdNonce msg <> view refLogUpdData msg let sign = view refLogUpdSign msg - pure $ verifySign @e pubk sign noncebs + pure $ verifySign @s pubk sign noncebs data RefLogRequestI e m = RefLogRequestI - { onRefLogRequest :: (Peer e, PubKey 'Sign e) -> m (Maybe (Hash HbSync)) - , onRefLogResponse :: (Peer e, PubKey 'Sign e, Hash HbSync) -> m () + { onRefLogRequest :: (Peer e, PubKey 'Sign (Encryption e)) -> m (Maybe (Hash HbSync)) + , onRefLogResponse :: (Peer e, PubKey 'Sign (Encryption e), Hash HbSync) -> m () } -refLogRequestProto :: forall e m . ( MonadIO m - , Request e (RefLogRequest e) m - , Response e (RefLogRequest e) m - , HasDeferred e (RefLogRequest e) m - , Sessions e (KnownPeer e) m - , IsPeerAddr e m - , Pretty (AsBase58 (PubKey 'Sign e)) - , EventEmitter e (RefLogRequestAnswer e) m - , Pretty (Peer e) - ) +refLogRequestProto :: forall e s m . ( MonadIO m + , Request e (RefLogRequest e) m + , Response e (RefLogRequest e) m + , HasDeferred e (RefLogRequest e) m + , Sessions e (KnownPeer e) m + , IsPeerAddr e m + , Pretty (AsBase58 (PubKey 'Sign (Encryption e))) + , EventEmitter e (RefLogRequestAnswer e) m + , Pretty (Peer e) + , s ~ Encryption e + ) => RefLogRequestI e m -> RefLogRequest e -> m () refLogRequestProto adapter cmd = do @@ -155,18 +159,19 @@ refLogRequestProto adapter cmd = do where proto = Proxy @(RefLogRequest e) -refLogUpdateProto :: forall e m . ( MonadIO m - , Request e (RefLogUpdate e) m - , Response e (RefLogUpdate e) m - , HasDeferred e (RefLogUpdate e) m - , IsPeerAddr e m - , Pretty (Peer e) - , Signatures e - , Nonce (RefLogUpdate e) ~ ByteString - , Sessions e (KnownPeer e) m - , Pretty (AsBase58 (PubKey 'Sign e)) - , EventEmitter e (RefLogUpdateEv e) m - ) +refLogUpdateProto :: forall e s m . ( MonadIO m + , Request e (RefLogUpdate e) m + , Response e (RefLogUpdate e) m + , HasDeferred e (RefLogUpdate e) m + , IsPeerAddr e m + , Pretty (Peer e) + , Nonce (RefLogUpdate e) ~ ByteString + , Sessions e (KnownPeer e) m + , Signatures s + , Pretty (AsBase58 (PubKey 'Sign s)) + , EventEmitter e (RefLogUpdateEv e) m + , s ~ Encryption e + ) => RefLogUpdateI e m -> RefLogUpdate e -> m () refLogUpdateProto adapter = @@ -193,12 +198,12 @@ refLogUpdateProto adapter = where proto = Proxy @(RefLogUpdate e) -instance ( Serialise (PubKey 'Sign e) +instance ( Serialise (PubKey 'Sign (Encryption e)) , Serialise (Nonce (RefLogUpdate e)) - , Serialise (Signature e) + , Serialise (Signature (Encryption e)) ) => Serialise (RefLogUpdate e) -instance ( Serialise (PubKey 'Sign e) +instance ( Serialise (PubKey 'Sign (Encryption e)) ) => Serialise (RefLogRequest e) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 1cafd717..79c5d48e 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -16,13 +16,17 @@ import Data.Hashable import Control.Monad.IO.Class import System.Random qualified as Random import Data.Digest.Murmur32 -import Data.ByteString (ByteString) -import Lens.Micro.Platform -import Data.Text (Text) -- e -> Transport (like, UDP or TChan) -- p -> L4 Protocol (like Ping/Pong) +type family Encryption e :: Type + +-- FIXME: move-to-a-crypto-definition-modules +data HBS2Basic + +-- type family Encryption e :: Type + class Monad m => GenCookie e m where genCookie :: Hashable salt => salt -> m (Cookie e) diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index d674d149..f03da38d 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -15,6 +15,7 @@ import HBS2.Hash import HBS2.System.Logger.Simple import HBS2.Merkle import HBS2.Git.Types +import HBS2.Net.Messaging.UDP (UDP) import HBS2.Net.Proto.Definition() import HBS2.Net.Auth.Credentials hiding (getCredentials) import HBS2.Net.Proto.RefLog @@ -324,7 +325,15 @@ readObject h = runMaybeT do mconcat <$> liftIO (atomically $ flushTQueue q) -postRefUpdate :: (MonadIO m, HasRefCredentials m) => RepoRef -> Integer -> HashRef -> m () +postRefUpdate :: ( MonadIO m + , HasRefCredentials m + , IsRefPubKey Schema + ) + => RepoRef + -> Integer + -> HashRef + -> m () + postRefUpdate ref seqno hash = do trace $ "refPostUpdate" <+> pretty seqno <+> pretty hash @@ -333,7 +342,8 @@ postRefUpdate ref seqno hash = do let privk = view peerSignSk cred let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash) let bs = serialise tran & LBS.toStrict - msg <- makeRefLogUpdate @Schema pubk privk bs <&> serialise + + msg <- makeRefLogUpdate @HBS2L4Proto pubk privk bs <&> serialise let input = byteStringInput msg let cmd = setStdin input $ shell [qc|hbs2-peer reflog send-raw|] diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs index c6439ac0..1f7f8330 100644 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ b/hbs2-git/lib/HBS2Git/Import.hs @@ -70,7 +70,7 @@ importRefLog db ref = do runMaybeT $ do bs <- MaybeT $ readBlock e - refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate Schema) bs & either (const Nothing) Just + refupd <- MaybeT $ pure $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs & either (const Nothing) Just e <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just let (SequentialRef n (AnnotatedHashRef _ h)) = e withDB db $ stateUpdateRefLog n h diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index 3407ea02..417e6991 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -12,6 +12,7 @@ import HBS2.Prelude.Plated import HBS2.Git.Types import HBS2.Net.Messaging.UDP (UDP) import HBS2.Data.Types.Refs +import HBS2.Net.Proto.Types import HBS2.Net.Auth.Credentials import Data.Config.Suckless @@ -35,7 +36,9 @@ import System.IO (Handle) import Data.Kind import Control.Monad.Catch -type Schema = UDP +-- FIXME: remove-udp-hardcode-asap +type Schema = HBS2Basic +type HBS2L4Proto = UDP -- FIXME: introduce-API-type type API = String diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index b9147751..a90cd3d9 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -3,18 +3,15 @@ module HttpWorker where import HBS2.Prelude import HBS2.Actors.Peer import HBS2.Storage -import HBS2.Hash import HBS2.Data.Types.Refs +import HBS2.Net.Proto.Types import HBS2.System.Logger.Simple import PeerTypes import PeerConfig -import Data.Maybe -import Data.Function import Data.Functor -import Data.Text.Lazy qualified as Text import Data.ByteString.Lazy qualified as LBS import Network.HTTP.Types.Status import Network.Wai.Middleware.RequestLogger @@ -25,10 +22,12 @@ import Web.Scotty -- TODO: introduce-http-of-off-feature -httpWorker :: forall e m . ( MyPeer e - , MonadIO m - , HasStorage m - ) => PeerConfig -> DownloadEnv e -> m () +httpWorker :: forall e s m . ( MyPeer e + , MonadIO m + , HasStorage m + , IsRefPubKey s + , s ~ Encryption e + ) => PeerConfig -> DownloadEnv e -> m () httpWorker conf e = do @@ -63,7 +62,7 @@ httpWorker conf e = do case re of Nothing -> status status404 Just ref -> do - va <- liftIO $ getRef sto (RefLogKey ref) + va <- liftIO $ getRef sto (RefLogKey @s ref) maybe1 va (status status404) $ \val -> do text [qc|{pretty val}|] diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 27db7c7c..81872434 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -53,8 +53,6 @@ import Crypto.Saltine (sodiumInit) import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS -import Data.Either -import Data.Foldable (for_) import Data.Function import Data.List qualified as L import Data.Map qualified as Map @@ -62,13 +60,9 @@ import Data.Maybe import Data.Set qualified as Set import Data.Set (Set) import Data.Text qualified as Text -import Data.Text (Text) -import GHC.Stats -import GHC.TypeLits import Lens.Micro.Platform import Network.Socket import Options.Applicative -import Prettyprinter import System.Directory import System.Exit import System.IO @@ -101,7 +95,7 @@ data PeerTraceKey data PeerProxyFetchKey data AcceptAnnounce = AcceptAnnounceAll - | AcceptAnnounceFrom (Set (PubKey 'Sign UDP)) + | AcceptAnnounceFrom (Set (PubKey 'Sign (Encryption UDP))) instance Pretty AcceptAnnounce where pretty = \case @@ -142,7 +136,7 @@ instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where where fromAll = headMay [ AcceptAnnounceAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ] lst = Set.fromList $ - catMaybes [ fromStringMay @(PubKey 'Sign UDP) (Text.unpack e) + catMaybes [ fromStringMay @(PubKey 'Sign (Encryption UDP)) (Text.unpack e) | ListVal @C (Key s [LitStrVal e]) <- syn, s == kk ] kk = key @PeerAcceptAnnounceKey @AcceptAnnounce @@ -166,8 +160,8 @@ data RPCCommand = | PEERS | SETLOG SetLogging | REFLOGUPDATE ByteString - | REFLOGFETCH (PubKey 'Sign UDP) - | REFLOGGET (PubKey 'Sign UDP) + | REFLOGFETCH (PubKey 'Sign (Encryption UDP)) + | REFLOGGET (PubKey 'Sign (Encryption UDP)) data PeerOpts = PeerOpts @@ -315,7 +309,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $ trace "pRefLogSend" s <- BS.readFile kr -- FIXME: UDP is weird here - creds <- pure (parseCredentials @UDP (AsCredFile s)) `orDie` "bad keyring file" + creds <- pure (parseCredentials @(Encryption UDP) (AsCredFile s)) `orDie` "bad keyring file" bs <- BS.take defChunkSize <$> BS.hGetContents stdin let pubk = view peerSignPk creds let privk = view peerSignSk creds @@ -352,63 +346,67 @@ myException :: SomeException -> IO () myException e = die ( show e ) >> exitFailure -newtype CredentialsM e m a = - CredentialsM { fromCredentials :: ReaderT (PeerCredentials e) m a } +newtype CredentialsM e s m a = + CredentialsM { fromCredentials :: ReaderT (PeerCredentials s) m a } deriving newtype ( Functor , Applicative , Monad , MonadIO - , MonadReader (PeerCredentials e) + , MonadReader (PeerCredentials s) , MonadTrans) -withCredentials :: forall e m a . (HasOwnPeer e m, Monad m) - => PeerCredentials e - -> CredentialsM e m a -> m a +withCredentials :: forall e s m a . (HasOwnPeer e m, Monad m, s ~ Encryption e) + => PeerCredentials s + -> CredentialsM e s m a -> m a withCredentials pc m = runReaderT (fromCredentials m) pc -instance (Monad m, HasTimeLimits e p m) => HasTimeLimits e p (CredentialsM e m) where +instance (Monad m, HasTimeLimits e p m, s ~ Encryption e) => HasTimeLimits e p (CredentialsM e s m) where tryLockForPeriod p m = lift $ tryLockForPeriod p m -instance (HasOwnPeer e m) => HasOwnPeer e (CredentialsM e m) where +instance (HasOwnPeer e m) => HasOwnPeer e (CredentialsM e s m) where ownPeer = lift ownPeer -instance (Monad m, HasFabriq e m) => HasFabriq e (CredentialsM e m) where +instance (Monad m, HasFabriq e m, s ~ Encryption e) => HasFabriq e (CredentialsM e s m) where getFabriq = lift getFabriq -instance (Sessions e p m ) => Sessions e p (CredentialsM e m) where +instance (Sessions e p m, s ~ Encryption e) => Sessions e p (CredentialsM e s m) where find k f = lift (find k f) fetch i d k f = lift (fetch i d k f) update d k f = lift (update d k f) expire k = lift (expire k) -instance (Monad m, HasPeerNonce e m) => HasPeerNonce e (CredentialsM e m) where +instance (Monad m, HasPeerNonce e m, s ~ Encryption e) => HasPeerNonce e (CredentialsM e s m) where peerNonce = lift $ peerNonce @e -instance Monad m => HasCredentials e (CredentialsM e m) where +instance (Monad m, s ~ Encryption e) => HasCredentials s (CredentialsM e s m) where getCredentials = ask -instance Monad m => HasCredentials e (ResponseM e (CredentialsM e m)) where +instance (Monad m, s ~ Encryption e) => HasCredentials s (ResponseM e (CredentialsM e s m)) where getCredentials = lift getCredentials -instance (Monad m, HasThatPeer e p m) => HasThatPeer e p (CredentialsM e m) where +instance (Monad m, HasThatPeer e p m, s ~ Encryption e) => HasThatPeer e p (CredentialsM e s m) where thatPeer = lift . thatPeer instance ( EventEmitter e p m - ) => EventEmitter e p (CredentialsM e m) where + ) => EventEmitter e p (CredentialsM e s m) where emit k d = lift $ emit k d instance ( Monad m , Response e p m - ) => Response e p (CredentialsM e m) where + , s ~ Encryption e + ) => Response e p (CredentialsM e s m) where response = lift . response -- runPeer :: forall e . (e ~ UDP, Nonce (RefLogUpdate e) ~ BS.ByteString) => PeerOpts -> IO () -runPeer :: forall e . (e ~ UDP, FromStringMaybe (PeerAddr e)) => PeerOpts -> IO () +runPeer :: forall e s . ( e ~ UDP + , FromStringMaybe (PeerAddr e) + , s ~ Encryption e + ) => PeerOpts -> IO () runPeer opts = Exception.handle myException $ do @@ -445,7 +443,7 @@ runPeer opts = Exception.handle myException $ do let whs = cfgValue @PeerWhiteListKey conf :: Set String let toKeys xs = Set.fromList $ catMaybes [ fromStringMay x | x <- Set.toList xs - ] :: Set (PubKey 'Sign UDP) + ] let blkeys = toKeys bls let wlkeys = toKeys (whs `Set.difference` bls) let helpFetchKeys = cfgValue @PeerProxyFetchKey conf & toKeys @@ -471,9 +469,9 @@ runPeer opts = Exception.handle myException $ do let ps = mempty pc' <- LBS.readFile credFile - <&> parseCredentials @e . AsCredFile - . LBS.toStrict - . LBS.take 4096 + <&> parseCredentials @(Encryption e) . AsCredFile + . LBS.toStrict + . LBS.take 4096 pc <- pure pc' `orDie` "can't parse credential file" @@ -790,7 +788,7 @@ runPeer opts = Exception.handle myException $ do [ makeResponse (blockSizeProto blk dontHandle onNoBlock) , makeResponse (blockChunksProto adapter) , makeResponse blockAnnounceProto - , makeResponse (withCredentials pc . peerHandShakeProto hshakeAdapter) + , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter) , makeResponse peerExchangeProto , makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogRequestProto reflogReqAdapter) @@ -872,7 +870,7 @@ runPeer opts = Exception.handle myException $ do who <- thatPeer (Proxy @(RPC e)) void $ liftIO $ async $ withPeerM penv $ do sto <- getStorage - h <- liftIO $ getRef sto (RefLogKey puk) + h <- liftIO $ getRef sto (RefLogKey @(Encryption e) puk) request who (RPCRefLogGetAnswer @e h) let arpc = RpcAdapter pokeAction diff --git a/hbs2-peer/app/RPC.hs b/hbs2-peer/app/RPC.hs index deec1b61..b1221cf3 100644 --- a/hbs2-peer/app/RPC.hs +++ b/hbs2-peer/app/RPC.hs @@ -10,9 +10,6 @@ import HBS2.Actors.Peer import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Definition() -import PeerConfig - -import Data.Text (Text) import Control.Monad.Reader import Data.ByteString.Lazy (ByteString) import Codec.Serialise (serialise,deserialiseOrFail) @@ -29,21 +26,20 @@ data RPC e = RPCPoke | RPCPing (PeerAddr e) | RPCPong (PeerAddr e) - | RPCPokeAnswer (PubKey 'Sign e) + | RPCPokeAnswer (PubKey 'Sign (Encryption e)) | RPCPokeAnswerFull Text | RPCAnnounce (Hash HbSync) | RPCFetch (Hash HbSync) | RPCPeers - | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign e) + | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign (Encryption e)) | RPCLogLevel SetLogging | RPCRefLogUpdate ByteString - | RPCRefLogFetch (PubKey 'Sign e) - | RPCRefLogGet (PubKey 'Sign e) + | RPCRefLogFetch (PubKey 'Sign (Encryption e)) + | RPCRefLogGet (PubKey 'Sign (Encryption e)) | RPCRefLogGetAnswer (Maybe (Hash HbSync)) deriving stock (Generic) - -instance Serialise (PeerAddr e) => Serialise (RPC e) +instance (Serialise (PeerAddr e), Serialise (PubKey 'Sign (Encryption e))) => Serialise (RPC e) instance HasProtocol UDP (RPC UDP) where type instance ProtocolId (RPC UDP) = 0xFFFFFFE0 @@ -63,18 +59,18 @@ makeLenses 'RPCEnv data RpcAdapter e m = RpcAdapter { rpcOnPoke :: RPC e -> m () - , rpcOnPokeAnswer :: PubKey 'Sign e -> m () + , rpcOnPokeAnswer :: PubKey 'Sign (Encryption e) -> m () , rpcOnPokeAnswerFull :: Text -> m () , rpcOnAnnounce :: Hash HbSync -> m () , rpcOnPing :: PeerAddr e -> m () , rpcOnPong :: PeerAddr e -> m () , rpcOnFetch :: Hash HbSync -> m () , rpcOnPeers :: RPC e -> m () - , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m () + , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign (Encryption e)) -> m () , rpcOnLogLevel :: SetLogging -> m () , rpcOnRefLogUpdate :: ByteString -> m () - , rpcOnRefLogFetch :: PubKey 'Sign e -> m () - , rpcOnRefLogGet :: PubKey 'Sign e -> m () + , rpcOnRefLogFetch :: PubKey 'Sign (Encryption e) -> m () + , rpcOnRefLogGet :: PubKey 'Sign (Encryption e) -> m () , rpcOnRefLogGetAnsw :: Maybe (Hash HbSync) -> m () } diff --git a/hbs2-peer/app/RefLog.hs b/hbs2-peer/app/RefLog.hs index 9bf76e9b..74e845d6 100644 --- a/hbs2-peer/app/RefLog.hs +++ b/hbs2-peer/app/RefLog.hs @@ -57,36 +57,37 @@ doRefLogBroadCast msg = do request @e pip msg -mkRefLogRequestAdapter :: forall e m . ( MonadIO m - , HasPeerLocator e m - , MyPeer e - , HasStorage m - , Pretty (AsBase58 (PubKey 'Sign e)) - ) +mkRefLogRequestAdapter :: forall e s m . ( MonadIO m + , HasPeerLocator e m + , MyPeer e + , HasStorage m + , IsRefPubKey s + , Pretty (AsBase58 (PubKey 'Sign s)) + , s ~ Encryption e + ) => m (RefLogRequestI e (ResponseM e m )) mkRefLogRequestAdapter = do sto <- getStorage pure $ RefLogRequestI (doOnRefLogRequest sto) dontHandle -doOnRefLogRequest :: forall e m . ( MonadIO m - , MyPeer e - ) - => AnyStorage -> (Peer e, PubKey 'Sign e) -> m (Maybe (Hash HbSync)) +doOnRefLogRequest :: forall e s m . ( MonadIO m + , MyPeer e + , s ~ Encryption e + , IsRefPubKey s + ) + => AnyStorage -> (Peer e, PubKey 'Sign s) -> m (Maybe (Hash HbSync)) -doOnRefLogRequest sto (_,pk) = do - r <- liftIO $ getRef sto (RefLogKey pk) - trace $ "doOnRefLogRequest" <+> pretty (AsBase58 pk) <+> pretty r - pure r +doOnRefLogRequest sto (_,pk) = liftIO $ getRef sto (RefLogKey @s pk) - -mkAdapter :: forall e m . ( MonadIO m - , HasPeerLocator e m - , Sessions e (KnownPeer e) m - , Request e (RefLogUpdate e) m - , MyPeer e - , Pretty (AsBase58 (PubKey 'Sign e)) - ) +mkAdapter :: forall e s m . ( MonadIO m + , HasPeerLocator e m + , Sessions e (KnownPeer e) m + , Request e (RefLogUpdate e) m + , MyPeer e + -- , Pretty (AsBase58 (PubKey 'Sign s)) + , s ~ Encryption e + ) => m (RefLogUpdateI e (ResponseM e m )) mkAdapter = do @@ -97,19 +98,22 @@ mkAdapter = do data RefLogWorkerAdapter e = RefLogWorkerAdapter { reflogDownload :: Hash HbSync -> IO () - , reflogFetch :: PubKey 'Sign e -> IO () + , reflogFetch :: PubKey 'Sign (Encryption e) -> IO () } -reflogWorker :: forall e m . ( MonadIO m, MyPeer e - , EventListener e (RefLogUpdateEv e) m - , EventListener e (RefLogRequestAnswer e) m +reflogWorker :: forall e s m . ( MonadIO m, MyPeer e + , EventListener e (RefLogUpdateEv e) m + , EventListener e (RefLogRequestAnswer e) m -- , Request e (RefLogRequest e) (Peerm - , HasStorage m - , Nonce (RefLogUpdate e) ~ BS.ByteString - , Signatures e - , Serialise (RefLogUpdate e) - , EventEmitter e (RefLogUpdateEv e) m -- (PeerM e m) - ) + , HasStorage m + , Nonce (RefLogUpdate e) ~ BS.ByteString + , Serialise (RefLogUpdate e) + , EventEmitter e (RefLogUpdateEv e) m -- (PeerM e m) + , Signatures s + , s ~ Encryption e + , IsRefPubKey s + , Pretty (AsBase58 (PubKey 'Sign s)) + ) => PeerConfig -> RefLogWorkerAdapter e -> m () @@ -193,7 +197,7 @@ reflogWorker conf adapter = do let (PeerConfig syn) = conf - let mkRef = fromStringMay . Text.unpack :: (Text -> Maybe (PubKey 'Sign e)) + let mkRef = fromStringMay . Text.unpack :: (Text -> Maybe (PubKey 'Sign s)) let defPoll = lastDef 10 [ x | ListVal @C (Key "poll-default" [SymbolVal "reflog", LitIntVal x]) <- syn @@ -232,8 +236,8 @@ reflogWorker conf adapter = do let byRef = HashMap.fromListWith (<>) els for_ (HashMap.toList byRef) $ \(r,x) -> do - let reflogkey = RefLogKey r - h' <- liftIO $! getRef sto (RefLogKey r) + let reflogkey = RefLogKey @s r + h' <- liftIO $! getRef sto (RefLogKey @s r) hashes <- liftIO $ readHashesFromBlock sto h' <&> HashSet.fromList diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 8ae9cb13..7ff12093 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -5,6 +5,7 @@ import HBS2.Data.Detect import HBS2.Data.Types import HBS2.Defaults import HBS2.Merkle +import HBS2.Net.Proto.Types import HBS2.Net.Auth.AccessKey import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.UDP (UDP) @@ -129,7 +130,7 @@ runHash opts ss = do withBinaryFile (hashFp opts) ReadMode $ \h -> do LBS.hGetContents h >>= print . pretty . hashObject @HbSync -runCat :: CatOpts -> SimpleStorage HbSync -> IO () +runCat :: forall s . ForHBS2Basic s => CatOpts -> SimpleStorage HbSync -> IO () runCat opts ss | catRaw opts == Just True = do @@ -181,11 +182,11 @@ runCat opts ss = do `orDie` "block encrypted. keyring required" s <- BS.readFile keyringFile ourKeys <- _peerKeyring - <$> pure (parseCredentials @MerkleEncryptionType (AsCredFile s)) + <$> pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file" blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth) - recipientKeys :: [(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)] + recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox)] <- pure (deserialiseMay blkc) `orDie` "can not deserialise access key" @@ -266,7 +267,7 @@ runStore opts ss = do print $ "merkle-root: " <+> pretty root Just gkfile -> do - gk :: GroupKey MerkleEncryptionType 'NaClAsymm + gk :: GroupKey HBS2Basic <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)) `orDie` "bad groupkey file" @@ -290,92 +291,93 @@ runStore opts ss = do print $ "merkle-ann-root: " <+> pretty mannh -runNewGroupkey :: FilePath -> IO () +runNewGroupkey :: forall s . (s ~ HBS2Basic) => FilePath -> IO () runNewGroupkey pubkeysFile = do s <- BS.readFile pubkeysFile - pubkeys <- pure (parsePubKeys s) `orDie` "bad pubkeys file" - keypair <- newKeypair @MerkleEncryptionType Nothing - accesskey <- AccessKeyNaClAsymm <$> do + pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file" + keypair <- newKeypair @s Nothing + accesskey <- AccessKeyNaClAsymm @s <$> do List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey -runNewKey :: IO () +runNewKey :: forall s . (s ~ HBS2Basic) => IO () runNewKey = do - cred <- newCredentials @UDP + cred <- newCredentials @s print $ pretty $ AsCredFile $ AsBase58 cred -runListKeys :: FilePath -> IO () +runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO () runListKeys fp = do s <- BS.readFile fp - cred <- pure (parseCredentials @UDP (AsCredFile s)) `orDie` "bad keyring file" + cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file" print $ pretty (ListKeyringKeys cred) -runKeyAdd :: FilePath -> IO () +runKeyAdd :: forall s . (s ~ HBS2Basic) => FilePath -> IO () runKeyAdd fp = do hPrint stderr $ "adding a key into keyring" <+> pretty fp s <- BS.readFile fp - cred <- pure (parseCredentials @UDP (AsCredFile s)) `orDie` "bad keyring file" + cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file" credNew <- addKeyPair Nothing cred print $ pretty $ AsCredFile $ AsBase58 credNew -runKeyDel :: String -> FilePath -> IO () +runKeyDel :: forall s . (s ~ HBS2Basic) => String -> FilePath -> IO () runKeyDel n fp = do hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp s <- BS.readFile fp - cred <- pure (parseCredentials @UDP (AsCredFile s)) `orDie` "bad keyring file" + cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file" credNew <- delKeyPair (AsBase58 n) cred print $ pretty $ AsCredFile $ AsBase58 credNew -runShowPeerKey :: Maybe FilePath -> IO () +runShowPeerKey :: forall s . ( s ~ HBS2Basic) => Maybe FilePath -> IO () runShowPeerKey fp = do handle <- maybe (pure stdin) (`openFile` ReadMode) fp bs <- LBS.hGet handle 4096 <&> LBS.toStrict - let cred' = parseCredentials @UDP (AsCredFile bs) + let cred' = parseCredentials @s (AsCredFile bs) maybe1 cred' exitFailure $ \cred -> do print $ pretty $ AsBase58 (view peerSignPk cred) +-- FIXME: hardcoded-encryption-schema runGenACB :: Maybe FilePath -> Maybe FilePath -> IO () runGenACB inFile outFile = do inf <- maybe (pure stdin) (`openFile` ReadMode) inFile s <- hGetContents inf - acb <- pure (fromStringMay s :: Maybe (ACBSimple UDP)) `orDie` "invalid ACB syntax" + acb <- pure (fromStringMay s :: Maybe (ACBSimple HBS2Basic)) `orDie` "invalid ACB syntax" let bin = serialise acb out <- maybe (pure stdout) (`openFile` WriteMode) outFile LBS.hPutStr out bin hClose out hClose inf - runDumpACB :: Maybe FilePath -> IO () runDumpACB inFile = do inf <- maybe (pure stdin) (`openFile` ReadMode) inFile - acb <- LBS.hGetContents inf <&> deserialise @(ACBSimple UDP) + acb <- LBS.hGetContents inf <&> deserialise @(ACBSimple HBS2Basic) print $ pretty (AsSyntax (DefineACB "a1" acb)) --- -runNewLRef :: FilePath -> FilePath -> Text -> SimpleStorage HbSync -> IO () + +runNewLRef :: forall s . ( ForHBS2Basic s ) => 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) + nodeCred <- (parseCredentials @s . AsCredFile <$> BS.readFile nf) `orDie` "bad node keyring file" - ownerCred <- (parseCredentials @MerkleEncryptionType . AsCredFile <$> BS.readFile uf) + ownerCred <- (parseCredentials @s . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" -- FIXME: extract reusable functions -- полученный хэш будет хэшем ссылки на список референсов ноды - lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @[HashRef] (_peerSignPk nodeCred)) + lrh <- (putBlock ss . serialise) (nodeLinearRefsRef @s (_peerSignPk nodeCred)) `orDie` "can not create node refs genesis" -- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred - chh <- (putBlock ss . serialise) (RefGenesis (_peerSignPk ownerCred) refName NoMetaData) + chh <- (putBlock ss . serialise) (RefGenesis @s (_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 :: forall s . (ForHBS2Basic s) + => SimpleStorage HbSync -> PeerCredentials s -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO () modifyNodeLinearRefList ss kr chh f = modifyLinearRef ss kr chh \mh -> do v <- case mh of @@ -384,16 +386,16 @@ modifyNodeLinearRefList ss kr chh f = (putBlock ss . serialise) (f v) `orDie` "can not put new node channel list block" -runListLRef :: FilePath -> SimpleStorage HbSync -> IO () +runListLRef :: forall s . ( ForHBS2Basic s ) => FilePath -> SimpleStorage HbSync -> IO () runListLRef nf ss = do hPrint stderr $ "listing node channels" <+> pretty nf - nodeCred <- (parseCredentials @UDP . AsCredFile <$> BS.readFile nf) + nodeCred <- (parseCredentials @s . 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) + mg <- (mdeserialiseMay @(RefGenesis s) <$> getBlock ss chh) forM_ mg \g -> do print $ "owner:" <+> viaShow (refOwner g) print $ "title:" <+> viaShow (refName g) @@ -403,33 +405,33 @@ runListLRef nf ss = do print $ "empty" Just refvalraw -> do LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw) + <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s '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 :: forall s . (ForHBS2Basic s) + => SimpleStorage HbSync -> PubKey 'Sign s -> IO [Hash HbSync] readNodeLinearRefList ss pk = do -- полученный хэш будет хэшем ссылки на список референсов ноды lrh :: Hash HbSync <- pure do - (hashObject . serialise) (nodeLinearRefsRef @e pk) + (hashObject . serialise) (nodeLinearRefsRef @s pk) simpleReadLinkVal ss lrh >>= \case Nothing -> pure [] Just refvalraw -> do LinearMutableRefSigned _ ref - <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef e 'LinearRef)) refvalraw) + <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw) `orDie` "can not parse channel ref" fromMaybe mempty . mdeserialiseMay <$> getBlock ss (lrefVal ref) -modifyLinearRef :: forall e. (Signatures e, Serialise (Signature e)) +modifyLinearRef :: forall s. ( ForHBS2Basic s ) => SimpleStorage HbSync - -> PeerCredentials e -- owner keyring + -> PeerCredentials s -- 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) + g :: RefGenesis s <- (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" @@ -444,7 +446,7 @@ modifyLinearRef ss kr chh modIO = do } Just refvalraw -> do -- assert lrefId == h - LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef) + LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef s 'LinearRef) <- pure (deserialiseMay refvalraw) `orDie` "can not parse channel ref" val <- modIO (Just (lrefVal ref)) @@ -454,25 +456,31 @@ modifyLinearRef ss kr chh modIO = do , lrefVal = val } (simpleWriteLinkRaw ss chh . serialise) - (LinearMutableRefSigned @e ((makeSign @e (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr) + (LinearMutableRefSigned @s ((makeSign @s (_peerSignSk kr) . LBS.toStrict . serialise) lmr) lmr) `orDie` "can not write link" pure () -runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO () +runGetLRef :: forall s . ForHBS2Basic s => 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) + <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s '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 :: forall s . (ForHBS2Basic s) + => 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) + ownerCred <- (parseCredentials @s . AsCredFile <$> BS.readFile uf) `orDie` "bad ref owner keyring file" modifyLinearRef ss ownerCred refh \_ -> pure valh @@ -490,7 +498,7 @@ runEnc58 = do s <- LBS.hGetContents stdin <&> LBS.toStrict print $ pretty (AsBase58 s) -runRefLogGet :: RefLogKey e -> SimpleStorage HbSync -> IO () +runRefLogGet :: forall s . IsRefPubKey s => RefLogKey s -> SimpleStorage HbSync -> IO () runRefLogGet s ss = do ref' <- getRef ss s maybe1 ref' exitFailure $ \ref -> do @@ -647,10 +655,11 @@ main = join . customExecParser (prefs showHelpOnError) $ pReflog = hsubparser ( command "get" (info pRefLogGet (progDesc "get reflog root") ) ) + -- FIXME: only-for-hbs2-basic-encryption pRefLogGet = do o <- common reflogs <- strArgument ( metavar "REFLOG" ) - pure $ withStore o (runRefLogGet reflogs) + pure $ withStore o (runRefLogGet @HBS2Basic reflogs) pFsck = do o <- common