{-# 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 = 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 = 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 = 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
deviceAuthorizationEndpoint :: OpenIDConfiguration -> URI
jwksUri :: OpenIDConfiguration -> URI
userinfoEndpoint :: OpenIDConfiguration -> URI
tokenEndpoint :: OpenIDConfiguration -> URI
authorizationEndpoint :: OpenIDConfiguration -> URI
issuer :: OpenIDConfiguration -> URI
deviceAuthorizationEndpoint :: URI
jwksUri :: URI
userinfoEndpoint :: URI
tokenEndpoint :: URI
authorizationEndpoint :: URI
issuer :: URI
..} <- forall (m :: * -> *).
MonadIO m =>
Text -> ExceptT Text m OpenIDConfiguration
fetchWellKnown Text
domain
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = 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 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
"aud" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall k (i :: k). Idp i -> URI
idpTokenEndpoint Idp i
idp
              , Key
"exp" 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" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime -> String
tToSeconds UTCTime
now
              , Key
"iss" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
cidStr
              , Key
"sub" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
cidStr
              ]
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (String -> Text
TL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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"

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
'_'}