{-# 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 = 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-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 = 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 = 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
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
"login.microsoftonline.com/" forall a. Semigroup a => a -> a -> a
<> Text
domain forall a. Semigroup a => a -> a -> a
<> Text
"/v2.0")
  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
      }

-- | 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AzureADUser] -> ShowS
$cshowList :: [AzureADUser] -> ShowS
show :: AzureADUser -> String
$cshow :: AzureADUser -> String
showsPrec :: Int -> AzureADUser -> ShowS
$cshowsPrec :: Int -> AzureADUser -> ShowS
Show, 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
$cto :: forall x. Rep AzureADUser x -> AzureADUser
$cfrom :: forall x. AzureADUser -> Rep AzureADUser x
Generic)

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