{-# 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 = forall a. Show a => DictShow a
DictShow
instance SomeShow PublicKey  where someShow :: forall a. DictShow (PublicKey a)
someShow = forall a. Show a => DictShow a
DictShow
instance SomeShow PrivateKey where someShow :: forall a. DictShow (PrivateKey a)
someShow = forall a. Show a => DictShow a
DictShow

instance SomeEq Key        where someEq :: forall a. DictEq (Key a)
someEq = forall a. Eq a => DictEq a
DictEq
instance SomeEq PublicKey  where someEq :: forall a. DictEq (PublicKey a)
someEq = forall a. Eq a => DictEq a
DictEq
instance SomeEq PrivateKey where someEq :: forall a. DictEq (PrivateKey a)
someEq = 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 = forall a. Show a => DictShow a
DictShow
instance SomeEq   KeyType where someEq :: forall a. DictEq (KeyType a)
someEq   = 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 = forall a. a -> Maybe a
Just 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
_) = KeyType Ed25519
KeyTypeEd25519

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

instance Typed PrivateKey where
  typeOf :: forall typ. PrivateKey typ -> TypeOf PrivateKey typ
typeOf (PrivateKeyEd25519 SecretKey
_) = 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) = forall (f :: * -> *) a. f a -> Some f
Some (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) = forall (f :: * -> *) a. f a -> Some f
Some (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) = 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 = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PublicKey -> SecretKey -> Key Ed25519
KeyEd25519 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' = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (f :: * -> *) a. f a -> Some f
Some forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyId] -> ShowS
$cshowList :: [KeyId] -> ShowS
show :: KeyId -> String
$cshow :: KeyId -> String
showsPrec :: Int -> KeyId -> ShowS
$cshowsPrec :: Int -> KeyId -> ShowS
Show, KeyId -> KeyId -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyId -> KeyId -> Bool
$c/= :: KeyId -> KeyId -> Bool
== :: KeyId -> KeyId -> Bool
$c== :: KeyId -> KeyId -> Bool
Eq, Eq 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
min :: KeyId -> KeyId -> KeyId
$cmin :: KeyId -> KeyId -> KeyId
max :: KeyId -> KeyId -> KeyId
$cmax :: KeyId -> KeyId -> KeyId
>= :: KeyId -> KeyId -> Bool
$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
compare :: KeyId -> KeyId -> Ordering
$ccompare :: KeyId -> KeyId -> Ordering
Ord)

instance Monad m => ToObjectKey m KeyId where
  toObjectKey :: KeyId -> m String
toObjectKey = forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just 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
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.C8.unpack
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA256.hashlazy
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSValue -> ByteString
renderCanonicalJSON
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON

instance HasKeyId Key where
  keyId :: forall typ. Key typ -> KeyId
keyId = forall (key :: * -> *) typ. HasKeyId key => key typ -> KeyId
keyId forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecretKey -> ByteString -> Signature
dsign SecretKey
pri forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
BS.concat 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 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 = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
            (String
"keytype", forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
tag)
          , (String
"keyval", forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
                (String
"public",  forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (ByteString -> Base64
B64.fromByteString ByteString
pub))
              , (String
"private", 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" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some 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 ->
          forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid key type" (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 <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keytype"
        JSValue
val <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keyval"
        Base64
pub <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
val String
"public"
        Base64
pri <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
val String
"private"
        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 = forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
            (String
"keytype", forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> JSValue
JSString String
tag)
          , (String
"keyval", forall (m :: * -> *). Monad m => [(String, m JSValue)] -> m JSValue
mkObject [
                (String
"public", 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) = 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) = 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) = 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" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$
          PublicKey -> PublicKey Ed25519
PublicKeyEd25519 (ByteString -> PublicKey
Ed25519.PublicKey ByteString
pub)
        String
_otherwise ->
          forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid key type" (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 <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keytype"
        JSValue
val <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
obj String
"keyval"
        Base64
pub <- forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> String -> m a
fromJSField JSValue
val String
"public"
        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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
enc
    case String
tag of
      String
"ed25519"  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ KeyType Ed25519
KeyTypeEd25519
      String
_otherwise -> forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"valid key type" (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