voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

merged refactor-crypto-remove-l4-protocol-dependency

This commit is contained in:
Dmitry Zuikov 2023-04-06 09:22:45 +03:00
parent 261641f719
commit 1c8f6b978b
17 changed files with 379 additions and 354 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
hbs2-core/lib/HBS2/Data/Types/Refs.hs
View File

@ -8,15 +8,13 @@ module HBS2.Data.Types.Refs
import HBS2.Base58 import HBS2.Base58
import HBS2.Hash import HBS2.Hash
import HBS2.Merkle import HBS2.Merkle
import HBS2.Net.Proto.Types (Encryption)
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Prelude import HBS2.Prelude
import Codec.Serialise(serialise) import Codec.Serialise(serialise)
import Data.Data import Data.Data
import Data.Functor.Identity
import Data.String(IsString)
import GHC.Generics import GHC.Generics
import Prettyprinter
import Data.Hashable hiding (Hashed) import Data.Hashable hiding (Hashed)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -65,14 +63,14 @@ instance Serialise HashRefObject
--- ---
data RefGenesis e = RefGenesis data RefGenesis s = RefGenesis
{ refOwner :: !(PubKey 'Sign e) { refOwner :: !(PubKey 'Sign s)
, refName :: !Text , refName :: !Text
, refMeta :: !AnnMetaData , refMeta :: !AnnMetaData
} }
deriving stock (Generic) deriving stock (Generic)
instance (Serialise (PubKey 'Sign e)) => Serialise (RefGenesis e) instance Serialise (PubKey 'Sign s) => Serialise (RefGenesis s)
data RefForm data RefForm
= LinearRef = LinearRef
@ -92,7 +90,7 @@ instance Serialise (Refs e 'LinearRef)
data family MutableRef e ( f :: RefForm ) data family MutableRef e ( f :: RefForm )
data instance MutableRef e 'LinearRef data instance MutableRef s 'LinearRef
= LinearMutableRef = LinearMutableRef
{ lrefId :: !(Hash HbSync) { lrefId :: !(Hash HbSync)
, lrefHeight :: !Int , lrefHeight :: !Int
@ -101,7 +99,7 @@ data instance MutableRef e 'LinearRef
} }
deriving stock (Generic, Show) 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 family Signed ( p :: SignPhase ) a
data instance Signed SignaturePresent (MutableRef e 'LinearRef) data instance Signed SignaturePresent (MutableRef s 'LinearRef)
= LinearMutableRefSigned = LinearMutableRefSigned
{ signature :: Signature e { signature :: Signature s
, signedRef :: MutableRef e 'LinearRef , signedRef :: MutableRef s 'LinearRef
} }
deriving stock (Generic) deriving stock (Generic)
instance Serialise (Signature e) => instance Serialise (Signature s) =>
Serialise (Signed 'SignaturePresent (MutableRef e 'LinearRef)) Serialise (Signed 'SignaturePresent (MutableRef s 'LinearRef))
data instance Signed 'SignatureVerified (MutableRef e 'LinearRef) data instance Signed 'SignatureVerified (MutableRef s 'LinearRef)
= LinearMutableRefSignatureVerified = LinearMutableRefSignatureVerified
{ signature :: Signature e { signature :: Signature s
, signedRef :: MutableRef e 'LinearRef , signedRef :: MutableRef s 'LinearRef
, signer :: PubKey 'Sign e , signer :: PubKey 'Sign s
} }
deriving stock (Generic) deriving stock (Generic)
--- ---
nodeLinearRefsRef :: PubKey 'Sign e -> RefGenesis e nodeLinearRefsRef :: PubKey 'Sign s -> RefGenesis s
nodeLinearRefsRef pk = RefGenesis nodeLinearRefsRef pk = RefGenesis
{ refOwner = pk { refOwner = pk
, refName = "List of node linear refs" , 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) 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) 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 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) 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) 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) pretty (RefLogKey k) = pretty (AsBase58 k)

88
hbs2-core/lib/HBS2/Net/Auth/AccessKey.hs
View File

