{-# LANGUAGE CPP #-}
module Hackage.Security.Key (
    -- * Key types
    Ed25519
    -- * Types abstracting over key types
  , Key(..)
  , PublicKey(..)
  , PrivateKey(..)
    -- * Key types in isolation
  , KeyType(..)
    -- * Hiding key types
  , somePublicKey
  , somePublicKeyType
  , someKeyId
    -- * Operations on keys
  , publicKey
  , privateKey
  , createKey
  , createKey'
    -- * Key IDs
  , KeyId(..)
  , HasKeyId(..)
    -- * Signing
  , sign
  , verify
  ) where

import MyPrelude
import Control.Monad
import Data.Functor.Identity
import Data.Typeable (Typeable)
import Text.JSON.Canonical
import qualified Crypto.Hash.SHA256   as SHA256
import qualified Crypto.Sign.Ed25519  as Ed25519
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Char8 as BS.C8
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as BS.L

#if !MIN_VERSION_base(4,7,0)
import qualified Data.Typeable as Typeable
#endif

import Hackage.Security.Util.JSON
import Hackage.Security.Util.Some
import Hackage.Security.Util.TypedEmbedded
import qualified Hackage.Security.Util.Base64 as B64

{-------------------------------------------------------------------------------
  Generalization over key types
-------------------------------------------------------------------------------}

data Ed25519

data Key a where
    KeyEd25519 :: Ed25519.PublicKey -> Ed25519.SecretKey -> Key Ed25519
  deriving (Typeable)

data PublicKey a where
    PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519
  deriving (Typeable)

data PrivateKey a where
    PrivateKeyEd25519 :: Ed25519.SecretKey -> PrivateKey Ed25519
  deriving (Typeable)

deriving instance Show (Key        typ)
deriving instance Show (PublicKey  typ)
deriving instance Show (PrivateKey typ)

deriving instance Eq (Key        typ)
deriving instance Eq (PublicKey  typ)
deriving instance Eq (PrivateKey typ)

instance SomeShow Key        where someShow :: forall a. DictShow (Key a)
someShow = DictShow (Key a)
forall a. Show a => DictShow a
DictShow
instance SomeShow PublicKey  where someShow :: forall a. DictShow (PublicKey a)
someShow = DictShow (PublicKey a)
forall a. Show a => DictShow a
DictShow
instance SomeShow PrivateKey where someShow :: forall a. DictShow (PrivateKey a)
someShow = DictShow (PrivateKey a)
forall a. Show a => DictShow a
DictShow

instance SomeEq Key        where someEq :: forall a. DictEq (Key a)
someEq = DictEq (Key a)
forall a. Eq a => DictEq a
DictEq
instance SomeEq PublicKey  where someEq :: forall a. DictEq (PublicKey a)
someEq = DictEq (PublicKey a)
forall a. Eq a => DictEq a
DictEq
instance SomeEq PrivateKey where someEq :: forall a. DictEq (PrivateKey a)
someEq = DictEq (PrivateKey a)
forall a. Eq a => DictEq a
DictEq

publicKey :: Key a -> PublicKey a
publicKey :: forall a. Key a -> PublicKey a
publicKey (KeyEd25519 PublicKey
pub SecretKey
_pri) = PublicKey -> PublicKey Ed25519
PublicKeyEd25519 PublicKey
pub

privateKey :: Key a -> PrivateKey a
privateKey :: forall a. Key a -> PrivateKey a
privateKey (KeyEd25519 PublicKey
_pub SecretKey
pri) = SecretKey -> PrivateKey Ed25519
PrivateKeyEd25519 SecretKey
pri

{-------------------------------------------------------------------------------
  Sometimes it's useful to talk about the type of a key independent of the key
-------------------------------------------------------------------------------}

data KeyType typ where
  KeyTypeEd25519 :: KeyType Ed25519

deriving instance Show (KeyType typ)
deriving instance Eq   (KeyType typ)

instance SomeShow KeyType where someShow :: forall a. DictShow (KeyType a)
someShow = DictShow (KeyType a)
forall a. Show a => DictShow a
DictShow
instance SomeEq   KeyType where someEq :: forall a. DictEq (KeyType a)
someEq   = DictEq (KeyType a)
forall a. Eq a => DictEq a
DictEq

instance Unify KeyType where
  unify :: forall typ typ'.
KeyType typ -> KeyType typ' -> Maybe (typ :=: typ')
unify KeyType typ
KeyTypeEd25519 KeyType typ'
KeyTypeEd25519 = (typ :=: typ') -> Maybe (typ :=: typ')
forall a. a -> Maybe a
Just typ :=: typ
typ :=: typ'
forall a. a :=: a
Refl

type instance TypeOf Key        = KeyType
type instance TypeOf PublicKey  = KeyType
type instance TypeOf PrivateKey = KeyType

instance Typed Key where
  typeOf :: forall typ. Key typ -> TypeOf Key typ
typeOf (KeyEd25519 PublicKey
_ SecretKey
_) = TypeOf Key typ
KeyType Ed25519
KeyTypeEd25519

instance Typed PublicKey where
  typeOf :: forall typ. PublicKey typ -> TypeOf PublicKey typ
typeOf (PublicKeyEd25519 PublicKey
_) = TypeOf PublicKey typ
KeyType Ed25519
KeyTypeEd25519

instance Typed PrivateKey where
  typeOf :: forall typ. PrivateKey typ -> TypeOf PrivateKey typ
typeOf (PrivateKeyEd25519 SecretKey
_) = TypeOf PrivateKey typ
KeyType Ed25519
KeyTypeEd25519

{-------------------------------------------------------------------------------
  We don't always know the key type
-------------------------------------------------------------------------------}

somePublicKey :: Some Key -> Some PublicKey
somePublicKey :: Some Key -> Some PublicKey
somePublicKey (Some Key a
key) = PublicKey a -> Some PublicKey
forall (f :: * -> *) a. f a -> Some f
Some (Key a -> PublicKey a
forall a. Key a -> PublicKey a
publicKey Key a
key)

somePublicKeyType :: Some PublicKey -> Some KeyType
somePublicKeyType :: Some PublicKey -> Some KeyType
somePublicKeyType (Some PublicKey a
pub) = KeyType a -> Some KeyType
forall (f :: * -> *) a. f a -> Some f
Some (PublicKey a -> TypeOf PublicKey a
forall typ. PublicKey typ -> TypeOf PublicKey typ
forall (f :: * -> *) typ. Typed f => f typ -> TypeOf f typ
typeOf PublicKey a
pub)

someKeyId :: HasKeyId key => Some key -> KeyId
someKeyId :: forall (key :: * -> *). HasKeyId key => Some key -> KeyId
someKeyId (Some key a
a) = key a -> KeyId
forall typ. key typ -> KeyId
forall (key :: * -> *) typ. HasKeyId key => key typ -> KeyId
keyId key a
a

{-------------------------------------------------------------------------------
  Creating keys
-------------------------------------------------------------------------------}

createKey :: KeyType key -> IO (Key key)
createKey :: forall key. KeyType key -> IO (Key key)
createKey KeyType key
KeyTypeEd25519 = (PublicKey -> SecretKey -> Key key)
-> (PublicKey, SecretKey) -> Key key
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PublicKey -> SecretKey -> Key key
PublicKey -> SecretKey -> Key Ed25519
KeyEd25519 ((PublicKey, SecretKey) -> Key key)
-> IO (PublicKey, SecretKey) -> IO (Key key)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (PublicKey, SecretKey)
Ed25519.createKeypair

createKey' :: KeyType key -> IO (Some Key)
createKey' :: forall key. KeyType key -> IO (Some Key)
createKey' = (Key key -> Some Key) -> IO (Key key) -> IO (Some Key)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Key key -> Some Key
forall (f :: * -> *) a. f a -> Some f
Some (IO (Key key) -> IO (Some Key))
-> (KeyType key -> IO (Key key)) -> KeyType key -> IO (Some Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyType key -> IO (Key key)
forall key. KeyType key -> IO (Key key)
createKey

{-------------------------------------------------------------------------------
  Key IDs
-------------------------------------------------------------------------------}

-- | The key ID of a key, by definition, is the hexdigest of the SHA-256 hash of
-- the canonical JSON form of the key where the private object key is excluded.
--
-- NOTE: The FromJSON and ToJSON instances for KeyId are intentionally omitted.
-- Use writeKeyAsId instead.
newtype KeyId = KeyId { KeyId -> String
keyIdString :: String }
  deriving (Int -> KeyId -> ShowS
[KeyId] -> ShowS
KeyId -> String
(Int -> KeyId -> ShowS)
-> (KeyId -> String) -> ([KeyId] -> ShowS) -> Show KeyId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyId -> ShowS
showsPrec :: Int -> KeyId -> ShowS
$cshow :: KeyId -> String
show :: KeyId -> String
$cshowList :: [KeyId] -> ShowS
showList :: [KeyId] -> ShowS
Show, KeyId -> KeyId -> Bool
(KeyId -> KeyId -> Bool) -> (KeyId -> KeyId -> Bool) -> Eq KeyId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyId -> KeyId -> Bool
== :: KeyId -> KeyId -> Bool
$c/= :: KeyId -> KeyId -> Bool
/= :: KeyId -> KeyId -> Bool
Eq, Eq KeyId
Eq KeyId =>
(KeyId -> KeyId -> Ordering)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> KeyId)
-> (KeyId -> KeyId -> KeyId)
-> Ord KeyId
KeyId -> KeyId -> Bool
KeyId -> KeyId -> Ordering
KeyId -> KeyId -> KeyId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: KeyId -> KeyId -> Ordering
compare :: KeyId -> KeyId -> Ordering
$c< :: KeyId -> KeyId -> Bool
< :: KeyId -> KeyId -> Bool
$c<= :: KeyId -> KeyId -> Bool
<= :: KeyId -> KeyId -> Bool
$c> :: KeyId -> KeyId -> Bool
> :: KeyId -> KeyId -> Bool
$c>= :: KeyId -> KeyId -> Bool
>= :: KeyId -> KeyId -> Bool
$cmax :: KeyId -> KeyId -> KeyId
max :: KeyId -> KeyId -> KeyId
$cmin :: KeyId -> KeyId -> KeyId
min :: KeyId -> KeyId -> KeyId
Ord)

instance Monad m => ToObjectKey m KeyId where
  toObjectKey :: KeyId -> m String
toObjectKey = String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> (KeyId -> String) -> KeyId -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyId -> String
keyIdString

instance Monad m => FromObjectKey m KeyId where
  fromObjectKey :: String -> m (Maybe KeyId)
fromObjectKey = Maybe KeyId -> m (Maybe KeyId)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe KeyId -> m (Maybe KeyId))
-> (String -> Maybe KeyId) -> String -> m (Maybe KeyId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyId -> Maybe KeyId
forall a. a -> Maybe a
Just (KeyId -> Maybe KeyId)
-> (String -> KeyId) -> String -> Maybe KeyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> KeyId
KeyId

-- | Compute the key ID of a key
class HasKeyId key where
  keyId :: key typ -> KeyId

instance HasKeyId PublicKey where
  keyId :: forall typ. PublicKey typ -> KeyId
keyId = String -> KeyId
KeyId
        (String -> KeyId)
-> (PublicKey typ -> String) -> PublicKey typ -> KeyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.C8.unpack
        (ByteString -> String)
-> (PublicKey typ -> ByteString) -> PublicKey typ -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode
        (ByteString -> ByteString)
-> (PublicKey typ -> ByteString) -> PublicKey typ -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA256.hashlazy
        (ByteString -> ByteString)
-> (PublicKey typ -> ByteString) -> PublicKey typ -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ByteString
renderCanonicalJSON
        (JSValue -> ByteString)
-> (PublicKey typ -> JSValue) -> PublicKey typ -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity JSValue -> JSValue
forall a. Identity a -> a
runIdentity
        (Identity JSValue -> JSValue)
-> (PublicKey typ -> Identity JSValue) -> PublicKey typ -> JSValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey typ -> Identity JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON

instance HasKeyId Key where
  keyId :: forall typ. Key typ -> KeyId
keyId = PublicKey typ -> KeyId
forall typ. PublicKey typ -> KeyId
forall (key :: * -> *) typ. HasKeyId key => key typ -> KeyId
keyId (PublicKey typ -> KeyId)
-> (Key typ -> PublicKey typ) -> Key typ -> KeyId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key typ -> PublicKey typ
forall a. Key a -> PublicKey a
publicKey

{-------------------------------------------------------------------------------
  Signing
-------------------------------------------------------------------------------}

-- | Sign a bytestring and return the signature
--
-- TODO: It is unfortunate that we have to convert to a strict bytestring for
-- ed25519
sign :: PrivateKey typ -> BS.L.ByteString -> BS.ByteString
sign :: forall typ. PrivateKey typ -> ByteString -> ByteString
sign (PrivateKeyEd25519 SecretKey
pri) =
    Signature -> ByteString
Ed25519.unSignature (Signature -> ByteString)
-> (ByteString -> Signature) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretKey -> ByteString -> Signature
dsign SecretKey
pri (ByteString -> Signature)
-> (ByteString -> ByteString) -> ByteString -> Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.L.toChunks
  where
#if MIN_VERSION_ed25519(0,0,4)
    dsign :: SecretKey -> ByteString -> Signature
dsign = SecretKey -> ByteString -> Signature
Ed25519.dsign
#else
    dsign = Ed25519.sign'
#endif

verify :: PublicKey typ -> BS.L.ByteString -> BS.ByteString -> Bool
verify :: forall typ. PublicKey typ -> ByteString -> ByteString -> Bool
verify (PublicKeyEd25519 PublicKey
pub) ByteString
inp ByteString
sig =
    PublicKey -> ByteString -> Signature -> Bool
dverify PublicKey
pub ([ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BS.L.toChunks ByteString
inp) (ByteString -> Signature
Ed25519.Signature ByteString
sig)
  where
#if MIN_VERSION_ed25519(0,0,4)
    dverify :: PublicKey -> ByteString -> Signature -> Bool
dverify = PublicKey -> ByteString -> Signature -> Bool
Ed25519.dverify
#else
    dverify = Ed25519.verify'
#endif

{-------------------------------------------------------------------------------
  JSON encoding and decoding
-------------------------------------------------------------------------------}

instance Monad m => ToJSON m (Key typ) where
  toJSON :: Key typ -> m JSValue
toJSON Key typ
key = case Key typ
key of
      KeyEd25519 PublicKey
pub SecretKey
pri ->
        String -> ByteString -> ByteString -> m JSValue
enc String
"ed25519" (PublicKey -> ByteString
Ed25519.unPublicKey PublicKey
pub) (SecretKey -> ByteString
Ed25519.unSecretKey SecretKey
pri)
    where
      enc :: String -> BS.ByteString -> BS.ByteString -> m JSValue
      enc :: String -> ByteString -> ByteString -> m JSValue
enc String
tag ByteString
pub ByteString
pri = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
            (String
"keytype", JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue) -> JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
tag)
          , (String
"keyval", [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
                (String
"public",  Base64 -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (ByteString -> Base64
B64.fromByteString ByteString
pub))
              , (String
"private", Base64 -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (ByteString -> Base64
B64.fromByteString ByteString
pri))
              ])
          ]

