mirror of https://github.com/voidlizard/hbs2
merged refactor-crypto-remove-l4-protocol-dependency
This commit is contained in:
Dmitry Zuikov
parent
261641f719
commit
1c8f6b978b
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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|]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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}|]
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
103
hbs2/Main.hs
103
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue