{-|

Copyright:

  This file is part of the package openid-connect.  It is subject to
  the license terms in the LICENSE file found in the top-level
  directory of this distribution and at:

    https://code.devalot.com/open/openid-connect

  No part of this package, including this file, may be copied,
  modified, propagated, or distributed except according to the terms
  contained in the LICENSE file.

License: BSD-2-Clause

-}
module OpenID.Connect.Provider.Key
  (
    -- * Generating Keys
    newJWK
  , newSigningJWK
  , newEncryptionJWK
  ) where

--------------------------------------------------------------------------------
-- Imports:
import Control.Lens ((^.), (?~), re)
import Crypto.Hash (Digest, SHA256)
import Crypto.JOSE (JWK, KeyUse(..))
import qualified Crypto.JOSE as JOSE
import qualified Crypto.JOSE.JWA.JWE.Alg as JOSE
import Crypto.Random (MonadRandom)
import Data.Function ((&))
import Data.Text (Text)
import Data.Text.Strict.Lens (utf8)

--------------------------------------------------------------------------------
-- | An opinionated way of creating a 'JWK'.  For more control over
-- how the key is crated use 'JOSE.genJWK' instead.
--
-- Returns the new key and the key's ID.
--
-- @since 0.1.0.0
newJWK :: MonadRandom m => KeyUse -> m (JWK, Text)
newJWK :: KeyUse -> m (JWK, Text)
newJWK KeyUse
keyuse = do
    JWK
jwk <- KeyMaterialGenParam -> m JWK
forall (m :: * -> *). MonadRandom m => KeyMaterialGenParam -> m JWK
JOSE.genJWK (Int -> KeyMaterialGenParam
JOSE.RSAGenParam (Int
4096 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8))

    let h :: Digest SHA256
h     = JWK
jwk JWK -> Getting (Digest SHA256) JWK (Digest SHA256) -> Digest SHA256
forall s a. s -> Getting a s a -> a
^. Getting (Digest SHA256) JWK (Digest SHA256)
forall a. HashAlgorithm a => Getter JWK (Digest a)
JOSE.thumbprint :: Digest SHA256
        kid :: Text
kid   = Digest SHA256
h Digest SHA256 -> Getting Text (Digest SHA256) Text -> Text
forall s a. s -> Getting a s a -> a
^. (AReview ByteString (Digest SHA256)
-> Getter (Digest SHA256) ByteString
forall t b. AReview t b -> Getter b t
re (Tagged ByteString (Identity ByteString)
-> Tagged ByteString (Identity ByteString)
forall s1 s2.
(AsEmpty s1, AsEmpty s2, Cons s1 s1 Word8 Word8,
 Cons s2 s2 Word8 Word8) =>
Prism' s1 s2
JOSE.base64url (Tagged ByteString (Identity ByteString)
 -> Tagged ByteString (Identity ByteString))
-> AReview ByteString (Digest SHA256)
-> AReview ByteString (Digest SHA256)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AReview ByteString (Digest SHA256)
forall a. HashAlgorithm a => Prism' ByteString (Digest a)
JOSE.digest) ((ByteString -> Const Text ByteString)
 -> Digest SHA256 -> Const Text (Digest SHA256))
-> ((Text -> Const Text Text)
    -> ByteString -> Const Text ByteString)
-> Getting Text (Digest SHA256) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ByteString -> Const Text ByteString
Prism' ByteString Text
utf8)
        final :: JWK
final = JWK
jwk
              JWK -> (JWK -> JWK) -> JWK
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> JWK -> Identity JWK
Lens' JWK (Maybe Text)
JOSE.jwkKid ((Maybe Text -> Identity (Maybe Text)) -> JWK -> Identity JWK)
-> Text -> JWK -> JWK
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
kid
              JWK -> (JWK -> JWK) -> JWK
forall a b. a -> (a -> b) -> b
& (Maybe KeyUse -> Identity (Maybe KeyUse)) -> JWK -> Identity JWK
Lens' JWK (Maybe KeyUse)
JOSE.jwkUse ((Maybe KeyUse -> Identity (Maybe KeyUse)) -> JWK -> Identity JWK)
-> KeyUse -> JWK -> JWK
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ KeyUse
keyuse
              JWK -> (JWK -> JWK) -> JWK
forall a b. a -> (a -> b) -> b
& (Maybe JWKAlg -> Identity (Maybe JWKAlg)) -> JWK -> Identity JWK
Lens' JWK (Maybe JWKAlg)
JOSE.jwkAlg ((Maybe JWKAlg -> Identity (Maybe JWKAlg)) -> JWK -> Identity JWK)
-> JWKAlg -> JWK -> JWK
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ KeyUse -> JWKAlg
alg KeyUse
keyuse

    (JWK, Text) -> m (JWK, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JWK
final, Text
kid)

  where
    alg :: KeyUse -> JOSE.JWKAlg
    alg :: KeyUse -> JWKAlg
alg = \case
      KeyUse
Sig -> Alg -> JWKAlg
JOSE.JWSAlg Alg
JOSE.RS256
      KeyUse
Enc -> Alg -> JWKAlg
JOSE.JWEAlg Alg
JOSE.A256KW

--------------------------------------------------------------------------------
-- | Created a new signing key.
--
-- @since 0.1.0.0
newSigningJWK :: MonadRandom m => m JWK
newSigningJWK :: m JWK
newSigningJWK = (JWK, Text) -> JWK
forall a b. (a, b) -> a
fst ((JWK, Text) -> JWK) -> m (JWK, Text) -> m JWK
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyUse -> m (JWK, Text)
forall (m :: * -> *). MonadRandom m => KeyUse -> m (JWK, Text)
newJWK KeyUse
Sig

--------------------------------------------------------------------------------
-- | Create a new encryption key.
--
-- @since 0.1.0.0
newEncryptionJWK :: MonadRandom m => m JWK
newEncryptionJWK :: m JWK
newEncryptionJWK = (JWK, Text) -> JWK
forall a b. (a, b) -> a
fst ((JWK, Text) -> JWK) -> m (JWK, Text) -> m JWK
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyUse -> m (JWK, Text)
forall (m :: * -> *). MonadRandom m => KeyUse -> m (JWK, Text)
newJWK KeyUse
Enc