@ -6,34 +6,28 @@
module HBS2.Net.Auth.AccessKey where module HBS2.Net.Auth.AccessKey where
import HBS2.Base58 import HBS2.Base58
import HBS2.Data.Detect
import HBS2.Data.Types import HBS2.Data.Types
import HBS2.Defaults
import HBS2.Merkle import HBS2.Merkle
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Net.Messaging.UDP (UDP) import HBS2.Net.Proto.Definition
import HBS2.Net.Proto.Definition()
import HBS2.Net.Proto.Types
import HBS2.OrDie
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import Codec.Serialise import Codec.Serialise
import Control.Monad ((<=<)) 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.Core.Box qualified as Encrypt
import Crypto.Saltine.Class qualified as Crypto import Crypto.Saltine.Class qualified as Crypto
import Crypto.Saltine.Class (IsEncoding)
import Data.ByteString.Lazy.Char8 qualified as LBS import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import Data.Function
import Data.List.Split (chunksOf) import Data.List.Split (chunksOf)
import Data.Text (Text)
import Data.List qualified as List
import Lens.Micro.Platform type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s)
import Data.Kind , Serialise (PubKey 'Encrypt s)
import Prettyprinter , Serialise (PubKey 'Sign s)
, Serialise (PrivKey 'Sign s)
, Serialise (PrivKey 'Encrypt s)
)
newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString } newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString }
@ -41,32 +35,30 @@ newtype EncryptedBox = EncryptedBox { unEncryptedBox :: ByteString }
instance Serialise EncryptedBox 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 AccessKeyNaClAsymm
{ permitted :: [(PubKey 'Encrypt e, EncryptedBox)] { permitted :: [(PubKey 'Encrypt s, EncryptedBox)]
} }
deriving stock (Generic) 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 GroupKeyNaClAsymm
{ recipientPk :: PubKey 'Encrypt e { recipientPk :: PubKey 'Encrypt s
, accessKey :: AccessKey e 'NaClAsymm , accessKey :: AccessKey s
} }
deriving stock (Generic) 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 -- FIXME: integration-regression-test-for-groupkey
-- Добавить тест: сгенерировали groupkey/распарсили groupkey -- Добавить тест: сгенерировали groupkey/распарсили groupkey
parseGroupKey :: forall e . () parseGroupKey :: forall s . ForAccessKey s
=> AsGroupKeyFile ByteString -> Maybe (GroupKey e 'NaClAsymm) => AsGroupKeyFile ByteString -> Maybe (GroupKey s)
parseGroupKey (AsGroupKeyFile bs) = parseSerialisableFromBase58 bs 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 (AsBase58 c) =
pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c
@ -96,28 +88,30 @@ instance Pretty (AsBase58 a) => Pretty (AsGroupKeyFile (AsBase58 a)) where
$ pretty pc $ pretty pc
-- newtype ListGroupKeyKeys e s = ListGroupKeyKeys (GroupKey e s) parsePubKeys :: forall s . ForAccessKey s
=> ByteString
-- instance () -> Maybe [PubKey 'Encrypt s]
-- => 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 = sequenceA . fmap (Crypto.decode <=< fromBase58) . B8.lines 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) 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 = openEncryptedKey (EncryptedBox bs) kr =
either (const Nothing) Just . deserialiseOrFail . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs either (const Nothing) Just . deserialiseOrFail . LBS.fromStrict =<< Encrypt.boxSealOpen (_krPk kr) (_krSk kr) bs

57
hbs2-core/lib/HBS2/Net/Auth/Credentials.hs
View File

@ -6,6 +6,7 @@
module HBS2.Net.Auth.Credentials where module HBS2.Net.Auth.Credentials where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import HBS2.Net.Proto.Types
import HBS2.Base58 import HBS2.Base58
import Codec.Serialise import Codec.Serialise
@ -19,11 +20,10 @@ import Data.ByteString.Char8 qualified as B8
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import Data.Function import Data.Function
import Data.List.Split (chunksOf) import Data.List.Split (chunksOf)
import Data.Text (Text)
import Data.List qualified as List import Data.List qualified as List
import Lens.Micro.Platform import Lens.Micro.Platform
import Data.Kind import Data.Kind
import Prettyprinter
type family EncryptPubKey e :: Type type family EncryptPubKey e :: Type
@ -39,8 +39,8 @@ class Signatures e where
verifySign :: PubKey 'Sign e -> Signature e -> ByteString -> Bool verifySign :: PubKey 'Sign e -> Signature e -> ByteString -> Bool
class HasCredentials e m where class HasCredentials s m where
getCredentials :: m (PeerCredentials e) getCredentials :: m (PeerCredentials s)
data KeyringEntry e = data KeyringEntry e =
KeyringEntry KeyringEntry
@ -53,17 +53,24 @@ data KeyringEntry e =
deriving stock instance (Eq (PubKey 'Encrypt e), Eq (PrivKey 'Encrypt e)) deriving stock instance (Eq (PubKey 'Encrypt e), Eq (PrivKey 'Encrypt e))
=> Eq (KeyringEntry e) => Eq (KeyringEntry e)
data PeerCredentials e = data PeerCredentials s =
PeerCredentials PeerCredentials
{ _peerSignSk :: PrivKey 'Sign e { _peerSignSk :: PrivKey 'Sign s
, _peerSignPk :: PubKey 'Sign e , _peerSignPk :: PubKey 'Sign s
, _peerKeyring :: [KeyringEntry e] , _peerKeyring :: [KeyringEntry s]
} }
deriving Generic deriving Generic
makeLenses 'KeyringEntry makeLenses 'KeyringEntry
makeLenses 'PeerCredentials 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) type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e)
, Serialise (PubKey 'Sign e) , Serialise (PubKey 'Sign e)
, Serialise (PubKey 'Encrypt e) , Serialise (PubKey 'Encrypt e)
@ -79,24 +86,24 @@ newtype AsCredFile a = AsCredFile a
-- FIXME: integration-regression-test-for-keyring -- FIXME: integration-regression-test-for-keyring
-- Добавить тест: сгенерировали keypair/распарсили keypair -- Добавить тест: сгенерировали keypair/распарсили keypair
newCredentials :: forall e m . ( MonadIO m newCredentials :: forall s m . ( MonadIO m
, Signatures e , Signatures s
, PrivKey 'Sign e ~ Sign.SecretKey , PrivKey 'Sign s ~ Sign.SecretKey
, PubKey 'Sign e ~ Sign.PublicKey , PubKey 'Sign s ~ Sign.PublicKey
) => m (PeerCredentials e) ) => m (PeerCredentials s)
newCredentials = do newCredentials = do
pair <- liftIO Sign.newKeypair 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 newKeypair :: forall s m . ( MonadIO m
, PrivKey 'Encrypt e ~ Encrypt.SecretKey , PrivKey 'Encrypt s ~ Encrypt.SecretKey
, PubKey 'Encrypt e ~ Encrypt.PublicKey , PubKey 'Encrypt s ~ Encrypt.PublicKey
) )
=> Maybe Text -> m (KeyringEntry e) => Maybe Text -> m (KeyringEntry s)
newKeypair txt = do newKeypair txt = do
pair <- liftIO Encrypt.newKeypair 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 addKeyPair :: forall e m . ( MonadIO m
, PrivKey 'Encrypt e ~ Encrypt.SecretKey , PrivKey 'Encrypt e ~ Encrypt.SecretKey
@ -109,8 +116,7 @@ addKeyPair txt cred = do
pure $ cred & over peerKeyring (List.nub . (<> [kp])) pure $ cred & over peerKeyring (List.nub . (<> [kp]))
delKeyPair :: forall e m . ( MonadIO m delKeyPair :: forall e m . ( MonadIO m
, PrivKey 'Encrypt e ~ Encrypt.SecretKey , ForHBS2Basic e
, PubKey 'Encrypt e ~ Encrypt.PublicKey
) )
=> AsBase58 String -> PeerCredentials e -> m (PeerCredentials e) => AsBase58 String -> PeerCredentials e -> m (PeerCredentials e)
delKeyPair (AsBase58 pks) cred = do delKeyPair (AsBase58 pks) cred = do
@ -119,12 +125,11 @@ delKeyPair (AsBase58 pks) cred = do
let rest = [ e | e <- kring, asStr e /= pks ] let rest = [ e | e <- kring, asStr e /= pks ]
pure $ cred & set peerKeyring rest pure $ cred & set peerKeyring rest
parseCredentials :: forall e . ( Signatures e
, PrivKey 'Sign e ~ Sign.SecretKey parseCredentials :: forall s . ( ForHBS2Basic s
, PubKey 'Sign e ~ Sign.PublicKey , SerialisedCredentials s
, SerialisedCredentials e
) )
=> AsCredFile ByteString -> Maybe (PeerCredentials e) => AsCredFile ByteString -> Maybe (PeerCredentials s)
parseCredentials (AsCredFile bs) = parseSerialisableFromBase58 bs parseCredentials (AsCredFile bs) = parseSerialisableFromBase58 bs
parseSerialisableFromBase58 :: Serialise a => ByteString -> Maybe a parseSerialisableFromBase58 :: Serialise a => ByteString -> Maybe a

1
hbs2-core/lib/HBS2/Net/Proto.hs
View File

@ -3,7 +3,6 @@ module HBS2.Net.Proto
, module HBS2.Net.Proto.Types , module HBS2.Net.Proto.Types
) where ) where
import HBS2.Prelude.Plated
import HBS2.Hash import HBS2.Hash
import HBS2.Net.Proto.Types import HBS2.Net.Proto.Types

50
hbs2-core/lib/HBS2/Net/Proto/ACB.hs
View File

