{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Network.OAuth2.Provider.Okta where

import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson
import Data.Aeson qualified as Aeson
import Data.Bifunctor
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text.Lazy (Text)
import Data.Time
import GHC.Generics
import Jose.Jwa
import Jose.Jwk
import Jose.Jws
import Jose.Jwt
import Network.OAuth.OAuth2
import Network.OAuth2.Experiment
import Network.OAuth2.Provider.Utils
import Network.OIDC.WellKnown
import URI.ByteString.QQ

data Okta = Okta deriving (Okta -> Okta -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Okta -> Okta -> Bool
$c/= :: Okta -> Okta -> Bool
== :: Okta -> Okta -> Bool
$c== :: Okta -> Okta -> Bool
Eq, Int -> Okta -> ShowS
[Okta] -> ShowS
Okta -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Okta] -> ShowS
$cshowList :: [Okta] -> ShowS
show :: Okta -> String
$cshow :: Okta -> String
showsPrec :: Int -> Okta -> ShowS
$cshowsPrec :: Int -> Okta -> ShowS
Show)

type instance IdpUserInfo Okta = OktaUser

defaultOktaApp :: Idp Okta -> IdpApplication 'AuthorizationCode Okta
defaultOktaApp :: Idp Okta -> IdpApplication 'AuthorizationCode Okta
defaultOktaApp Idp Okta
i =
  AuthorizationCodeIdpApplication
    { $sel:idpAppClientId:AuthorizationCodeIdpApplication :: ClientId
idpAppClientId = ClientId
""
    , $sel:idpAppClientSecret:AuthorizationCodeIdpApplication :: ClientSecret
idpAppClientSecret = ClientSecret
""
    , $sel:idpAppScope:AuthorizationCodeIdpApplication :: Set Scope
idpAppScope = forall a. Ord a => [a] -> Set a
Set.fromList [Scope
"openid", Scope
"profile", Scope
"email"]
    , $sel:idpAppAuthorizeState:AuthorizationCodeIdpApplication :: AuthorizeState
idpAppAuthorizeState = AuthorizeState
"CHANGE_ME"
    , $sel:idpAppAuthorizeExtraParams:AuthorizationCodeIdpApplication :: Map Text Text
idpAppAuthorizeExtraParams = forall k a. Map k a
Map.empty
    , $sel:idpAppRedirectUri:AuthorizationCodeIdpApplication :: URI
idpAppRedirectUri = [uri|http://localhost|]
    , $sel:idpAppName:AuthorizationCodeIdpApplication :: Text
idpAppName = Text
"default-okta-App"
    , $sel:idpAppTokenRequestAuthenticationMethod:AuthorizationCodeIdpApplication :: ClientAuthenticationMethod
idpAppTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
    , $sel:idp:AuthorizationCodeIdpApplication :: Idp Okta
idp = Idp Okta
i
    }

defaultOktaIdp :: Idp Okta
defaultOktaIdp :: Idp Okta
defaultOktaIdp =
  Idp
    { $sel:idpFetchUserInfo:Idp :: forall (m :: * -> *).
(FromJSON (IdpUserInfo Okta), MonadIO m) =>
Manager
-> AccessToken -> URI -> ExceptT ByteString m (IdpUserInfo Okta)
idpFetchUserInfo = forall a (m :: * -> *).
(FromJSON a, MonadIO m) =>
Manager -> AccessToken -> URI -> ExceptT ByteString m a
authGetJSON @(IdpUserInfo Okta)
    , $sel:idpUserInfoEndpoint:Idp :: URI
idpUserInfoEndpoint = [uri|https://foo.okta.com/oauth2/v1/userinfo|]
    , $sel:idpAuthorizeEndpoint:Idp :: URI
idpAuthorizeEndpoint =
        [uri|https://foo.okta.com/oauth2/v1/authorize|]
    , $sel:idpTokenEndpoint:Idp :: URI
idpTokenEndpoint =
        [uri|https://foo.okta.com/oauth2/v1/token|]
    }

mkOktaIdp ::
  MonadIO m =>
  -- | Full domain with no http protocol. e.g. @foo.okta.com@
  Text ->
  ExceptT Text m (Idp Okta)
mkOktaIdp :: forall (m :: * -> *).
MonadIO m =>
Text -> ExceptT Text m (Idp Okta)
mkOktaIdp Text
domain = do
  OpenIDConfigurationUris {URI
$sel:jwksUri:OpenIDConfigurationUris :: OpenIDConfigurationUris -> URI
$sel:userinfoUri:OpenIDConfigurationUris :: OpenIDConfigurationUris -> URI
$sel:tokenUri:OpenIDConfigurationUris :: OpenIDConfigurationUris -> URI
$sel:authorizationUri:OpenIDConfigurationUris :: OpenIDConfigurationUris -> URI
jwksUri :: URI
userinfoUri :: URI
tokenUri :: URI
authorizationUri :: URI
..} <- forall (m :: * -> *).
MonadIO m =>
Text -> ExceptT Text m OpenIDConfigurationUris
fetchWellKnownUris Text
domain
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( Idp Okta
defaultOktaIdp
        { $sel:idpUserInfoEndpoint:Idp :: URI
idpUserInfoEndpoint = URI
userinfoUri
        , $sel:idpAuthorizeEndpoint:Idp :: URI
idpAuthorizeEndpoint = URI
authorizationUri
        , $sel:idpTokenEndpoint:Idp :: URI
idpTokenEndpoint = URI
tokenUri
        }
    )

mkOktaClientCredentialAppJwt ::
  Jwk ->
  ClientId ->
  Idp Okta ->
  IO (Either String Jwt)
mkOktaClientCredentialAppJwt :: Jwk -> ClientId -> Idp Okta -> IO (Either String Jwt)
mkOktaClientCredentialAppJwt Jwk
jwk ClientId
cid Idp Okta
idp = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let cidStr :: Text
cidStr = ClientId -> Text
unClientId ClientId
cid
  let payload :: ByteString
payload =
        ByteString -> ByteString
bsToStrict forall a b. (a -> b) -> a -> b
$
          forall a. ToJSON a => a -> ByteString
Aeson.encode forall a b. (a -> b) -> a -> b
$
            [Pair] -> Value
Aeson.object
              [ Key
"iss" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
cidStr
              , Key
"sub" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
cidStr
              , Key
"aud" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. Idp a -> URI
idpTokenEndpoint Idp Okta
idp
              , Key
"exp" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds (NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
300) UTCTime
now) -- 5 minutes expiration time
              , Key
"iat" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds UTCTime
now
              ]
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
JwsAlg -> Jwk -> Payload -> m (Either JwtError Jwt)
jwkEncode JwsAlg
RS256 Jwk
jwk (ByteString -> Payload
Claims ByteString
payload)
  where
    tToSeconds :: UTCTime -> String
tToSeconds = forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s"

-- https://developer.okta.com/docs/reference/api/oidc/#request-parameters
-- Okta Org AS doesn't support consent
-- Okta Custom AS does support consent via config (what scope shall prompt consent)
data OktaUser = OktaUser
  { OktaUser -> Text
name :: Text
  , OktaUser -> Text
preferredUsername :: Text
  }
  deriving (Int -> OktaUser -> ShowS
[OktaUser] -> ShowS
OktaUser -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OktaUser] -> ShowS
$cshowList :: [OktaUser] -> ShowS
show :: OktaUser -> String
$cshow :: OktaUser -> String
showsPrec :: Int -> OktaUser -> ShowS
$cshowsPrec :: Int -> OktaUser -> ShowS
Show, forall x. Rep OktaUser x -> OktaUser
forall x. OktaUser -> Rep OktaUser x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OktaUser x -> OktaUser
$cfrom :: forall x. OktaUser -> Rep OktaUser x
Generic)

instance FromJSON OktaUser where
  parseJSON :: Value -> Parser OktaUser
parseJSON =
    forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions {fieldLabelModifier :: ShowS
fieldLabelModifier = Char -> ShowS
camelTo2 Char
'_'}