{-|

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 :: forall (m :: * -> *). MonadRandom m => KeyUse -> m (JWK, Text)
newJWK KeyUse
keyuse = do
    JWK
jwk <- forall (m :: * -> *). MonadRandom m => KeyMaterialGenParam -> m JWK
JOSE.genJWK (Int -> KeyMaterialGenParam
JOSE.RSAGenParam (Int
4096 forall a. Integral a => a -> a -> a
`div` Int
8))

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

    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 :: forall (m :: * -> *). MonadRandom m => m JWK
newSigningJWK = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall (m :: * -> *). MonadRandom m => m JWK
newEncryptionJWK = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadRandom m => KeyUse -> m (JWK, Text)
newJWK KeyUse
Enc