From 830bcf30a66dad181e628fdbc2be368c5444dd18 Mon Sep 17 00:00:00 2001 From: Dmitry Zuikov Date: Thu, 9 Feb 2023 09:27:52 +0300 Subject: [PATCH] basic-keyring-maagement --- hbs2-core/lib/HBS2/Net/Auth/Credentials.hs | 104 ++++++++++++++++++--- hbs2-core/lib/HBS2/Net/Proto/Definition.hs | 18 +++- hbs2-core/lib/HBS2/Net/Proto/Types.hs | 10 -- hbs2/Main.hs | 53 +++++++++-- 4 files changed, 152 insertions(+), 33 deletions(-) diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index aad07acd..08ec6b43 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -1,14 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language TemplateHaskell #-} {-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language ConstraintKinds #-} module HBS2.Net.Auth.Credentials where import HBS2.Prelude.Plated -import HBS2.Net.Proto.Types import HBS2.Base58 import Codec.Serialise 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 @@ -17,9 +20,25 @@ 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 + +data CryptoAction = Sign | Encrypt + +type family PubKey ( a :: CryptoAction) e :: Type +type family PrivKey ( a :: CryptoAction) e :: Type + +class Signatures e where + type family Signature e :: Type + makeSign :: PrivKey 'Sign e -> ByteString -> Signature e + verifySign :: PubKey 'Sign e -> Signature e -> ByteString -> Bool + + class HasCredentials e m where getCredentials :: m (PeerCredentials e) @@ -27,8 +46,12 @@ data KeyringEntry e = KeyringEntry { _krPk :: PubKey 'Encrypt e , _krSk :: PrivKey 'Encrypt e - , _krDesc :: Text + , _krDesc :: Maybe Text } + deriving stock (Generic) + +deriving stock instance (Eq (PubKey 'Encrypt e), Eq (PrivKey 'Encrypt e)) + => Eq (KeyringEntry e) data PeerCredentials e = PeerCredentials @@ -36,13 +59,26 @@ data PeerCredentials e = , _peerSignPk :: PubKey 'Sign e , _peerKeyring :: [KeyringEntry e] } + deriving Generic makeLenses 'KeyringEntry makeLenses 'PeerCredentials +type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e) + , Serialise (PubKey 'Sign e) + , Serialise (PubKey 'Encrypt e) + , Serialise (PrivKey 'Encrypt e) + ) + +instance SerialisedCredentials e => Serialise (KeyringEntry e) + +instance SerialisedCredentials e => Serialise (PeerCredentials e) 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 @@ -53,21 +89,48 @@ newCredentials = do pure $ PeerCredentials @e (secretKey pair) (publicKey pair) mempty +newKeypair :: forall e m . ( MonadIO m + , PrivKey 'Encrypt e ~ Encrypt.SecretKey + , PubKey 'Encrypt e ~ Encrypt.PublicKey + ) + => Maybe Text -> m (KeyringEntry e) +newKeypair txt = do + pair <- liftIO Encrypt.newKeypair + pure $ KeyringEntry @e (Encrypt.publicKey pair) (Encrypt.secretKey pair) txt + +addKeyPair :: forall e m . ( MonadIO m + , PrivKey 'Encrypt e ~ Encrypt.SecretKey + , PubKey 'Encrypt e ~ Encrypt.PublicKey + ) + => Maybe Text -> PeerCredentials e -> m (PeerCredentials e) + +addKeyPair txt cred = do + kp <- newKeypair @e txt + pure $ cred & over peerKeyring (List.nub . (<> [kp])) + +delKeyPair :: forall e m . ( MonadIO m + , PrivKey 'Encrypt e ~ Encrypt.SecretKey + , PubKey 'Encrypt e ~ Encrypt.PublicKey + ) + => AsBase58 String -> PeerCredentials e -> m (PeerCredentials e) +delKeyPair (AsBase58 pks) cred = do + let kring = view peerKeyring cred + let asStr e = show (pretty (AsBase58 ( Crypto.encode (e ^. krPk) ) ) ) + 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 ) => AsCredFile ByteString -> Maybe (PeerCredentials e) parseCredentials (AsCredFile bs) = maybe1 b58_1 Nothing fromCbor where - fromCbor s = deserialiseOrFail @(ByteString, ByteString) s - & either (const Nothing) fromPair - - fromPair (s1,s2) = PeerCredentials <$> Crypto.decode s1 - <*> Crypto.decode s2 - <*> pure mempty + fromCbor s = deserialiseOrFail @(PeerCredentials e) s + & either (const Nothing) Just b58_1 = B8.lines bs & dropWhile hdr & filter ( not . B8.null ) @@ -77,16 +140,14 @@ parseCredentials (AsCredFile bs) = maybe1 b58_1 Nothing fromCbor hdr s = B8.isPrefixOf "#" s || B8.null s -instance ( IsEncoding (PrivKey 'Sign e) - , IsEncoding (PubKey 'Sign e) +instance ( Serialise (PeerCredentials e) ) => Pretty (AsBase58 (PeerCredentials e)) where - pretty (AsBase58 (PeerCredentials s p _)) = pretty $ B8.unpack (toBase58 bs) + pretty (AsBase58 c@(PeerCredentials s p _)) = pretty $ B8.unpack (toBase58 bs) where - sk = Crypto.encode s - pk = Crypto.encode p - bs = serialise (sk,pk) & LBS.toStrict + bs = LBS.toStrict $ serialise c + instance Pretty (AsBase58 Sign.PublicKey) where pretty (AsBase58 pk) = pretty $ B8.unpack $ toBase58 (Crypto.encode pk) @@ -97,8 +158,21 @@ instance Pretty (AsBase58 a) => Pretty (AsCredFile (AsBase58 a)) where <> co where co = vcat $ fmap pretty - $ chunksOf 32 + $ chunksOf 60 $ show $ pretty pc +newtype ListKeyringKeys e = ListKeyringKeys (PeerCredentials e) + +instance ( IsEncoding (PubKey 'Sign e), Pretty (KeyringEntry e) ) + => Pretty (ListKeyringKeys e) where + pretty (ListKeyringKeys p) = + fill 10 "sign-key:" <+> pretty (AsBase58 (Crypto.encode (view peerSignPk p))) + <> line <> vcat (fmap pretty (view peerKeyring p)) + +instance IsEncoding (PubKey 'Encrypt e) + => Pretty (KeyringEntry e) where + pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke))) + + diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index aac1bf41..2462b1b6 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs @@ -6,8 +6,9 @@ module HBS2.Net.Proto.Definition ) where -import HBS2.Prelude import HBS2.Clock +import HBS2.Defaults +import HBS2.Net.Auth.Credentials import HBS2.Net.Messaging.UDP import HBS2.Net.Proto import HBS2.Net.Proto.BlockAnnounce @@ -16,7 +17,7 @@ import HBS2.Net.Proto.BlockInfo import HBS2.Net.Proto.Peer import HBS2.Net.Proto.PeerAnnounce import HBS2.Net.Proto.PeerExchange -import HBS2.Defaults +import HBS2.Prelude import Data.Functor import Data.ByteString.Lazy (ByteString) @@ -26,12 +27,25 @@ import Codec.Serialise (deserialiseOrFail,serialise,Serialise(..)) import Crypto.Saltine.Core.Box qualified as Crypto import Crypto.Saltine.Class qualified as Crypto 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 + +-- FIXME: proper-serialise-for-keys +-- Возможно, нужно написать ручные инстансы Serialise +-- использовать encode/decode для каждого инстанса ниже $(c:end + 4) +-- и это будет более правильная сериализация. +-- но возможно, будет работать и так, ведь ключи +-- это же всего лишь байтстроки внутри. instance Serialise Sign.PublicKey +instance Serialise Encrypt.PublicKey +instance Serialise Sign.SecretKey +instance Serialise Encrypt.SecretKey instance HasProtocol UDP (BlockInfo UDP) where type instance ProtocolId (BlockInfo UDP) = 1 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index e2af5fe1..1c7aaf8f 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -26,21 +26,11 @@ import Data.Text (Text) class Monad m => GenCookie e m where genCookie :: Hashable salt => salt -> m (Cookie e) -type family EncryptPubKey e :: Type class Monad m => HasNonces p m where type family Nonce p :: Type newNonce :: m (Nonce p) -data CryptoAction = Sign | Encrypt - -type family PubKey ( a :: CryptoAction) e :: Type -type family PrivKey ( a :: CryptoAction) e :: Type - -class Signatures e where - type family Signature e :: Type - makeSign :: PrivKey 'Sign e -> ByteString -> Signature e - verifySign :: PubKey 'Sign e -> Signature e -> ByteString -> Bool class HasCookie e p | p -> e where diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 11ac7759..38daee2f 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -12,6 +12,7 @@ import HBS2.Net.Proto.Types import HBS2.Prelude.Plated import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra +import HBS2.OrDie import Data.ByteString.Lazy (ByteString) @@ -165,6 +166,30 @@ runNewKey = do cred <- newCredentials @UDP print $ pretty $ AsCredFile $ AsBase58 cred +runListKeys :: FilePath -> IO () +runListKeys fp = do + s <- BS.readFile fp + cred <- pure (parseCredentials @UDP (AsCredFile s)) `orDie` "bad keyring file" + print $ pretty (ListKeyringKeys cred) + + +runKeyAdd :: 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" + credNew <- addKeyPair Nothing cred + print $ pretty $ AsCredFile $ AsBase58 credNew + +runKeyDel :: 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" + credNew <- delKeyPair (AsBase58 n) cred + print $ pretty $ AsCredFile $ AsBase58 credNew + + runShowPeerKey :: Maybe FilePath -> IO () runShowPeerKey fp = do handle <- maybe (pure stdin) (`openFile` ReadMode) fp @@ -200,12 +225,15 @@ main = join . customExecParser (prefs showHelpOnError) $ ) where parser :: Parser (IO ()) - parser = hsubparser ( command "store" (info pStore (progDesc "store block")) - <> command "new-ref" (info pNewRef (progDesc "creates reference")) - <> command "cat" (info pCat (progDesc "cat block")) - <> command "hash" (info pHash (progDesc "calculates hash")) - <> command "new-key" (info pNewKey (progDesc "generates a new keypair")) - <> command "show-peer-key" (info pShowPeerKey (progDesc "show peer key from credential file")) + parser = hsubparser ( command "store" (info pStore (progDesc "store block")) + <> command "new-ref" (info pNewRef (progDesc "creates reference")) + <> command "cat" (info pCat (progDesc "cat block")) + <> command "hash" (info pHash (progDesc "calculates hash")) + <> command "keyring-new" (info pNewKey (progDesc "generates a new keyring")) + <> command "keyring-list" (info pKeyList (progDesc "list public keys from keyring")) + <> command "keyring-key-add" (info pKeyAdd (progDesc "adds a new keypair into the keyring")) + <> command "keyring-key-del" (info pKeyDel (progDesc "removes a keypair from the keyring")) + <> command "show-peer-key" (info pShowPeerKey (progDesc "show peer key from credential file")) ) common = do @@ -242,4 +270,17 @@ main = join . customExecParser (prefs showHelpOnError) $ fp <- optional $ strArgument ( metavar "FILE" ) pure $ runShowPeerKey fp + pKeyList = do + f <- strArgument ( metavar "KEYRING-FILE" ) + pure (runListKeys f) + + pKeyAdd = do + f <- strArgument ( metavar "KEYRING-FILE" ) + pure (runKeyAdd f) + + + pKeyDel = do + s <- strArgument ( metavar "PUB-KEY-BAS58" ) + f <- strArgument ( metavar "KEYRING-FILE" ) + pure (runKeyDel s f)