{-# LANGUAGE QuasiQuotes #-}

-- 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)

-- | [Okta OIDC & OAuth2 API](https://developer.okta.com/docs/reference/api/oidc/)
module Network.OAuth2.Provider.Okta where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..))
import Data.Aeson
import Data.Aeson qualified as Aeson
import Data.Bifunctor
import Data.ByteString.Contrib
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text.Lazy as TL
import Data.Time
import GHC.Generics
import Jose.Jwa
import Jose.Jwk
import Jose.Jws
import Jose.Jwt
import Network.HTTP.Conduit (Manager)
import Network.OAuth.OAuth2
import Network.OAuth2.Experiment
import Network.OAuth2.Provider
import Network.OIDC.WellKnown
import URI.ByteString.QQ

sampleOktaAuthorizationCodeApp :: AuthorizationCodeApplication
sampleOktaAuthorizationCodeApp :: AuthorizationCodeApplication
sampleOktaAuthorizationCodeApp =
  AuthorizationCodeApplication
    { acClientId :: ClientId
acClientId = ClientId
""
    , acClientSecret :: ClientSecret
acClientSecret = ClientSecret
""
    , acScope :: Set Scope
acScope = [Scope] -> Set Scope
forall a. Ord a => [a] -> Set a
Set.fromList [Scope
"openid", Scope
"profile", Scope
"email"]
    , acAuthorizeState :: AuthorizeState
acAuthorizeState = AuthorizeState
"CHANGE_ME"
    , acAuthorizeRequestExtraParams :: Map Text Text
acAuthorizeRequestExtraParams = Map Text Text
forall k a. Map k a
Map.empty
    , acRedirectUri :: URI
acRedirectUri = [uri|http://localhost|]
    , acName :: Text
acName = Text
"sample-okta-authorization-code-app"
    , acTokenRequestAuthenticationMethod :: ClientAuthenticationMethod
acTokenRequestAuthenticationMethod = ClientAuthenticationMethod
ClientSecretBasic
    }

fetchUserInfo ::
  (MonadIO m, HasUserInfoRequest a, FromJSON b) =>
  IdpApplication i a ->
  Manager ->
  AccessToken ->
  ExceptT BSL.ByteString m b
fetchUserInfo :: forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
fetchUserInfo = IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
forall {k} (m :: * -> *) a b (i :: k).
(MonadIO m, HasUserInfoRequest a, FromJSON b) =>
IdpApplication i a
-> Manager -> AccessToken -> ExceptT ByteString m b
conduitUserInfoRequest

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
  OpenIDConfiguration {URI
issuer :: URI
authorizationEndpoint :: URI
tokenEndpoint :: URI
userinfoEndpoint :: URI
jwksUri :: URI
deviceAuthorizationEndpoint :: URI
issuer :: OpenIDConfiguration -> URI
authorizationEndpoint :: OpenIDConfiguration -> URI
tokenEndpoint :: OpenIDConfiguration -> URI
userinfoEndpoint :: OpenIDConfiguration -> URI
jwksUri :: OpenIDConfiguration -> URI
deviceAuthorizationEndpoint :: OpenIDConfiguration -> URI
..} <- Text -> ExceptT Text m OpenIDConfiguration
forall (m :: * -> *).
MonadIO m =>
Text -> ExceptT Text m OpenIDConfiguration
fetchWellKnown Text
domain
  Idp 'Okta -> ExceptT Text m (Idp 'Okta)
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Idp 'Okta -> ExceptT Text m (Idp 'Okta))
-> Idp 'Okta -> ExceptT Text m (Idp 'Okta)
forall a b. (a -> b) -> a -> b
$
    Idp
      { idpUserInfoEndpoint :: URI
idpUserInfoEndpoint = URI
userinfoEndpoint
      , idpAuthorizeEndpoint :: URI
idpAuthorizeEndpoint = URI
authorizationEndpoint
      , idpTokenEndpoint :: URI
idpTokenEndpoint = URI
tokenEndpoint
      , idpDeviceAuthorizationEndpoint :: Maybe URI
idpDeviceAuthorizationEndpoint = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
deviceAuthorizationEndpoint
      }

mkOktaClientCredentialAppJwt ::
  Jwk ->
  ClientId ->
  Idp i ->
  IO (Either Text Jwt)
mkOktaClientCredentialAppJwt :: forall {k} (i :: k).
Jwk -> ClientId -> Idp i -> IO (Either Text Jwt)
mkOktaClientCredentialAppJwt Jwk
jwk ClientId
cid Idp i
idp = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let cidStr :: Text
cidStr = ClientId -> Text
unClientId ClientId
cid
  let payload :: ByteString
payload =
        ByteString -> ByteString
bsToStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
            [Pair] -> Value
Aeson.object
              [ Key
"aud" Key -> URI -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Idp i -> URI
forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp
              , Key
"exp" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e 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" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds UTCTime
now
              , Key
"iss" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
cidStr
              , Key
"sub" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
cidStr
              ]
  (JwtError -> Text) -> Either JwtError Jwt -> Either Text Jwt
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
TL.pack (String -> Text) -> (JwtError -> String) -> JwtError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JwtError -> String
forall a. Show a => a -> String
show) (Either JwtError Jwt -> Either Text Jwt)
-> IO (Either JwtError Jwt) -> IO (Either Text Jwt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JwsAlg -> Jwk -> Payload -> IO (Either JwtError Jwt)
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 = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%s"

data OktaUser = OktaUser
  { OktaUser -> Text
name :: Text
  , OktaUser -> Text
preferredUsername :: Text
  }
  deriving (Int -> OktaUser -> ShowS
[OktaUser] -> ShowS
OktaUser -> String
(Int -> OktaUser -> ShowS)
-> (OktaUser -> String) -> ([OktaUser] -> ShowS) -> Show OktaUser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OktaUser -> ShowS
showsPrec :: Int -> OktaUser -> ShowS
$cshow :: OktaUser -> String
show :: OktaUser -> String
$cshowList :: [OktaUser] -> ShowS
showList :: [OktaUser] -> ShowS
Show, (forall x. OktaUser -> Rep OktaUser x)
-> (forall x. Rep OktaUser x -> OktaUser) -> Generic OktaUser
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
$cfrom :: forall x. OktaUser -> Rep OktaUser x
from :: forall x. OktaUser -> Rep OktaUser x
$cto :: forall x. Rep OktaUser x -> OktaUser
to :: forall x. Rep OktaUser x -> OktaUser
Generic)

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