mirror of https://github.com/voidlizard/hbs2
basic-keyring-maagement
This commit is contained in:
Dmitry Zuikov
parent
887ff91b80
commit
830bcf30a6
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
53
hbs2/Main.hs
53
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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue