module Galley.Keys
( MLSPrivateKeyPaths,
loadAllMLSKeys,
)
where
import Control.Error.Util
import Control.Exception
import Crypto.ECC hiding (KeyPair)
import Crypto.Error
import Crypto.PubKey.ECDSA qualified as ECDSA
import Crypto.PubKey.Ed25519 qualified as Ed25519
import Data.ASN1.BinaryEncoding
import Data.ASN1.BitArray
import Data.ASN1.Encoding
import Data.ASN1.Types
import Data.Bifunctor
import Data.ByteString.Lazy qualified as LBS
import Data.PEM
import Data.Proxy
import Data.X509
import Imports
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Keys
type MLSPrivateKeyPaths = MLSKeysByPurpose (MLSKeys FilePath)
data MLSPrivateKeyException = MLSPrivateKeyException
{ MLSPrivateKeyException -> String
mpkePath :: FilePath,
MLSPrivateKeyException -> String
mpkeMsg :: String
}
deriving (MLSPrivateKeyException -> MLSPrivateKeyException -> Bool
(MLSPrivateKeyException -> MLSPrivateKeyException -> Bool)
-> (MLSPrivateKeyException -> MLSPrivateKeyException -> Bool)
-> Eq MLSPrivateKeyException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MLSPrivateKeyException -> MLSPrivateKeyException -> Bool
== :: MLSPrivateKeyException -> MLSPrivateKeyException -> Bool
$c/= :: MLSPrivateKeyException -> MLSPrivateKeyException -> Bool
/= :: MLSPrivateKeyException -> MLSPrivateKeyException -> Bool
Eq, Int -> MLSPrivateKeyException -> ShowS
[MLSPrivateKeyException] -> ShowS
MLSPrivateKeyException -> String
(Int -> MLSPrivateKeyException -> ShowS)
-> (MLSPrivateKeyException -> String)
-> ([MLSPrivateKeyException] -> ShowS)
-> Show MLSPrivateKeyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MLSPrivateKeyException -> ShowS
showsPrec :: Int -> MLSPrivateKeyException -> ShowS
$cshow :: MLSPrivateKeyException -> String
show :: MLSPrivateKeyException -> String
$cshowList :: [MLSPrivateKeyException] -> ShowS
showList :: [MLSPrivateKeyException] -> ShowS
Show, Typeable)
instance Exception MLSPrivateKeyException where
displayException :: MLSPrivateKeyException -> String
displayException MLSPrivateKeyException
e = MLSPrivateKeyException -> String
mpkePath MLSPrivateKeyException
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> MLSPrivateKeyException -> String
mpkeMsg MLSPrivateKeyException
e
loadAllMLSKeys :: MLSPrivateKeyPaths -> IO (MLSKeysByPurpose MLSPrivateKeys)
loadAllMLSKeys :: MLSPrivateKeyPaths -> IO (MLSKeysByPurpose MLSPrivateKeys)
loadAllMLSKeys = (MLSKeys String -> IO MLSPrivateKeys)
-> MLSPrivateKeyPaths -> IO (MLSKeysByPurpose MLSPrivateKeys)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MLSKeysByPurpose a -> f (MLSKeysByPurpose b)
traverse MLSKeys String -> IO MLSPrivateKeys
loadMLSKeys
loadMLSKeys :: MLSKeys FilePath -> IO MLSPrivateKeys
loadMLSKeys :: MLSKeys String -> IO MLSPrivateKeys
loadMLSKeys MLSKeys String
paths =
(SecretKey, PublicKey)
-> (Scalar, Point)
-> (Scalar SEC_p384r1, Point SEC_p384r1)
-> (Scalar SEC_p521r1, Point SEC_p521r1)
-> MLSPrivateKeys
KeyPair 'Ed25519
-> KeyPair 'Ecdsa_secp256r1_sha256
-> KeyPair 'Ecdsa_secp384r1_sha384
-> KeyPair 'Ecdsa_secp521r1_sha512
-> MLSPrivateKeys
MLSPrivateKeys
((SecretKey, PublicKey)
-> (Scalar, Point)
-> (Scalar SEC_p384r1, Point SEC_p384r1)
-> (Scalar SEC_p521r1, Point SEC_p521r1)
-> MLSPrivateKeys)
-> IO (SecretKey, PublicKey)
-> IO
((Scalar, Point)
-> (Scalar SEC_p384r1, Point SEC_p384r1)
-> (Scalar SEC_p521r1, Point SEC_p521r1)
-> MLSPrivateKeys)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ss :: SignatureSchemeTag).
LoadKeyPair ss =>
String -> IO (KeyPair ss)
loadKeyPair @Ed25519 MLSKeys String
paths.ed25519
IO
((Scalar, Point)
-> (Scalar SEC_p384r1, Point SEC_p384r1)
-> (Scalar SEC_p521r1, Point SEC_p521r1)
-> MLSPrivateKeys)
-> IO (Scalar, Point)
-> IO
((Scalar SEC_p384r1, Point SEC_p384r1)
-> (Scalar SEC_p521r1, Point SEC_p521r1) -> MLSPrivateKeys)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ss :: SignatureSchemeTag).
LoadKeyPair ss =>
String -> IO (KeyPair ss)
loadKeyPair @Ecdsa_secp256r1_sha256 MLSKeys String
paths.ecdsa_secp256r1_sha256
IO
((Scalar SEC_p384r1, Point SEC_p384r1)
-> (Scalar SEC_p521r1, Point SEC_p521r1) -> MLSPrivateKeys)
-> IO (Scalar SEC_p384r1, Point SEC_p384r1)
-> IO ((Scalar SEC_p521r1, Point SEC_p521r1) -> MLSPrivateKeys)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ss :: SignatureSchemeTag).
LoadKeyPair ss =>
String -> IO (KeyPair ss)
loadKeyPair @Ecdsa_secp384r1_sha384 MLSKeys String
paths.ecdsa_secp384r1_sha384
IO ((Scalar SEC_p521r1, Point SEC_p521r1) -> MLSPrivateKeys)
-> IO (Scalar SEC_p521r1, Point SEC_p521r1) -> IO MLSPrivateKeys
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (ss :: SignatureSchemeTag).
LoadKeyPair ss =>
String -> IO (KeyPair ss)
loadKeyPair @Ecdsa_secp521r1_sha512 MLSKeys String
paths.ecdsa_secp521r1_sha512
class LoadKeyPair (ss :: SignatureSchemeTag) where
loadKeyPair :: FilePath -> IO (KeyPair ss)
instance LoadKeyPair Ed25519 where
loadKeyPair :: String -> IO (KeyPair 'Ed25519)
loadKeyPair = String -> IO (SecretKey, PublicKey)
String -> IO (KeyPair 'Ed25519)
loadEd25519KeyPair
instance LoadKeyPair Ecdsa_secp256r1_sha256 where
loadKeyPair :: String -> IO (KeyPair 'Ecdsa_secp256r1_sha256)
loadKeyPair = forall c.
(EllipticCurveECDSA c, CurveOID c) =>
String -> IO (PrivateKey c, PublicKey c)
loadECDSAKeyPair @Curve_P256R1
instance LoadKeyPair Ecdsa_secp384r1_sha384 where
loadKeyPair :: String -> IO (KeyPair 'Ecdsa_secp384r1_sha384)
loadKeyPair = forall c.
(EllipticCurveECDSA c, CurveOID c) =>
String -> IO (PrivateKey c, PublicKey c)
loadECDSAKeyPair @Curve_P384R1
instance LoadKeyPair Ecdsa_secp521r1_sha512 where
loadKeyPair :: String -> IO (KeyPair 'Ecdsa_secp521r1_sha512)
loadKeyPair = forall c.
(EllipticCurveECDSA c, CurveOID c) =>
String -> IO (PrivateKey c, PublicKey c)
loadECDSAKeyPair @Curve_P521R1
class CurveOID c where
curveOID :: [Integer]
instance CurveOID Curve_P256R1 where
curveOID :: [Integer]
curveOID = [Integer
1, Integer
2, Integer
840, Integer
10045, Integer
3, Integer
1, Integer
7]
instance CurveOID Curve_P384R1 where
curveOID :: [Integer]
curveOID = [Integer
1, Integer
3, Integer
132, Integer
0, Integer
34]
instance CurveOID Curve_P521R1 where
curveOID :: [Integer]
curveOID = [Integer
1, Integer
3, Integer
132, Integer
0, Integer
35]
loadECDSAKeyPair ::
forall c.
(ECDSA.EllipticCurveECDSA c, CurveOID c) =>
FilePath ->
IO (ECDSA.PrivateKey c, ECDSA.PublicKey c)
loadECDSAKeyPair :: forall c.
(EllipticCurveECDSA c, CurveOID c) =>
String -> IO (PrivateKey c, PublicKey c)
loadECDSAKeyPair String
path = do
ByteString
bytes <- String -> IO ByteString
LBS.readFile String
path
(String -> IO (PrivateKey c, PublicKey c))
-> ((PrivateKey c, PublicKey c) -> IO (PrivateKey c, PublicKey c))
-> Either String (PrivateKey c, PublicKey c)
-> IO (PrivateKey c, PublicKey c)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MLSPrivateKeyException -> IO (PrivateKey c, PublicKey c)
forall e a. Exception e => e -> IO a
throwIO (MLSPrivateKeyException -> IO (PrivateKey c, PublicKey c))
-> (String -> MLSPrivateKeyException)
-> String
-> IO (PrivateKey c, PublicKey c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> MLSPrivateKeyException
MLSPrivateKeyException String
path) (PrivateKey c, PublicKey c) -> IO (PrivateKey c, PublicKey c)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (PrivateKey c, PublicKey c)
-> IO (PrivateKey c, PublicKey c))
-> Either String (PrivateKey c, PublicKey c)
-> IO (PrivateKey c, PublicKey c)
forall a b. (a -> b) -> a -> b
$
forall c.
(EllipticCurveECDSA c, CurveOID c) =>
ByteString -> Either String (PrivateKey c, PublicKey c)
decodeEcdsaKeyPair @c ByteString
bytes
loadEd25519KeyPair :: FilePath -> IO (Ed25519.SecretKey, Ed25519.PublicKey)
loadEd25519KeyPair :: String -> IO (SecretKey, PublicKey)
loadEd25519KeyPair String
path = do
ByteString
bytes <- String -> IO ByteString
LBS.readFile String
path
SecretKey
priv <-
(String -> IO SecretKey)
-> (SecretKey -> IO SecretKey)
-> Either String SecretKey
-> IO SecretKey
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (MLSPrivateKeyException -> IO SecretKey
forall e a. Exception e => e -> IO a
throwIO (MLSPrivateKeyException -> IO SecretKey)
-> (String -> MLSPrivateKeyException) -> String -> IO SecretKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> MLSPrivateKeyException
MLSPrivateKeyException String
path) SecretKey -> IO SecretKey
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SecretKey -> IO SecretKey)
-> Either String SecretKey -> IO SecretKey
forall a b. (a -> b) -> a -> b
$
ByteString -> Either String SecretKey
decodeEd25519PrivateKey ByteString
bytes
(SecretKey, PublicKey) -> IO (SecretKey, PublicKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SecretKey
priv, SecretKey -> PublicKey
Ed25519.toPublic SecretKey
priv)
decodeEcdsaKeyPair ::
forall c.
(ECDSA.EllipticCurveECDSA c, CurveOID c) =>
LByteString ->
Either String (ECDSA.PrivateKey c, ECDSA.PublicKey c)
decodeEcdsaKeyPair :: forall c.
(EllipticCurveECDSA c, CurveOID c) =>
ByteString -> Either String (PrivateKey c, PublicKey c)
decodeEcdsaKeyPair ByteString
bytes = do
let curve :: Proxy c
curve = forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @c
[PEM]
pems <- ByteString -> Either String [PEM]
pemParseLBS ByteString
bytes
PEM
pem <- String -> [PEM] -> Either String PEM
forall a. String -> [a] -> Either String a
expectOne String
"private key" [PEM]
pems
let content :: ByteString
content = PEM -> ByteString
pemContent PEM
pem
[ASN1]
asn1 <- (ASN1Error -> String)
-> Either ASN1Error [ASN1] -> Either String [ASN1]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ASN1Error -> String
forall e. Exception e => e -> String
displayException (BER -> ByteString -> Either ASN1Error [ASN1]
forall a.
ASN1Decoding a =>
a -> ByteString -> Either ASN1Error [ASN1]
decodeASN1' BER
BER ByteString
content)
([Integer]
oid, ByteString
key) <- case [ASN1]
asn1 of
[ Start ASN1ConstructionType
Sequence,
IntVal Integer
_version,
Start ASN1ConstructionType
Sequence,
OID [Integer
1, Integer
2, Integer
840, Integer
10045, Integer
2, Integer
1],
OID [Integer]
oid,
End ASN1ConstructionType
Sequence,
OctetString ByteString
key,
End ASN1ConstructionType
Sequence
] -> ([Integer], ByteString) -> Either String ([Integer], ByteString)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Integer]
oid, ByteString
key)
[ASN1]
_ -> String -> Either String ([Integer], ByteString)
forall a b. a -> Either a b
Left String
"invalid ECDSA key format: expected pkcs8"
String -> Maybe () -> Either String ()
forall a b. a -> Maybe b -> Either a b
note
( String
"private key curve mismatch, expected "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Integer] -> String
forall a. Show a => a -> String
show (forall c. CurveOID c => [Integer]
forall {k} (c :: k). CurveOID c => [Integer]
curveOID @c)
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", found "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Integer] -> String
forall a. Show a => a -> String
show [Integer]
oid
)
(Maybe () -> Either String ()) -> Maybe () -> Either String ()
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Integer]
oid [Integer] -> [Integer] -> Bool
forall a. Eq a => a -> a -> Bool
== forall c. CurveOID c => [Integer]
forall {k} (c :: k). CurveOID c => [Integer]
curveOID @c)
[ASN1]
asn1' <- (ASN1Error -> String)
-> Either ASN1Error [ASN1] -> Either String [ASN1]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ASN1Error -> String
forall e. Exception e => e -> String
displayException (BER -> ByteString -> Either ASN1Error [ASN1]
forall a.
ASN1Decoding a =>
a -> ByteString -> Either ASN1Error [ASN1]
decodeASN1' BER
BER ByteString
key)
(ByteString
privBS, ByteString
pubBS) <- case [ASN1]
asn1' of
[ Start ASN1ConstructionType
Sequence,
IntVal Integer
_version,
OctetString ByteString
priv,
Start (Container ASN1Class
Context Int
_),
BitString (BitArray Word64
_ ByteString
pub),
End (Container ASN1Class
Context Int
_),
End ASN1ConstructionType
Sequence
] -> (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
priv, ByteString
pub)
[ASN1]
_ -> String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left String
"invalid ECDSA key format: expected rfc5915 private key format"
PrivateKey c
priv <-
(CryptoError -> String)
-> Either CryptoError (PrivateKey c)
-> Either String (PrivateKey c)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> String
forall e. Exception e => e -> String
displayException (Either CryptoError (PrivateKey c) -> Either String (PrivateKey c))
-> (CryptoFailable (PrivateKey c)
-> Either CryptoError (PrivateKey c))
-> CryptoFailable (PrivateKey c)
-> Either String (PrivateKey c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable (PrivateKey c) -> Either CryptoError (PrivateKey c)
forall a. CryptoFailable a -> Either CryptoError a
eitherCryptoError (CryptoFailable (PrivateKey c) -> Either String (PrivateKey c))
-> CryptoFailable (PrivateKey c) -> Either String (PrivateKey c)
forall a b. (a -> b) -> a -> b
$
Proxy c -> ByteString -> CryptoFailable (PrivateKey c)
forall curve bs (proxy :: * -> *).
(EllipticCurveECDSA curve, ByteArray bs) =>
proxy curve -> bs -> CryptoFailable (PrivateKey curve)
ECDSA.decodePrivate Proxy c
curve ByteString
privBS
PublicKey c
pub <-
(CryptoError -> String)
-> Either CryptoError (PublicKey c) -> Either String (PublicKey c)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CryptoError -> String
forall e. Exception e => e -> String
displayException (Either CryptoError (PublicKey c) -> Either String (PublicKey c))
-> (CryptoFailable (PublicKey c)
-> Either CryptoError (PublicKey c))
-> CryptoFailable (PublicKey c)
-> Either String (PublicKey c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoFailable (PublicKey c) -> Either CryptoError (PublicKey c)
forall a. CryptoFailable a -> Either CryptoError a
eitherCryptoError (CryptoFailable (PublicKey c) -> Either String (PublicKey c))
-> CryptoFailable (PublicKey c) -> Either String (PublicKey c)
forall a b. (a -> b) -> a -> b
$
Proxy c -> ByteString -> CryptoFailable (PublicKey c)
forall curve bs (proxy :: * -> *).
(EllipticCurve curve, ByteArray bs) =>
proxy curve -> bs -> CryptoFailable (PublicKey curve)
ECDSA.decodePublic Proxy c
curve ByteString
pubBS
(PrivateKey c, PublicKey c)
-> Either String (PrivateKey c, PublicKey c)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey c
priv, PublicKey c
pub)
decodeEd25519PrivateKey ::
LByteString ->
Either String Ed25519.SecretKey
decodeEd25519PrivateKey :: ByteString -> Either String SecretKey
decodeEd25519PrivateKey ByteString
bytes = do
[PEM]
pems <- ByteString -> Either String [PEM]
pemParseLBS ByteString
bytes
PEM
pem <- String -> [PEM] -> Either String PEM
forall a. String -> [a] -> Either String a
expectOne String
"private key" [PEM]
pems
let content :: ByteString
content = PEM -> ByteString
pemContent PEM
pem
[ASN1]
asn1 <- (ASN1Error -> String)
-> Either ASN1Error [ASN1] -> Either String [ASN1]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ASN1Error -> String
forall e. Exception e => e -> String
displayException (BER -> ByteString -> Either ASN1Error [ASN1]
forall a.
ASN1Decoding a =>
a -> ByteString -> Either ASN1Error [ASN1]
decodeASN1' BER
BER ByteString
content)
(PrivKey
priv, [ASN1]
remainder) <- [ASN1] -> Either String (PrivKey, [ASN1])
forall a. ASN1Object a => [ASN1] -> Either String (a, [ASN1])
fromASN1 [ASN1]
asn1
[ASN1] -> Either String ()
forall a. [a] -> Either String ()
expectEmpty [ASN1]
remainder
case PrivKey
priv of
PrivKeyEd25519 SecretKey
sec -> SecretKey -> Either String SecretKey
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SecretKey
sec
PrivKey
_ -> String -> Either String SecretKey
forall a b. a -> Either a b
Left (String -> Either String SecretKey)
-> String -> Either String SecretKey
forall a b. (a -> b) -> a -> b
$ String
"invalid signature scheme (expected ed25519)"
where
expectEmpty :: [a] -> Either String ()
expectEmpty :: forall a. [a] -> Either String ()
expectEmpty [] = () -> Either String ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
expectEmpty [a]
_ = String -> Either String ()
forall a b. a -> Either a b
Left String
"extraneous ASN.1 data"
expectOne :: String -> [a] -> Either String a
expectOne :: forall a. String -> [a] -> Either String a
expectOne String
label [] = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"no " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
label String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" found"
expectOne String
_ [a
x] = a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
expectOne String
label [a]
_ = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"found multiple " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
label String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"s"