@ -5,37 +5,31 @@ module HBS2.Net.Proto.ACB where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Data.Types.Refs (HashRef)
import HBS2.Base58 import HBS2.Base58
import HBS2.Data.Types import HBS2.Data.Types
import HBS2.Net.Proto.Definition
import HBS2.Net.Auth.AccessKey
import Data.Config.Suckless import Data.Config.Suckless
import Control.Applicative import Control.Applicative
import Lens.Micro.Platform import Lens.Micro.Platform
import Codec.Serialise() import Codec.Serialise()
import Prettyprinter
import Data.List qualified as L import Data.List qualified as L
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.Text (Text)
import Data.Maybe import Data.Maybe
import Data.Either 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 s =
data instance ACB 'NaClAsymm e =
ACB1 ACB1
{ _acbRoot :: !(Maybe (PubKey 'Sign e)) -- it's monoid. no choice but Maybe { _acbRoot :: !(Maybe (PubKey 'Sign s)) -- it's monoid. no choice but Maybe
, _acbOwners :: ![PubKey 'Sign e] , _acbOwners :: ![PubKey 'Sign s]
, _acbReaders :: ![PubKey 'Encrypt e] , _acbReaders :: ![PubKey 'Encrypt s]
, _acbWriters :: ![PubKey 'Sign e] , _acbWriters :: ![PubKey 'Sign s]
, _acbPrev :: !(Maybe HashRef) , _acbPrev :: !(Maybe HashRef)
} }
deriving stock (Generic) deriving stock (Generic)
@ -43,20 +37,22 @@ data instance ACB 'NaClAsymm e =
makeLenses 'ACB1 makeLenses 'ACB1
type IsACB e = ( Serialise (PubKey 'Sign e) type ForACB e = ( Serialise (PubKey 'Sign e)
, Serialise (PubKey 'Encrypt e) , Serialise (PubKey 'Encrypt e)
, Eq (PubKey 'Sign e) , Eq (PubKey 'Sign e)
, Eq (PubKey 'Encrypt 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 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) (<>) a b = ACB1 (view acbRoot a <|> view acbRoot b)
(L.nub (view acbOwners a <> view acbOwners b)) (L.nub (view acbOwners a <> view acbOwners b))
(L.nub (view acbReaders a <> view acbReaders 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) (view acbPrev a <|> view acbPrev b)
instance ( Pretty (AsBase58 (PubKey 'Sign e)) instance ( Pretty (AsBase58 (PubKey 'Sign s))
, Pretty (AsBase58 (PubKey 'Encrypt e) ) , Pretty (AsBase58 (PubKey 'Encrypt s) )
) => Pretty (AsSyntax (DefineACB 'NaClAsymm e)) where ) => Pretty (AsSyntax (DefineACB s)) where
pretty (AsSyntax (DefineACB nacb' acb)) = vcat [ pretty (AsSyntax (DefineACB nacb' acb)) = vcat [
"define-acb" <+> nacb "define-acb" <+> nacb
, prev , prev
@ -99,7 +95,7 @@ instance ( Pretty (AsBase58 (PubKey 'Sign e))
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c] pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
pattern Key n ns <- SymbolVal n : ns 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 fromStringMay s = Just $ ACB1 root owners readers writers prev
where where

20
hbs2-core/lib/HBS2/Net/Proto/Definition.hs
View File

@ -33,10 +33,13 @@ import Crypto.Saltine.Core.Sign qualified as Sign
import Crypto.Saltine.Core.Box qualified as Encrypt import Crypto.Saltine.Core.Box qualified as Encrypt
type instance PubKey 'Sign e = Sign.PublicKey
type instance PrivKey 'Sign e = Sign.SecretKey type instance Encryption UDP = HBS2Basic
type instance PubKey 'Encrypt e = Encrypt.PublicKey
type instance PrivKey 'Encrypt e = Encrypt.SecretKey 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 -- FIXME: proper-serialise-for-keys
-- Возможно, нужно написать ручные инстансы Serialise -- Возможно, нужно написать ручные инстансы Serialise
@ -160,13 +163,8 @@ instance MonadIO m => HasNonces () m where
instance Serialise Sign.Signature instance Serialise Sign.Signature
instance Signatures UDP where instance Signatures HBS2Basic where
type Signature UDP = Sign.Signature type Signature HBS2Basic = Sign.Signature
makeSign = Sign.signDetached
verifySign = Sign.signVerifyDetached
instance Signatures MerkleEncryptionType where
type Signature MerkleEncryptionType = Sign.Signature
makeSign = Sign.signDetached makeSign = Sign.signDetached
verifySign = Sign.signVerifyDetached verifySign = Sign.signVerifyDetached

49
hbs2-core/lib/HBS2/Net/Proto/Peer.hs
View File

@ -20,12 +20,12 @@ import Data.Hashable
import Lens.Micro.Platform import Lens.Micro.Platform
import Type.Reflection (someTypeRep) import Type.Reflection (someTypeRep)
type PingSign e = Signature e type PingSign e = Signature (Encryption e)
type PingNonce = BS.ByteString type PingNonce = BS.ByteString
data PeerData e = data PeerData e =
PeerData 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 , _peerOwnNonce :: PeerNonce -- TODO: to use this field to detect if it's own peer to avoid loops
} }
deriving stock (Typeable,Generic) deriving stock (Typeable,Generic)
@ -34,7 +34,7 @@ makeLenses 'PeerData
data PeerHandshake e = data PeerHandshake e =
PeerPing PingNonce PeerPing PingNonce
| PeerPong PingNonce (Signature e) (PeerData e) | PeerPong PingNonce (Signature (Encryption e)) (PeerData e)
deriving stock (Generic) deriving stock (Generic)
newtype KnownPeer e = KnownPeer (PeerData e) newtype KnownPeer e = KnownPeer (PeerData e)
@ -91,20 +91,21 @@ newtype PeerHandshakeAdapter e m =
} }
peerHandShakeProto :: forall e m . ( MonadIO m peerHandShakeProto :: forall e s m . ( MonadIO m
, Response e (PeerHandshake e) m , Response e (PeerHandshake e) m
, Request e (PeerHandshake e) m , Request e (PeerHandshake e) m
, Sessions e (PeerHandshake e) m , Sessions e (PeerHandshake e) m
, Sessions e (KnownPeer e) m , Sessions e (KnownPeer e) m
, HasNonces (PeerHandshake e) m , HasNonces (PeerHandshake e) m
, HasPeerNonce e m , HasPeerNonce e m
, Nonce (PeerHandshake e) ~ PingNonce , Nonce (PeerHandshake e) ~ PingNonce
, Signatures e , Pretty (Peer e)
, Pretty (Peer e) , EventEmitter e (PeerHandshake e) m
, HasCredentials e m , EventEmitter e (ConcretePeer e) m
, EventEmitter e (PeerHandshake e) m , HasCredentials s m
, EventEmitter e (ConcretePeer e) m , Signatures s
) , s ~ Encryption e
)
=> PeerHandshakeAdapter e m => PeerHandshakeAdapter e m
-> PeerHandshake e -> m () -> PeerHandshake e -> m ()
@ -113,10 +114,10 @@ peerHandShakeProto adapter =
PeerPing nonce -> do PeerPing nonce -> do
pip <- thatPeer proto 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 own <- peerNonce @e
@ -139,7 +140,7 @@ peerHandShakeProto adapter =
let pk = view peerSignKey d let pk = view peerSignKey d
let signed = verifySign @e pk sign nonce let signed = verifySign @s pk sign nonce
when signed $ do 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)) deriving instance Eq (Peer e) => Eq (SessionKey e (PeerHandshake e))
instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e)) instance Hashable (Peer e) => Hashable (SessionKey e (PeerHandshake e))
instance ( Serialise (PubKey 'Sign e) instance ( Serialise (PubKey 'Sign (Encryption e))
, Serialise (Signature e) , Serialise (Signature (Encryption e))
, Serialise PeerNonce , Serialise PeerNonce
) )
=> Serialise (PeerData e) => Serialise (PeerData e)
instance ( Serialise (PubKey 'Sign e) instance ( Serialise (PubKey 'Sign (Encryption e))
, Serialise (Signature e) , Serialise (Signature (Encryption e))
, Serialise PeerNonce , Serialise PeerNonce
) )

99
hbs2-core/lib/HBS2/Net/Proto/RefLog.hs
View File

@ -12,6 +12,7 @@ import HBS2.Base58
import HBS2.Events import HBS2.Events
import HBS2.Net.Proto.Peer import HBS2.Net.Proto.Peer
import HBS2.Net.Proto.Sessions import HBS2.Net.Proto.Sessions
import HBS2.Data.Types.Refs
import HBS2.System.Logger.Simple import HBS2.System.Logger.Simple
@ -22,16 +23,16 @@ import Type.Reflection (someTypeRep)
import Lens.Micro.Platform import Lens.Micro.Platform
data RefLogRequest e = data RefLogRequest e =
RefLogRequest (PubKey 'Sign e) RefLogRequest (PubKey 'Sign (Encryption e))
| RefLogResponse (PubKey 'Sign e) (Hash HbSync) | RefLogResponse (PubKey 'Sign (Encryption e)) (Hash HbSync)
deriving stock (Generic) deriving stock (Generic)
data RefLogUpdate e = data RefLogUpdate e =
RefLogUpdate RefLogUpdate
{ _refLogId :: PubKey 'Sign e { _refLogId :: PubKey 'Sign (Encryption e)
, _refLogUpdNonce :: Nonce (RefLogUpdate e) , _refLogUpdNonce :: Nonce (RefLogUpdate e)
, _refLogUpdData :: ByteString , _refLogUpdData :: ByteString
, _refLogUpdSign :: Signature e , _refLogUpdSign :: Signature (Encryption e)
} }
deriving stock (Generic) deriving stock (Generic)
@ -55,7 +56,7 @@ instance Typeable (RefLogUpdateEv e) => Hashable (EventKey e (RefLogUpdateEv e))
p = Proxy @RefLogUpdateEv p = Proxy @RefLogUpdateEv
newtype instance Event e (RefLogUpdateEv e) = newtype instance Event e (RefLogUpdateEv e) =
RefLogUpdateEvData (PubKey 'Sign e, RefLogUpdate e) RefLogUpdateEvData (PubKey 'Sign (Encryption e), RefLogUpdate e)
deriving (Typeable) deriving (Typeable)
instance EventType ( Event e (RefLogUpdateEv e) ) where instance EventType ( Event e (RefLogUpdateEv e) ) where
@ -74,7 +75,7 @@ instance Typeable (RefLogRequestAnswer e) => Hashable (EventKey e (RefLogRequest
p = Proxy @(RefLogRequestAnswer e) p = Proxy @(RefLogRequestAnswer e)
data instance Event e (RefLogRequestAnswer e) = data instance Event e (RefLogRequestAnswer e) =
RefLogReqAnswerData (PubKey 'Sign e) (Hash HbSync) RefLogReqAnswerData (PubKey 'Sign (Encryption e)) (Hash HbSync)
deriving (Typeable) deriving (Typeable)
instance EventType ( Event e (RefLogRequestAnswer e) ) where 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 instance Expires (EventKey e (RefLogRequestAnswer e)) where
expiresIn = const Nothing expiresIn = const Nothing
makeRefLogUpdate :: forall e m . ( MonadIO m makeRefLogUpdate :: forall e s m . ( MonadIO m
, HasNonces (RefLogUpdate e) m , HasNonces (RefLogUpdate e) m
, Nonce (RefLogUpdate e) ~ ByteString , Nonce (RefLogUpdate e) ~ ByteString
, Signatures e , Signatures s
) , s ~ Encryption e
=> PubKey 'Sign e , IsRefPubKey s
-> PrivKey 'Sign e )
=> PubKey 'Sign s
-> PrivKey 'Sign s
-> ByteString -> ByteString
-> m (RefLogUpdate e) -> m (RefLogUpdate e)
makeRefLogUpdate pubk privk bs = do makeRefLogUpdate pubk privk bs = do
nonce <- newNonce @(RefLogUpdate e) nonce <- newNonce @(RefLogUpdate e)
let noncebs = nonce <> bs let noncebs = nonce <> bs
let sign = makeSign @e privk noncebs let sign = makeSign @s privk noncebs
pure $ RefLogUpdate pubk nonce bs sign pure $ RefLogUpdate pubk nonce bs sign
verifyRefLogUpdate :: forall e m . ( MonadIO m verifyRefLogUpdate :: forall e s m . ( MonadIO m
-- , HasNonces (RefLogUpdate e) m , Nonce (RefLogUpdate e) ~ ByteString
, Nonce (RefLogUpdate e) ~ ByteString , Signatures s
, Signatures e , s ~ Encryption e
) )
=> RefLogUpdate e -> m Bool => RefLogUpdate e -> m Bool
verifyRefLogUpdate msg = do verifyRefLogUpdate msg = do
let pubk = view refLogId msg let pubk = view refLogId msg
let noncebs = view refLogUpdNonce msg <> view refLogUpdData msg let noncebs = view refLogUpdNonce msg <> view refLogUpdData msg
let sign = view refLogUpdSign msg let sign = view refLogUpdSign msg
pure $ verifySign @e pubk sign noncebs pure $ verifySign @s pubk sign noncebs
data RefLogRequestI e m = data RefLogRequestI e m =
RefLogRequestI RefLogRequestI
{ onRefLogRequest :: (Peer e, PubKey 'Sign e) -> m (Maybe (Hash HbSync)) { onRefLogRequest :: (Peer e, PubKey 'Sign (Encryption e)) -> m (Maybe (Hash HbSync))
, onRefLogResponse :: (Peer e, PubKey 'Sign e, Hash HbSync) -> m () , onRefLogResponse :: (Peer e, PubKey 'Sign (Encryption e), Hash HbSync) -> m ()
} }
refLogRequestProto :: forall e m . ( MonadIO m refLogRequestProto :: forall e s m . ( MonadIO m
, Request e (RefLogRequest e) m , Request e (RefLogRequest e) m
, Response e (RefLogRequest e) m , Response e (RefLogRequest e) m
, HasDeferred e (RefLogRequest e) m , HasDeferred e (RefLogRequest e) m
, Sessions e (KnownPeer e) m , Sessions e (KnownPeer e) m
, IsPeerAddr e m , IsPeerAddr e m
, Pretty (AsBase58 (PubKey 'Sign e)) , Pretty (AsBase58 (PubKey 'Sign (Encryption e)))
, EventEmitter e (RefLogRequestAnswer e) m , EventEmitter e (RefLogRequestAnswer e) m
, Pretty (Peer e) , Pretty (Peer e)
) , s ~ Encryption e
)
=> RefLogRequestI e m -> RefLogRequest e -> m () => RefLogRequestI e m -> RefLogRequest e -> m ()
refLogRequestProto adapter cmd = do refLogRequestProto adapter cmd = do
@ -155,18 +159,19 @@ refLogRequestProto adapter cmd = do
where where
proto = Proxy @(RefLogRequest e) proto = Proxy @(RefLogRequest e)
refLogUpdateProto :: forall e m . ( MonadIO m refLogUpdateProto :: forall e s m . ( MonadIO m
, Request e (RefLogUpdate e) m , Request e (RefLogUpdate e) m
, Response e (RefLogUpdate e) m , Response e (RefLogUpdate e) m
, HasDeferred e (RefLogUpdate e) m , HasDeferred e (RefLogUpdate e) m
, IsPeerAddr e m , IsPeerAddr e m
, Pretty (Peer e) , Pretty (Peer e)
, Signatures e , Nonce (RefLogUpdate e) ~ ByteString
, Nonce (RefLogUpdate e) ~ ByteString , Sessions e (KnownPeer e) m
, Sessions e (KnownPeer e) m , Signatures s
, Pretty (AsBase58 (PubKey 'Sign e)) , Pretty (AsBase58 (PubKey 'Sign s))
, EventEmitter e (RefLogUpdateEv e) m , EventEmitter e (RefLogUpdateEv e) m
) , s ~ Encryption e
)
=> RefLogUpdateI e m -> RefLogUpdate e -> m () => RefLogUpdateI e m -> RefLogUpdate e -> m ()
refLogUpdateProto adapter = refLogUpdateProto adapter =
@ -193,12 +198,12 @@ refLogUpdateProto adapter =
where where
proto = Proxy @(RefLogUpdate e) proto = Proxy @(RefLogUpdate e)
instance ( Serialise (PubKey 'Sign e) instance ( Serialise (PubKey 'Sign (Encryption e))
, Serialise (Nonce (RefLogUpdate e)) , Serialise (Nonce (RefLogUpdate e))
, Serialise (Signature e) , Serialise (Signature (Encryption e))
) => Serialise (RefLogUpdate e) ) => Serialise (RefLogUpdate e)
instance ( Serialise (PubKey 'Sign e) instance ( Serialise (PubKey 'Sign (Encryption e))
) => Serialise (RefLogRequest e) ) => Serialise (RefLogRequest e)

10
hbs2-core/lib/HBS2/Net/Proto/Types.hs
View File

@ -16,13 +16,17 @@ import Data.Hashable
import Control.Monad.IO.Class import Control.Monad.IO.Class
import System.Random qualified as Random import System.Random qualified as Random
import Data.Digest.Murmur32 import Data.Digest.Murmur32
import Data.ByteString (ByteString)
import Lens.Micro.Platform
import Data.Text (Text)
-- e -> Transport (like, UDP or TChan) -- e -> Transport (like, UDP or TChan)
-- p -> L4 Protocol (like Ping/Pong) -- 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 class Monad m => GenCookie e m where
genCookie :: Hashable salt => salt -> m (Cookie e) genCookie :: Hashable salt => salt -> m (Cookie e)

14
hbs2-git/lib/HBS2Git/App.hs
View File

@ -15,6 +15,7 @@ import HBS2.Hash
import HBS2.System.Logger.Simple import HBS2.System.Logger.Simple
import HBS2.Merkle import HBS2.Merkle
import HBS2.Git.Types import HBS2.Git.Types
import HBS2.Net.Messaging.UDP (UDP)
import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Definition()
import HBS2.Net.Auth.Credentials hiding (getCredentials) import HBS2.Net.Auth.Credentials hiding (getCredentials)
import HBS2.Net.Proto.RefLog import HBS2.Net.Proto.RefLog
@ -324,7 +325,15 @@ readObject h = runMaybeT do
mconcat <$> liftIO (atomically $ flushTQueue q) 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 postRefUpdate ref seqno hash = do
trace $ "refPostUpdate" <+> pretty seqno <+> pretty hash trace $ "refPostUpdate" <+> pretty seqno <+> pretty hash
@ -333,7 +342,8 @@ postRefUpdate ref seqno hash = do
let privk = view peerSignSk cred let privk = view peerSignSk cred
let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash) let tran = SequentialRef seqno (AnnotatedHashRef Nothing hash)
let bs = serialise tran & LBS.toStrict 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 input = byteStringInput msg
let cmd = setStdin input $ shell [qc|hbs2-peer reflog send-raw|] let cmd = setStdin input $ shell [qc|hbs2-peer reflog send-raw|]

2
hbs2-git/lib/HBS2Git/Import.hs
View File

@ -70,7 +70,7 @@ importRefLog db ref = do
runMaybeT $ do runMaybeT $ do
bs <- MaybeT $ readBlock e 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 e <- MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd) & either (const Nothing) Just
let (SequentialRef n (AnnotatedHashRef _ h)) = e let (SequentialRef n (AnnotatedHashRef _ h)) = e
withDB db $ stateUpdateRefLog n h withDB db $ stateUpdateRefLog n h

5
hbs2-git/lib/HBS2Git/Types.hs
View File

@ -12,6 +12,7 @@ import HBS2.Prelude.Plated
import HBS2.Git.Types import HBS2.Git.Types
import HBS2.Net.Messaging.UDP (UDP) import HBS2.Net.Messaging.UDP (UDP)
import HBS2.Data.Types.Refs import HBS2.Data.Types.Refs
import HBS2.Net.Proto.Types
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import Data.Config.Suckless import Data.Config.Suckless
@ -35,7 +36,9 @@ import System.IO (Handle)
import Data.Kind import Data.Kind
import Control.Monad.Catch import Control.Monad.Catch
type Schema = UDP -- FIXME: remove-udp-hardcode-asap
type Schema = HBS2Basic
type HBS2L4Proto = UDP
-- FIXME: introduce-API-type -- FIXME: introduce-API-type
type API = String type API = String

