basic-keyring-maagement

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
+    fromCbor s = deserialiseOrFail @(PeerCredentials e) s
-                   & either (const Nothing) fromPair
+                   & either (const Nothing) Just
-
-    fromPair (s1,s2) = PeerCredentials <$> Crypto.decode s1
-                                       <*> Crypto.decode s2
-                                       <*> pure mempty
 
     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)
+instance ( Serialise  (PeerCredentials e)
-         , IsEncoding (PubKey 'Sign 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
+     bs = LBS.toStrict $ serialise c
-     pk = Crypto.encode p
+
-     bs = serialise (sk,pk) & LBS.toStrict
 
 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)))
+
+

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

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

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
@@ -204,7 +229,10 @@ main = join . customExecParser (prefs showHelpOnError) $
                         <> 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 "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"))
                         )
 
@@ -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)