{-# LANGUAGE QuasiQuotes #-}

-- | [AzureAD oauth2 flow](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-auth-code-flow)
module Network.OAuth2.Provider.AzureAD where

import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..))
import Data.Aeson
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 (Text)
import GHC.Generics
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

-- Create app at https://go.microsoft.com/fwlink/?linkid=2083908
--
-- also be aware to find the right client id.
-- see https://stackoverflow.com/a/70670961
sampleAzureADAuthorizationCodeApp :: AuthorizationCodeApplication
sampleAzureADAuthorizationCodeApp :: AuthorizationCodeApplication
sampleAzureADAuthorizationCodeApp =
  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-azure-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

-- | https://login.microsoftonline.com/common/v2.0/.well-known/openid-configuration
-- It's supporse to resue 'mkAzureIdp'
--
-- @
-- mkAzureIdp "common"
-- @
--
-- But its issuer is "https://login.microsoftonline.com/{tenantid}/v2.0",
-- which is invalid URI!!
defaultAzureADIdp :: Idp AzureAD
defaultAzureADIdp :: Idp 'AzureAD
defaultAzureADIdp =
  Idp
    { idpAuthorizeEndpoint :: URI
idpAuthorizeEndpoint = [uri|https://login.microsoftonline.com/common/oauth2/v2.0/authorize|]
    , idpTokenEndpoint :: URI
idpTokenEndpoint = [uri|https://login.microsoftonline.com/common/oauth2/v2.0/token|]
    , idpUserInfoEndpoint :: URI
idpUserInfoEndpoint = [uri|https://graph.microsoft.com/oidc/userinfo|]
    , idpDeviceAuthorizationEndpoint :: Maybe URI
idpDeviceAuthorizationEndpoint = URI -> Maybe URI
forall a. a -> Maybe a
Just [uri|https://login.microsoftonline.com/common/oauth2/v2.0/devicecode|]
    }

mkAzureIdp ::
  MonadIO m =>
  -- | Full domain with no http protocol. e.g. @contoso.onmicrosoft.com@
  Text ->
  ExceptT Text m (Idp AzureAD)
mkAzureIdp :: forall (m :: * -> *).
MonadIO m =>
Text -> ExceptT Text m (Idp 'AzureAD)
mkAzureIdp 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
"login.microsoftonline.com/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domain Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/v2.0")
  Idp 'AzureAD -> ExceptT Text m (Idp 'AzureAD)
forall a. a -> ExceptT Text m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Idp 'AzureAD -> ExceptT Text m (Idp 'AzureAD))
-> Idp 'AzureAD -> ExceptT Text m (Idp 'AzureAD)
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
      }

-- | https://learn.microsoft.com/en-us/azure/active-directory/develop/userinfo
data AzureADUser = AzureADUser
  { AzureADUser -> Text
sub :: Text
  , AzureADUser -> Text
email :: Text
  , AzureADUser -> Text
familyName :: Text
  , AzureADUser -> Text
givenName :: Text
  , AzureADUser -> Text
name :: Text
  }
  deriving (Int -> AzureADUser -> ShowS
[AzureADUser] -> ShowS
AzureADUser -> String
(Int -> AzureADUser -> ShowS)
-> (AzureADUser -> String)
-> ([AzureADUser] -> ShowS)
-> Show AzureADUser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AzureADUser -> ShowS
showsPrec :: Int -> AzureADUser -> ShowS
$cshow :: AzureADUser -> String
show :: AzureADUser -> String
$cshowList :: [AzureADUser] -> ShowS
showList :: [AzureADUser] -> ShowS
Show, (forall x. AzureADUser -> Rep AzureADUser x)
-> (forall x. Rep AzureADUser x -> AzureADUser)
-> Generic AzureADUser
forall x. Rep AzureADUser x -> AzureADUser
forall x. AzureADUser -> Rep AzureADUser x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AzureADUser -> Rep AzureADUser x
from :: forall x. AzureADUser -> Rep AzureADUser x
$cto :: forall x. Rep AzureADUser x -> AzureADUser
to :: forall x. Rep AzureADUser x -> AzureADUser
Generic)

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