instance ReportSchemaErrors m => FromJSON m (Some Key) where
  fromJSON :: JSValue -> m (Some Key)
fromJSON JSValue
enc = do
      (String
tag, ByteString
pub, ByteString
pri) <- JSValue -> m (String, ByteString, ByteString)
dec JSValue
enc
      case String
tag of
        String
"ed25519" -> Some Key -> m (Some Key)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Some Key -> m (Some Key))
-> (Key Ed25519 -> Some Key) -> Key Ed25519 -> m (Some Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key Ed25519 -> Some Key
forall (f :: * -> *) a. f a -> Some f
Some (Key Ed25519 -> m (Some Key)) -> Key Ed25519 -> m (Some Key)
forall a b. (a -> b) -> a -> b
$
          PublicKey -> SecretKey -> Key Ed25519
KeyEd25519 (ByteString -> PublicKey
Ed25519.PublicKey ByteString
pub) (ByteString -> SecretKey
Ed25519.SecretKey ByteString
pri)
        String
_otherwise ->
          String -> Maybe String -> m (Some Key)
forall a. String -> Maybe String -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid key type" (String -> Maybe String
forall a. a -> Maybe a
Just String
tag)
    where
      dec :: JSValue -> m (String, BS.ByteString, BS.ByteString)
      dec :: JSValue -> m (String, ByteString, ByteString)
dec JSValue
obj = do
        String
tag <- JSValue -> String -> m String
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keytype"
        JSValue
val <- JSValue -> String -> m JSValue
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keyval"
        Base64
pub <- JSValue -> String -> m Base64
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
val String
"public"
        Base64
pri <- JSValue -> String -> m Base64
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
val String
"private"
        (String, ByteString, ByteString)
-> m (String, ByteString, ByteString)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
tag, Base64 -> ByteString
B64.toByteString Base64
pub, Base64 -> ByteString
B64.toByteString Base64
pri)

instance Monad m => ToJSON m (PublicKey typ) where
  toJSON :: PublicKey typ -> m JSValue
toJSON PublicKey typ
key = case PublicKey typ
key of
      PublicKeyEd25519 PublicKey
pub ->
        String -> ByteString -> m JSValue
enc String
"ed25519" (PublicKey -> ByteString
Ed25519.unPublicKey PublicKey
pub)
    where
      enc :: String -> BS.ByteString -> m JSValue
      enc :: String -> ByteString -> m JSValue