17
hbs2-peer/app/HttpWorker.hs
View File

@ -3,18 +3,15 @@ module HttpWorker where
import HBS2.Prelude import HBS2.Prelude
import HBS2.Actors.Peer import HBS2.Actors.Peer
import HBS2.Storage import HBS2.Storage
import HBS2.Hash
import HBS2.Data.Types.Refs import HBS2.Data.Types.Refs
import HBS2.Net.Proto.Types
import HBS2.System.Logger.Simple import HBS2.System.Logger.Simple
import PeerTypes import PeerTypes
import PeerConfig import PeerConfig
import Data.Maybe
import Data.Function
import Data.Functor import Data.Functor
import Data.Text.Lazy qualified as Text
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import Network.Wai.Middleware.RequestLogger import Network.Wai.Middleware.RequestLogger
@ -25,10 +22,12 @@ import Web.Scotty
-- TODO: introduce-http-of-off-feature -- TODO: introduce-http-of-off-feature
httpWorker :: forall e m . ( MyPeer e httpWorker :: forall e s m . ( MyPeer e
, MonadIO m , MonadIO m
, HasStorage m , HasStorage m
) => PeerConfig -> DownloadEnv e -> m () , IsRefPubKey s
, s ~ Encryption e
) => PeerConfig -> DownloadEnv e -> m ()
httpWorker conf e = do httpWorker conf e = do
@ -63,7 +62,7 @@ httpWorker conf e = do
case re of case re of
Nothing -> status status404 Nothing -> status status404
Just ref -> do Just ref -> do
va <- liftIO $ getRef sto (RefLogKey ref) va <- liftIO $ getRef sto (RefLogKey @s ref)
maybe1 va (status status404) $ \val -> do maybe1 va (status status404) $ \val -> do
text [qc|{pretty val}|] text [qc|{pretty val}|]

66
hbs2-peer/app/PeerMain.hs
View File