enc String
tag ByteString
pub = [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
            (String
"keytype", JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue) -> JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
tag)
          , (String
"keyval", [(String, m JSValue)] -> m JSValue
forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
                (String
"public", Base64 -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (ByteString -> Base64
B64.fromByteString ByteString
pub))
              ])
          ]

instance Monad m => ToJSON m (Some Key)        where toJSON :: Some Key -> m JSValue
toJSON (Some Key a
a) = Key a -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON Key a
a
instance Monad m => ToJSON m (Some PublicKey)  where toJSON :: Some PublicKey -> m JSValue
toJSON (Some PublicKey a
a) = PublicKey a -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON PublicKey a
a
instance Monad m => ToJSON m (Some KeyType)    where toJSON :: Some KeyType -> m JSValue
toJSON (Some KeyType a
a) = KeyType a -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON KeyType a
a

instance ReportSchemaErrors m => FromJSON m (Some PublicKey) where
  fromJSON :: JSValue -> m (Some PublicKey)
fromJSON JSValue
enc = do
      (String
tag, ByteString
pub) <- JSValue -> m (String, ByteString)
dec JSValue
enc
      case String
tag of
        String
"ed25519" -> Some PublicKey -> m (Some PublicKey)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Some PublicKey -> m (Some PublicKey))
-> (PublicKey Ed25519 -> Some PublicKey)
-> PublicKey Ed25519
-> m (Some PublicKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey Ed25519 -> Some PublicKey
forall (f :: * -> *) a. f a -> Some f
Some (PublicKey Ed25519 -> m (Some PublicKey))
-> PublicKey Ed25519 -> m (Some PublicKey)
forall a b. (a -> b) -> a -> b
$
          PublicKey -> PublicKey Ed25519
PublicKeyEd25519 (ByteString -> PublicKey
Ed25519.PublicKey ByteString
pub)
        String
_otherwise ->
          String -> Maybe String -> m (Some PublicKey)
forall a. String -> Maybe String -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid key type" (String -> Maybe String
forall a. a -> Maybe a
Just String
tag)
    where
      dec :: JSValue -> m (String, BS.ByteString)
      dec :: JSValue -> m (String, ByteString)
dec JSValue
obj = do
        String
tag <- JSValue -> String -> m String
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keytype"
        JSValue
val <- JSValue -> String -> m JSValue
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keyval"
        Base64
pub <- JSValue -> String -> m Base64
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
val String
"public"
        (String, ByteString) -> m (String, ByteString)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
tag, Base64 -> ByteString
B64.toByteString Base64
pub)

instance Monad m => ToJSON m (KeyType typ) where
  toJSON :: KeyType typ -> m JSValue
toJSON KeyType typ
KeyTypeEd25519 = JSValue -> m JSValue
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JSValue -> m JSValue) -> JSValue -> m JSValue
forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
"ed25519"

instance ReportSchemaErrors m => FromJSON m (Some KeyType) where
  fromJSON :: JSValue -> m (Some KeyType)
fromJSON JSValue
enc = do
    String
tag <- JSValue -> m String
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case String
tag of
      String
"ed25519"  -> Some KeyType -> m (Some KeyType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Some KeyType -> m (Some KeyType))
-> (KeyType Ed25519 -> Some KeyType)
-> KeyType Ed25519
-> m (Some KeyType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyType Ed25519 -> Some KeyType
forall (f :: * -> *) a. f a -> Some f
Some (KeyType Ed25519 -> m (Some KeyType))
-> KeyType Ed25519 -> m (Some KeyType)
forall a b. (a -> b) -> a -> b
$ KeyType Ed25519
KeyTypeEd25519
      String
_otherwise -> String -> Maybe String -> m (Some KeyType)
forall a. String -> Maybe String -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid key type" (String -> Maybe String
forall a. a -> Maybe a
Just String
tag)

{-------------------------------------------------------------------------------
  Orphans

  Pre-7.8 (base 4.7) we cannot have Typeable instance for higher-kinded types.
  Instead, here we provide some instance for specific instantiations.
-------------------------------------------------------------------------------}

#if !MIN_VERSION_base(4,7,0)
tyConKey, tyConPublicKey, tyConPrivateKey :: Typeable.TyCon
tyConKey        = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "Key"
tyConPublicKey  = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PublicKey"
tyConPrivateKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PrivateKey"

instance Typeable (Some Key) where
  typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConKey []]

instance Typeable (Some PublicKey) where
  typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPublicKey []]

instance Typeable (Some PrivateKey) where
  typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPrivateKey []]
#endif