@ -53,8 +53,6 @@ import Crypto.Saltine (sodiumInit)
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
import Data.ByteString qualified as BS import Data.ByteString qualified as BS
import Data.Either
import Data.Foldable (for_)
import Data.Function import Data.Function
import Data.List qualified as L import Data.List qualified as L
import Data.Map qualified as Map import Data.Map qualified as Map
@ -62,13 +60,9 @@ import Data.Maybe
import Data.Set qualified as Set import Data.Set qualified as Set
import Data.Set (Set) import Data.Set (Set)
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.Text (Text)
import GHC.Stats
import GHC.TypeLits
import Lens.Micro.Platform import Lens.Micro.Platform
import Network.Socket import Network.Socket
import Options.Applicative import Options.Applicative
import Prettyprinter
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
@ -101,7 +95,7 @@ data PeerTraceKey
data PeerProxyFetchKey data PeerProxyFetchKey
data AcceptAnnounce = AcceptAnnounceAll data AcceptAnnounce = AcceptAnnounceAll
| AcceptAnnounceFrom (Set (PubKey 'Sign UDP)) | AcceptAnnounceFrom (Set (PubKey 'Sign (Encryption UDP)))
instance Pretty AcceptAnnounce where instance Pretty AcceptAnnounce where
pretty = \case pretty = \case
@ -142,7 +136,7 @@ instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
where where
fromAll = headMay [ AcceptAnnounceAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ] fromAll = headMay [ AcceptAnnounceAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ]
lst = Set.fromList $ 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 | ListVal @C (Key s [LitStrVal e]) <- syn, s == kk
] ]
kk = key @PeerAcceptAnnounceKey @AcceptAnnounce kk = key @PeerAcceptAnnounceKey @AcceptAnnounce
@ -166,8 +160,8 @@ data RPCCommand =
| PEERS | PEERS
| SETLOG SetLogging | SETLOG SetLogging
| REFLOGUPDATE ByteString | REFLOGUPDATE ByteString
| REFLOGFETCH (PubKey 'Sign UDP) | REFLOGFETCH (PubKey 'Sign (Encryption UDP))
| REFLOGGET (PubKey 'Sign UDP) | REFLOGGET (PubKey 'Sign (Encryption UDP))
data PeerOpts = data PeerOpts =
PeerOpts PeerOpts
@ -315,7 +309,7 @@ runCLI = join . customExecParser (prefs showHelpOnError) $
trace "pRefLogSend" trace "pRefLogSend"
s <- BS.readFile kr s <- BS.readFile kr
-- FIXME: UDP is weird here -- 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 bs <- BS.take defChunkSize <$> BS.hGetContents stdin
let pubk = view peerSignPk creds let pubk = view peerSignPk creds
let privk = view peerSignSk creds let privk = view peerSignSk creds
@ -352,63 +346,67 @@ myException :: SomeException -> IO ()
myException e = die ( show e ) >> exitFailure myException e = die ( show e ) >> exitFailure
newtype CredentialsM e m a = newtype CredentialsM e s m a =
CredentialsM { fromCredentials :: ReaderT (PeerCredentials e) m a } CredentialsM { fromCredentials :: ReaderT (PeerCredentials s) m a }
deriving newtype ( Functor deriving newtype ( Functor
, Applicative , Applicative
, Monad , Monad
, MonadIO , MonadIO
, MonadReader (PeerCredentials e) , MonadReader (PeerCredentials s)
, MonadTrans) , MonadTrans)
withCredentials :: forall e m a . (HasOwnPeer e m, Monad m) withCredentials :: forall e s m a . (HasOwnPeer e m, Monad m, s ~ Encryption e)
=> PeerCredentials e => PeerCredentials s
-> CredentialsM e m a -> m a -> CredentialsM e s m a -> m a
withCredentials pc m = runReaderT (fromCredentials m) pc 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 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 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 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) find k f = lift (find k f)
fetch i d k f = lift (fetch i d k f) fetch i d k f = lift (fetch i d k f)
update d k f = lift (update d k f) update d k f = lift (update d k f)
expire k = lift (expire k) 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 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 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 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 thatPeer = lift . thatPeer
instance ( EventEmitter e p m 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 emit k d = lift $ emit k d
instance ( Monad m instance ( Monad m
, Response e p 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 response = lift . response
-- runPeer :: forall e . (e ~ UDP, Nonce (RefLogUpdate e) ~ BS.ByteString) => PeerOpts -> IO () -- 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 runPeer opts = Exception.handle myException $ do
@ -445,7 +443,7 @@ runPeer opts = Exception.handle myException $ do
let whs = cfgValue @PeerWhiteListKey conf :: Set String let whs = cfgValue @PeerWhiteListKey conf :: Set String
let toKeys xs = Set.fromList let toKeys xs = Set.fromList
$ catMaybes [ fromStringMay x | x <- Set.toList xs $ catMaybes [ fromStringMay x | x <- Set.toList xs
] :: Set (PubKey 'Sign UDP) ]
let blkeys = toKeys bls let blkeys = toKeys bls
let wlkeys = toKeys (whs `Set.difference` bls) let wlkeys = toKeys (whs `Set.difference` bls)
let helpFetchKeys = cfgValue @PeerProxyFetchKey conf & toKeys let helpFetchKeys = cfgValue @PeerProxyFetchKey conf & toKeys
@ -471,9 +469,9 @@ runPeer opts = Exception.handle myException $ do
let ps = mempty let ps = mempty
pc' <- LBS.readFile credFile pc' <- LBS.readFile credFile
<&> parseCredentials @e . AsCredFile <&> parseCredentials @(Encryption e) . AsCredFile
. LBS.toStrict . LBS.toStrict
. LBS.take 4096 . LBS.take 4096
pc <- pure pc' `orDie` "can't parse credential file" 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 (blockSizeProto blk dontHandle onNoBlock)
, makeResponse (blockChunksProto adapter) , makeResponse (blockChunksProto adapter)
, makeResponse blockAnnounceProto , makeResponse blockAnnounceProto
, makeResponse (withCredentials pc . peerHandShakeProto hshakeAdapter) , makeResponse (withCredentials @e pc . peerHandShakeProto hshakeAdapter)
, makeResponse peerExchangeProto , makeResponse peerExchangeProto
, makeResponse (refLogUpdateProto reflogAdapter) , makeResponse (refLogUpdateProto reflogAdapter)
, makeResponse (refLogRequestProto reflogReqAdapter) , makeResponse (refLogRequestProto reflogReqAdapter)
@ -872,7 +870,7 @@ runPeer opts = Exception.handle myException $ do
who <- thatPeer (Proxy @(RPC e)) who <- thatPeer (Proxy @(RPC e))
void $ liftIO $ async $ withPeerM penv $ do void $ liftIO $ async $ withPeerM penv $ do
sto <- getStorage sto <- getStorage
h <- liftIO $ getRef sto (RefLogKey puk) h <- liftIO $ getRef sto (RefLogKey @(Encryption e) puk)
request who (RPCRefLogGetAnswer @e h) request who (RPCRefLogGetAnswer @e h)
let arpc = RpcAdapter pokeAction let arpc = RpcAdapter pokeAction

22
hbs2-peer/app/RPC.hs
View File

@ -10,9 +10,6 @@ import HBS2.Actors.Peer
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Net.Proto.Definition() import HBS2.Net.Proto.Definition()
import PeerConfig
import Data.Text (Text)
import Control.Monad.Reader import Control.Monad.Reader
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Codec.Serialise (serialise,deserialiseOrFail) import Codec.Serialise (serialise,deserialiseOrFail)
@ -29,21 +26,20 @@ data RPC e =
RPCPoke RPCPoke
| RPCPing (PeerAddr e) | RPCPing (PeerAddr e)
| RPCPong (PeerAddr e) | RPCPong (PeerAddr e)
| RPCPokeAnswer (PubKey 'Sign e) | RPCPokeAnswer (PubKey 'Sign (Encryption e))
| RPCPokeAnswerFull Text | RPCPokeAnswerFull Text
| RPCAnnounce (Hash HbSync) | RPCAnnounce (Hash HbSync)
| RPCFetch (Hash HbSync) | RPCFetch (Hash HbSync)
| RPCPeers | RPCPeers
| RPCPeersAnswer (PeerAddr e) (PubKey 'Sign e) | RPCPeersAnswer (PeerAddr e) (PubKey 'Sign (Encryption e))
| RPCLogLevel SetLogging | RPCLogLevel SetLogging
| RPCRefLogUpdate ByteString | RPCRefLogUpdate ByteString
| RPCRefLogFetch (PubKey 'Sign e) | RPCRefLogFetch (PubKey 'Sign (Encryption e))
| RPCRefLogGet (PubKey 'Sign e) | RPCRefLogGet (PubKey 'Sign (Encryption e))
| RPCRefLogGetAnswer (Maybe (Hash HbSync)) | RPCRefLogGetAnswer (Maybe (Hash HbSync))
deriving stock (Generic) deriving stock (Generic)
instance (Serialise (PeerAddr e), Serialise (PubKey 'Sign (Encryption e))) => Serialise (RPC e)
instance Serialise (PeerAddr e) => Serialise (RPC e)
instance HasProtocol UDP (RPC UDP) where instance HasProtocol UDP (RPC UDP) where
type instance ProtocolId (RPC UDP) = 0xFFFFFFE0 type instance ProtocolId (RPC UDP) = 0xFFFFFFE0
@ -63,18 +59,18 @@ makeLenses 'RPCEnv
data RpcAdapter e m = data RpcAdapter e m =
RpcAdapter RpcAdapter
{ rpcOnPoke :: RPC e -> m () { rpcOnPoke :: RPC e -> m ()
, rpcOnPokeAnswer :: PubKey 'Sign e -> m () , rpcOnPokeAnswer :: PubKey 'Sign (Encryption e) -> m ()
, rpcOnPokeAnswerFull :: Text -> m () , rpcOnPokeAnswerFull :: Text -> m ()
, rpcOnAnnounce :: Hash HbSync -> m () , rpcOnAnnounce :: Hash HbSync -> m ()
, rpcOnPing :: PeerAddr e -> m () , rpcOnPing :: PeerAddr e -> m ()
, rpcOnPong :: PeerAddr e -> m () , rpcOnPong :: PeerAddr e -> m ()
, rpcOnFetch :: Hash HbSync -> m () , rpcOnFetch :: Hash HbSync -> m ()
, rpcOnPeers :: RPC e -> m () , rpcOnPeers :: RPC e -> m ()
, rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign e) -> m () , rpcOnPeersAnswer :: (PeerAddr e, PubKey 'Sign (Encryption e)) -> m ()
, rpcOnLogLevel :: SetLogging -> m () , rpcOnLogLevel :: SetLogging -> m ()
, rpcOnRefLogUpdate :: ByteString -> m () , rpcOnRefLogUpdate :: ByteString -> m ()
, rpcOnRefLogFetch :: PubKey 'Sign e -> m () , rpcOnRefLogFetch :: PubKey 'Sign (Encryption e) -> m ()
, rpcOnRefLogGet :: PubKey 'Sign e -> m () , rpcOnRefLogGet :: PubKey 'Sign (Encryption e) -> m ()
, rpcOnRefLogGetAnsw :: Maybe (Hash HbSync) -> m () , rpcOnRefLogGetAnsw :: Maybe (Hash HbSync) -> m ()
} }

74
hbs2-peer/app/RefLog.hs
View File

@ -57,36 +57,37 @@ doRefLogBroadCast msg = do
request @e pip msg request @e pip msg
mkRefLogRequestAdapter :: forall e m . ( MonadIO m mkRefLogRequestAdapter :: forall e s m . ( MonadIO m
, HasPeerLocator e m , HasPeerLocator e m
, MyPeer e , MyPeer e
, HasStorage m , HasStorage m
, Pretty (AsBase58 (PubKey 'Sign e)) , IsRefPubKey s
) , Pretty (AsBase58 (PubKey 'Sign s))
, s ~ Encryption e
)
=> m (RefLogRequestI e (ResponseM e m )) => m (RefLogRequestI e (ResponseM e m ))
mkRefLogRequestAdapter = do mkRefLogRequestAdapter = do
sto <- getStorage sto <- getStorage
pure $ RefLogRequestI (doOnRefLogRequest sto) dontHandle pure $ RefLogRequestI (doOnRefLogRequest sto) dontHandle
doOnRefLogRequest :: forall e m . ( MonadIO m doOnRefLogRequest :: forall e s m . ( MonadIO m
, MyPeer e , MyPeer e
) , s ~ Encryption e
=> AnyStorage -> (Peer e, PubKey 'Sign e) -> m (Maybe (Hash HbSync)) , IsRefPubKey s
)
=> AnyStorage -> (Peer e, PubKey 'Sign s) -> m (Maybe (Hash HbSync))
doOnRefLogRequest sto (_,pk) = do doOnRefLogRequest sto (_,pk) = liftIO $ getRef sto (RefLogKey @s pk)
r <- liftIO $ getRef sto (RefLogKey pk)
trace $ "doOnRefLogRequest" <+> pretty (AsBase58 pk) <+> pretty r
pure r
mkAdapter :: forall e s m . ( MonadIO m
mkAdapter :: forall e m . ( MonadIO m , HasPeerLocator e m
, HasPeerLocator e m , Sessions e (KnownPeer e) m
, Sessions e (KnownPeer e) m , Request e (RefLogUpdate e) m
, Request e (RefLogUpdate e) m , MyPeer e
, MyPeer e -- , Pretty (AsBase58 (PubKey 'Sign s))
, Pretty (AsBase58 (PubKey 'Sign e)) , s ~ Encryption e
) )
=> m (RefLogUpdateI e (ResponseM e m )) => m (RefLogUpdateI e (ResponseM e m ))
mkAdapter = do mkAdapter = do
@ -97,19 +98,22 @@ mkAdapter = do
data RefLogWorkerAdapter e = data RefLogWorkerAdapter e =
RefLogWorkerAdapter RefLogWorkerAdapter
{ reflogDownload :: Hash HbSync -> IO () { reflogDownload :: Hash HbSync -> IO ()
, reflogFetch :: PubKey 'Sign e -> IO () , reflogFetch :: PubKey 'Sign (Encryption e) -> IO ()
} }
reflogWorker :: forall e m . ( MonadIO m, MyPeer e reflogWorker :: forall e s m . ( MonadIO m, MyPeer e
, EventListener e (RefLogUpdateEv e) m , EventListener e (RefLogUpdateEv e) m
, EventListener e (RefLogRequestAnswer e) m , EventListener e (RefLogRequestAnswer e) m
-- , Request e (RefLogRequest e) (Peerm -- , Request e (RefLogRequest e) (Peerm
, HasStorage m , HasStorage m
, Nonce (RefLogUpdate e) ~ BS.ByteString , Nonce (RefLogUpdate e) ~ BS.ByteString
, Signatures e , Serialise (RefLogUpdate e)
, Serialise (RefLogUpdate e) , EventEmitter e (RefLogUpdateEv e) m -- (PeerM e m)
, EventEmitter e (RefLogUpdateEv e) m -- (PeerM e m) , Signatures s
) , s ~ Encryption e
, IsRefPubKey s
, Pretty (AsBase58 (PubKey 'Sign s))
)
=> PeerConfig => PeerConfig
-> RefLogWorkerAdapter e -> RefLogWorkerAdapter e
-> m () -> m ()
@ -193,7 +197,7 @@ reflogWorker conf adapter = do
let (PeerConfig syn) = conf 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 let defPoll = lastDef 10 [ x
| ListVal @C (Key "poll-default" [SymbolVal "reflog", LitIntVal x]) <- syn | ListVal @C (Key "poll-default" [SymbolVal "reflog", LitIntVal x]) <- syn
@ -232,8 +236,8 @@ reflogWorker conf adapter = do
let byRef = HashMap.fromListWith (<>) els let byRef = HashMap.fromListWith (<>) els
for_ (HashMap.toList byRef) $ \(r,x) -> do for_ (HashMap.toList byRef) $ \(r,x) -> do
let reflogkey = RefLogKey r let reflogkey = RefLogKey @s r
h' <- liftIO $! getRef sto (RefLogKey r) h' <- liftIO $! getRef sto (RefLogKey @s r)
hashes <- liftIO $ readHashesFromBlock sto h' <&> HashSet.fromList hashes <- liftIO $ readHashesFromBlock sto h' <&> HashSet.fromList

103
hbs2/Main.hs
View File

@ -5,6 +5,7 @@ import HBS2.Data.Detect
import HBS2.Data.Types import HBS2.Data.Types
import HBS2.Defaults import HBS2.Defaults
import HBS2.Merkle import HBS2.Merkle
import HBS2.Net.Proto.Types
import HBS2.Net.Auth.AccessKey import HBS2.Net.Auth.AccessKey
import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials
import HBS2.Net.Messaging.UDP (UDP) import HBS2.Net.Messaging.UDP (UDP)
@ -129,7 +130,7 @@ runHash opts ss = do
withBinaryFile (hashFp opts) ReadMode $ \h -> do withBinaryFile (hashFp opts) ReadMode $ \h -> do
LBS.hGetContents h >>= print . pretty . hashObject @HbSync 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 runCat opts ss | catRaw opts == Just True = do
@ -181,11 +182,11 @@ runCat opts ss = do
`orDie` "block encrypted. keyring required" `orDie` "block encrypted. keyring required"
s <- BS.readFile keyringFile s <- BS.readFile keyringFile
ourKeys <- _peerKeyring ourKeys <- _peerKeyring
<$> pure (parseCredentials @MerkleEncryptionType (AsCredFile s)) <$> pure (parseCredentials @s (AsCredFile s))
`orDie` "bad keyring file" `orDie` "bad keyring file"
blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth) blkc <- getBlock ss crypth `orDie` (show $ "missed block: " <+> pretty crypth)
recipientKeys :: [(PubKey 'Encrypt MerkleEncryptionType, EncryptedBox)] recipientKeys :: [(PubKey 'Encrypt s, EncryptedBox)]
<- pure (deserialiseMay blkc) <- pure (deserialiseMay blkc)
`orDie` "can not deserialise access key" `orDie` "can not deserialise access key"
@ -266,7 +267,7 @@ runStore opts ss = do
print $ "merkle-root: " <+> pretty root print $ "merkle-root: " <+> pretty root
Just gkfile -> do Just gkfile -> do
gk :: GroupKey MerkleEncryptionType 'NaClAsymm gk :: GroupKey HBS2Basic
<- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile)) <- (parseGroupKey . AsGroupKeyFile <$> BS.readFile (unOptGroupkeyFile gkfile))
`orDie` "bad groupkey file" `orDie` "bad groupkey file"
@ -290,92 +291,93 @@ runStore opts ss = do
print $ "merkle-ann-root: " <+> pretty mannh print $ "merkle-ann-root: " <+> pretty mannh
runNewGroupkey :: FilePath -> IO () runNewGroupkey :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
runNewGroupkey pubkeysFile = do runNewGroupkey pubkeysFile = do
s <- BS.readFile pubkeysFile s <- BS.readFile pubkeysFile
pubkeys <- pure (parsePubKeys s) `orDie` "bad pubkeys file" pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file"
keypair <- newKeypair @MerkleEncryptionType Nothing keypair <- newKeypair @s Nothing
accesskey <- AccessKeyNaClAsymm <$> do accesskey <- AccessKeyNaClAsymm @s <$> do
List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk
print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey
runNewKey :: IO () runNewKey :: forall s . (s ~ HBS2Basic) => IO ()
runNewKey = do runNewKey = do
cred <- newCredentials @UDP cred <- newCredentials @s
print $ pretty $ AsCredFile $ AsBase58 cred print $ pretty $ AsCredFile $ AsBase58 cred
runListKeys :: FilePath -> IO () runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
runListKeys fp = do runListKeys fp = do
s <- BS.readFile 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"
print $ pretty (ListKeyringKeys cred) print $ pretty (ListKeyringKeys cred)
runKeyAdd :: FilePath -> IO () runKeyAdd :: forall s . (s ~ HBS2Basic) => FilePath -> IO ()
runKeyAdd fp = do runKeyAdd fp = do
hPrint stderr $ "adding a key into keyring" <+> pretty fp hPrint stderr $ "adding a key into keyring" <+> pretty fp
s <- BS.readFile 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 credNew <- addKeyPair Nothing cred
print $ pretty $ AsCredFile $ AsBase58 credNew print $ pretty $ AsCredFile $ AsBase58 credNew
runKeyDel :: String -> FilePath -> IO () runKeyDel :: forall s . (s ~ HBS2Basic) => String -> FilePath -> IO ()
runKeyDel n fp = do runKeyDel n fp = do
hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp
s <- BS.readFile 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 credNew <- delKeyPair (AsBase58 n) cred
print $ pretty $ AsCredFile $ AsBase58 credNew print $ pretty $ AsCredFile $ AsBase58 credNew
runShowPeerKey :: Maybe FilePath -> IO () runShowPeerKey :: forall s . ( s ~ HBS2Basic) => Maybe FilePath -> IO ()
runShowPeerKey fp = do runShowPeerKey fp = do
handle <- maybe (pure stdin) (`openFile` ReadMode) fp handle <- maybe (pure stdin) (`openFile` ReadMode) fp
bs <- LBS.hGet handle 4096 <&> LBS.toStrict bs <- LBS.hGet handle 4096 <&> LBS.toStrict
let cred' = parseCredentials @UDP (AsCredFile bs) let cred' = parseCredentials @s (AsCredFile bs)
maybe1 cred' exitFailure $ \cred -> do maybe1 cred' exitFailure $ \cred -> do
print $ pretty $ AsBase58 (view peerSignPk cred) print $ pretty $ AsBase58 (view peerSignPk cred)
-- FIXME: hardcoded-encryption-schema
runGenACB :: Maybe FilePath -> Maybe FilePath -> IO () runGenACB :: Maybe FilePath -> Maybe FilePath -> IO ()
runGenACB inFile outFile = do runGenACB inFile outFile = do
inf <- maybe (pure stdin) (`openFile` ReadMode) inFile inf <- maybe (pure stdin) (`openFile` ReadMode) inFile
s <- hGetContents inf 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 let bin = serialise acb
out <- maybe (pure stdout) (`openFile` WriteMode) outFile out <- maybe (pure stdout) (`openFile` WriteMode) outFile
LBS.hPutStr out bin LBS.hPutStr out bin
hClose out hClose out
hClose inf hClose inf
runDumpACB :: Maybe FilePath -> IO () runDumpACB :: Maybe FilePath -> IO ()
runDumpACB inFile = do runDumpACB inFile = do
inf <- maybe (pure stdin) (`openFile` ReadMode) inFile 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)) 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 runNewLRef nf uf refName ss = do
hPrint stderr $ "adding a new channel ref" <+> pretty nf <+> pretty uf 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" `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" `orDie` "bad ref owner keyring file"
-- FIXME: extract reusable functions -- 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" `orDie` "can not create node refs genesis"
-- полученный хэш будет хэшем ссылки на созданный канал владельца c ownerCred -- полученный хэш будет хэшем ссылки на созданный канал владельца 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" `orDie` "can not put channel genesis block"
modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList modifyNodeLinearRefList ss nodeCred lrh $ Set.toList . Set.insert chh . Set.fromList
print $ "channel ref:" <+> pretty chh print $ "channel ref:" <+> pretty chh
modifyNodeLinearRefList :: (Signatures e, Serialise (Signature e)) modifyNodeLinearRefList :: forall s . (ForHBS2Basic s)
=> SimpleStorage HbSync -> PeerCredentials e -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO () => SimpleStorage HbSync -> PeerCredentials s -> Hash HbSync -> ([Hash HbSync] -> [Hash HbSync]) -> IO ()
modifyNodeLinearRefList ss kr chh f = modifyNodeLinearRefList ss kr chh f =
modifyLinearRef ss kr chh \mh -> do modifyLinearRef ss kr chh \mh -> do
v <- case mh of v <- case mh of
@ -384,16 +386,16 @@ modifyNodeLinearRefList ss kr chh f =
(putBlock ss . serialise) (f v) (putBlock ss . serialise) (f v)
`orDie` "can not put new node channel list block" `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 runListLRef nf ss = do
hPrint stderr $ "listing node channels" <+> pretty nf 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" `orDie` "bad node keyring file"
hs :: [Hash HbSync] <- readNodeLinearRefList ss (_peerSignPk nodeCred) hs :: [Hash HbSync] <- readNodeLinearRefList ss (_peerSignPk nodeCred)
forM_ hs \chh -> do forM_ hs \chh -> do
putStrLn "" putStrLn ""
print $ pretty chh print $ pretty chh
mg <- (mdeserialiseMay @(RefGenesis [Hash HbSync]) <$> getBlock ss chh) mg <- (mdeserialiseMay @(RefGenesis s) <$> getBlock ss chh)
forM_ mg \g -> do forM_ mg \g -> do
print $ "owner:" <+> viaShow (refOwner g) print $ "owner:" <+> viaShow (refOwner g)
print $ "title:" <+> viaShow (refName g) print $ "title:" <+> viaShow (refName g)
@ -403,33 +405,33 @@ runListLRef nf ss = do
print $ "empty" print $ "empty"
Just refvalraw -> do Just refvalraw -> do
LinearMutableRefSigned _ ref LinearMutableRefSigned _ ref
<- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw) <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw)
`orDie` "can not parse linear ref" `orDie` "can not parse linear ref"
print $ "height: " <+> viaShow (lrefHeight ref) print $ "height: " <+> viaShow (lrefHeight ref)
print $ "val: " <+> pretty (lrefVal ref) print $ "val: " <+> pretty (lrefVal ref)
readNodeLinearRefList :: forall e. (e ~ UDP) readNodeLinearRefList :: forall s . (ForHBS2Basic s)
=> SimpleStorage HbSync -> PubKey 'Sign e -> IO [Hash HbSync] => SimpleStorage HbSync -> PubKey 'Sign s -> IO [Hash HbSync]
readNodeLinearRefList ss pk = do readNodeLinearRefList ss pk = do
-- полученный хэш будет хэшем ссылки на список референсов ноды -- полученный хэш будет хэшем ссылки на список референсов ноды
lrh :: Hash HbSync <- pure do lrh :: Hash HbSync <- pure do
(hashObject . serialise) (nodeLinearRefsRef @e pk) (hashObject . serialise) (nodeLinearRefsRef @s pk)
simpleReadLinkVal ss lrh >>= \case simpleReadLinkVal ss lrh >>= \case
Nothing -> pure [] Nothing -> pure []
Just refvalraw -> do Just refvalraw -> do
LinearMutableRefSigned _ ref LinearMutableRefSigned _ ref
<- pure (deserialiseMay @(Signed SignaturePresent (MutableRef e 'LinearRef)) refvalraw) <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw)
`orDie` "can not parse channel ref" `orDie` "can not parse channel ref"
fromMaybe mempty . mdeserialiseMay <$> getBlock ss (lrefVal ref) fromMaybe mempty . mdeserialiseMay <$> getBlock ss (lrefVal ref)
modifyLinearRef :: forall e. (Signatures e, Serialise (Signature e)) modifyLinearRef :: forall s. ( ForHBS2Basic s )
=> SimpleStorage HbSync => SimpleStorage HbSync
-> PeerCredentials e -- owner keyring -> PeerCredentials s -- owner keyring
-> Hash HbSync -- channel id -> Hash HbSync -- channel id
-> (Maybe (Hash HbSync) -> IO (Hash HbSync)) -> (Maybe (Hash HbSync) -> IO (Hash HbSync))
-> IO () -> IO ()
modifyLinearRef ss kr chh modIO = do 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" `orDie` "can not read channel ref genesis"
when (refOwner g /= _peerSignPk kr) do when (refOwner g /= _peerSignPk kr) do
(pure Nothing) `orDie` "channel ref owner does not match genesis owner" (pure Nothing) `orDie` "channel ref owner does not match genesis owner"
@ -444,7 +446,7 @@ modifyLinearRef ss kr chh modIO = do
} }
Just refvalraw -> do Just refvalraw -> do
-- assert lrefId == h -- assert lrefId == h
LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef e 'LinearRef) LinearMutableRefSigned _ ref :: Signed SignaturePresent (MutableRef s 'LinearRef)
<- pure (deserialiseMay refvalraw) <- pure (deserialiseMay refvalraw)
`orDie` "can not parse channel ref" `orDie` "can not parse channel ref"
val <- modIO (Just (lrefVal ref)) val <- modIO (Just (lrefVal ref))
@ -454,25 +456,31 @@ modifyLinearRef ss kr chh modIO = do
, lrefVal = val , lrefVal = val
} }
(simpleWriteLinkRaw ss chh . serialise) (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" `orDie` "can not write link"
pure () pure ()
runGetLRef :: Hash HbSync -> SimpleStorage HbSync -> IO () runGetLRef :: forall s . ForHBS2Basic s => Hash HbSync -> SimpleStorage HbSync -> IO ()
runGetLRef refh ss = do runGetLRef refh ss = do
hPrint stderr $ "getting ref value" <+> pretty refh hPrint stderr $ "getting ref value" <+> pretty refh
refvalraw <- simpleReadLinkVal ss refh refvalraw <- simpleReadLinkVal ss refh
`orDie` "error reading ref val" `orDie` "error reading ref val"
LinearMutableRefSigned _ ref LinearMutableRefSigned _ ref
<- pure (deserialiseMay @(Signed SignaturePresent (MutableRef UDP 'LinearRef)) refvalraw) <- pure (deserialiseMay @(Signed SignaturePresent (MutableRef s 'LinearRef)) refvalraw)
`orDie` "can not parse channel ref" `orDie` "can not parse channel ref"
hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref) hPrint stderr $ "channel ref height: " <+> viaShow (lrefHeight ref)
print $ pretty (lrefVal 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 runUpdateLRef uf refh valh ss = do
hPrint stderr $ "updating channel" <+> pretty refh <+> "with value" <+> pretty valh 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" `orDie` "bad ref owner keyring file"
modifyLinearRef ss ownerCred refh \_ -> pure valh modifyLinearRef ss ownerCred refh \_ -> pure valh
@ -490,7 +498,7 @@ runEnc58 = do
s <- LBS.hGetContents stdin <&> LBS.toStrict s <- LBS.hGetContents stdin <&> LBS.toStrict
print $ pretty (AsBase58 s) print $ pretty (AsBase58 s)
runRefLogGet :: RefLogKey e -> SimpleStorage HbSync -> IO () runRefLogGet :: forall s . IsRefPubKey s => RefLogKey s -> SimpleStorage HbSync -> IO ()
runRefLogGet s ss = do runRefLogGet s ss = do
ref' <- getRef ss s ref' <- getRef ss s
maybe1 ref' exitFailure $ \ref -> do maybe1 ref' exitFailure $ \ref -> do
@ -647,10 +655,11 @@ main = join . customExecParser (prefs showHelpOnError) $
pReflog = hsubparser ( command "get" (info pRefLogGet (progDesc "get reflog root") ) ) pReflog = hsubparser ( command "get" (info pRefLogGet (progDesc "get reflog root") ) )
-- FIXME: only-for-hbs2-basic-encryption
pRefLogGet = do pRefLogGet = do
o <- common o <- common
reflogs <- strArgument ( metavar "REFLOG" ) reflogs <- strArgument ( metavar "REFLOG" )
pure $ withStore o (runRefLogGet reflogs) pure $ withStore o (runRefLogGet @HBS2Basic reflogs)
pFsck = do pFsck = do
o <- common o <- common