    {-# LANGUAGE FlexibleInstances #-}

    module Network.OAuth2.Experiment.Grants.DeviceAuthorization (
      DeviceAuthorizationApplication (..),
      pollDeviceTokenRequest,
    ) where

    import Control.Concurrent
    import Control.Monad.IO.Class (MonadIO (..))
    import Control.Monad.Trans.Except
    import Data.Map.Strict (Map)
    import Data.Map.Strict qualified as Map
    import Data.Maybe
    import Data.Set (Set)
    import Data.Text.Lazy (Text)
    import Network.HTTP.Conduit
    import Network.OAuth.OAuth2
    import Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest
    import Network.OAuth2.Experiment.Flows.TokenRequest
    import Network.OAuth2.Experiment.Flows.UserInfoRequest
    import Network.OAuth2.Experiment.Types
    import Prelude hiding (error)

    -- | An Application that supports "Device Authorization Grant"
    --
    -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1
    data DeviceAuthorizationApplication = DeviceAuthorizationApplication
      { DeviceAuthorizationApplication -> Text
    daName :: Text
      , DeviceAuthorizationApplication -> ClientId
    daClientId :: ClientId
      , DeviceAuthorizationApplication -> ClientSecret
    daClientSecret :: ClientSecret
      , DeviceAuthorizationApplication -> Set Scope
    daScope :: Set Scope
      , DeviceAuthorizationApplication -> Map Text Text
    daAuthorizationRequestExtraParam :: Map Text Text
      -- ^ Additional parameters to the device authorization request.
      -- Most of identity providers follow the spec strictly but
      -- AzureAD requires "tenant" parameter.
      , DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
    daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
      -- ^ The spec requires similar authentication method as /token request.
      -- Most of identity providers doesn't required it but some does like Okta.
      }

    pollDeviceTokenRequest ::
      MonadIO m =>
      IdpApplication i DeviceAuthorizationApplication ->
      Manager ->
      DeviceAuthorizationResponse ->
      ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequest :: forall {k} (m :: * -> *) (i :: k).
    MonadIO m =>
    IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceAuthorizationResponse
    -> ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequest IdpApplication i DeviceAuthorizationApplication
    idpApp Manager
    mgr DeviceAuthorizationResponse
    deviceAuthResp = do
      IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    forall {k} (m :: * -> *) (i :: k).
    MonadIO m =>
    IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequestInternal
        IdpApplication i DeviceAuthorizationApplication
    idpApp
        Manager
    mgr
        (DeviceAuthorizationResponse -> DeviceCode
    deviceCode DeviceAuthorizationResponse
    deviceAuthResp)
        (Int -> Maybe Int -> Int
    forall a. a -> Maybe a -> a
    fromMaybe Int
    5 (Maybe Int -> Int) -> Maybe Int -> Int
    forall a b. (a -> b) -> a -> b
    $ DeviceAuthorizationResponse -> Maybe Int
    interval DeviceAuthorizationResponse
    deviceAuthResp)

    pollDeviceTokenRequestInternal ::
      MonadIO m =>
      IdpApplication i DeviceAuthorizationApplication ->
      Manager ->
      DeviceCode ->
      Int ->
      -- | Polling Interval
      ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequestInternal :: forall {k} (m :: * -> *) (i :: k).
    MonadIO m =>
    IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequestInternal IdpApplication i DeviceAuthorizationApplication
    idpApp Manager
    mgr DeviceCode
    deviceCode Int
    intervalSeconds = do
      Either TokenResponseError OAuth2Token
    resp <- ExceptT
      TokenResponseError (ExceptT TokenResponseError m) OAuth2Token
    -> ExceptT
         TokenResponseError m (Either TokenResponseError OAuth2Token)
    forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
    runExceptT (IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> ExchangeTokenInfo DeviceAuthorizationApplication
    -> ExceptT
         TokenResponseError (ExceptT TokenResponseError m) OAuth2Token
    forall {k} a (m :: * -> *) (i :: k).
    (HasTokenRequest a, ToQueryParam (TokenRequest a), MonadIO m) =>
    IdpApplication i a
    -> Manager
    -> ExchangeTokenInfo a
    -> ExceptT TokenResponseError m OAuth2Token
    conduitTokenRequest IdpApplication i DeviceAuthorizationApplication
    idpApp Manager
    mgr ExchangeTokenInfo DeviceAuthorizationApplication
    DeviceCode
    deviceCode)
      case Either TokenResponseError OAuth2Token
    resp of
        Left TokenResponseError
    trRespError -> do
          case TokenResponseError -> TokenResponseErrorCode
    tokenResponseError TokenResponseError
    trRespError of
            -- TODO: Didn't have a good idea to expand the error code
            -- specifically for device token request flow
            -- Device Token Response additional error code: https://www.rfc-editor.org/rfc/rfc8628#section-3.5
            UnknownErrorCode Text
    "authorization_pending" -> do
              IO () -> ExceptT TokenResponseError m ()
    forall a. IO a -> ExceptT TokenResponseError m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ExceptT TokenResponseError m ())
    -> IO () -> ExceptT TokenResponseError m ()
    forall a b. (a -> b) -> a -> b
    $ Int -> IO ()
    threadDelay (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int
    intervalSeconds Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000000
              IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    forall {k} (m :: * -> *) (i :: k).
    MonadIO m =>
    IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequestInternal IdpApplication i DeviceAuthorizationApplication
    idpApp Manager
    mgr DeviceCode
    deviceCode Int
    intervalSeconds
            UnknownErrorCode Text
    "slow_down" -> do
              let newIntervalSeconds :: Int
    newIntervalSeconds = Int
    intervalSeconds Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    5
              IO () -> ExceptT TokenResponseError m ()
    forall a. IO a -> ExceptT TokenResponseError m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> ExceptT TokenResponseError m ())
    -> IO () -> ExceptT TokenResponseError m ()
    forall a b. (a -> b) -> a -> b
    $ Int -> IO ()
    threadDelay (Int -> IO ()) -> Int -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int
    newIntervalSeconds Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    1000000
              IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    forall {k} (m :: * -> *) (i :: k).
    MonadIO m =>
    IdpApplication i DeviceAuthorizationApplication
    -> Manager
    -> DeviceCode
    -> Int
    -> ExceptT TokenResponseError m OAuth2Token
    pollDeviceTokenRequestInternal IdpApplication i DeviceAuthorizationApplication
    idpApp Manager
    mgr DeviceCode
    deviceCode Int
    newIntervalSeconds
            TokenResponseErrorCode
    _ -> TokenResponseError -> ExceptT TokenResponseError m OAuth2Token
    forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
    throwE TokenResponseError
    trRespError
        Right OAuth2Token
    v -> OAuth2Token -> ExceptT TokenResponseError m OAuth2Token
    forall a. a -> ExceptT TokenResponseError m a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure OAuth2Token
    v

    instance HasOAuth2Key DeviceAuthorizationApplication where
      mkOAuth2Key :: DeviceAuthorizationApplication -> OAuth2
      mkOAuth2Key :: DeviceAuthorizationApplication -> OAuth2
    mkOAuth2Key DeviceAuthorizationApplication {Maybe ClientAuthenticationMethod
    Map Text Text
    Text
    Set Scope
    ClientSecret
    ClientId
    daName :: DeviceAuthorizationApplication -> Text
    daClientId :: DeviceAuthorizationApplication -> ClientId
    daClientSecret :: DeviceAuthorizationApplication -> ClientSecret
    daScope :: DeviceAuthorizationApplication -> Set Scope
    daAuthorizationRequestExtraParam :: DeviceAuthorizationApplication -> Map Text Text
    daAuthorizationRequestAuthenticationMethod :: DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
    daName :: Text
    daClientId :: ClientId
    daClientSecret :: ClientSecret
    daScope :: Set Scope
    daAuthorizationRequestExtraParam :: Map Text Text
    daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
    ..} = ClientId -> ClientSecret -> OAuth2
    toOAuth2Key ClientId
    daClientId ClientSecret
    daClientSecret

    instance HasTokenRequestClientAuthenticationMethod DeviceAuthorizationApplication where
      getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod
      getClientAuthenticationMethod :: DeviceAuthorizationApplication -> ClientAuthenticationMethod
    getClientAuthenticationMethod DeviceAuthorizationApplication
    _ = ClientAuthenticationMethod
    ClientSecretBasic

    instance HasDeviceAuthorizationRequest DeviceAuthorizationApplication where
      mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam
      mkDeviceAuthorizationRequestParam :: DeviceAuthorizationApplication -> DeviceAuthorizationRequestParam
    mkDeviceAuthorizationRequestParam DeviceAuthorizationApplication {Maybe ClientAuthenticationMethod
    Map Text Text
    Text
    Set Scope
    ClientSecret
    ClientId
    daName :: DeviceAuthorizationApplication -> Text
    daClientId :: DeviceAuthorizationApplication -> ClientId
    daClientSecret :: DeviceAuthorizationApplication -> ClientSecret
    daScope :: DeviceAuthorizationApplication -> Set Scope
    daAuthorizationRequestExtraParam :: DeviceAuthorizationApplication -> Map Text Text
    daAuthorizationRequestAuthenticationMethod :: DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
    daName :: Text
    daClientId :: ClientId
    daClientSecret :: ClientSecret
    daScope :: Set Scope
    daAuthorizationRequestExtraParam :: Map Text Text
    daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
    ..} =
        DeviceAuthorizationRequestParam
          { arScope :: Set Scope
    arScope = Set Scope
    daScope
          , arClientId :: Maybe ClientId
    arClientId =
              if Maybe ClientAuthenticationMethod
    daAuthorizationRequestAuthenticationMethod Maybe ClientAuthenticationMethod
    -> Maybe ClientAuthenticationMethod -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClientAuthenticationMethod -> Maybe ClientAuthenticationMethod
    forall a. a -> Maybe a
    Just ClientAuthenticationMethod
    ClientSecretBasic
                then Maybe ClientId
    forall a. Maybe a
    Nothing
                else ClientId -> Maybe ClientId
    forall a. a -> Maybe a
    Just ClientId
    daClientId
          , arExtraParams :: Map Text Text
    arExtraParams = Map Text Text
    daAuthorizationRequestExtraParam
          }

    -- | https://www.rfc-editor.org/rfc/rfc8628#section-3.4
    instance HasTokenRequest DeviceAuthorizationApplication where
      type ExchangeTokenInfo DeviceAuthorizationApplication = DeviceCode
      data TokenRequest DeviceAuthorizationApplication = AuthorizationCodeTokenRequest
        { TokenRequest DeviceAuthorizationApplication -> DeviceCode
    trCode :: DeviceCode
        , TokenRequest DeviceAuthorizationApplication -> GrantTypeValue
    trGrantType :: GrantTypeValue
        , TokenRequest DeviceAuthorizationApplication -> Maybe ClientId
    trClientId :: Maybe ClientId
        }

      mkTokenRequestParam ::
        DeviceAuthorizationApplication ->
        DeviceCode ->
        TokenRequest DeviceAuthorizationApplication
      mkTokenRequestParam :: DeviceAuthorizationApplication
    -> DeviceCode -> TokenRequest DeviceAuthorizationApplication
    mkTokenRequestParam DeviceAuthorizationApplication {Maybe ClientAuthenticationMethod
    Map Text Text
    Text
    Set Scope
    ClientSecret
    ClientId
    daName :: DeviceAuthorizationApplication -> Text
    daClientId :: DeviceAuthorizationApplication -> ClientId
    daClientSecret :: DeviceAuthorizationApplication -> ClientSecret
    daScope :: DeviceAuthorizationApplication -> Set Scope
    daAuthorizationRequestExtraParam :: DeviceAuthorizationApplication -> Map Text Text
    daAuthorizationRequestAuthenticationMethod :: DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
    daName :: Text
    daClientId :: ClientId
    daClientSecret :: ClientSecret
    daScope :: Set Scope
    daAuthorizationRequestExtraParam :: Map Text Text
    daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
    ..} DeviceCode
    deviceCode =
        --
        -- This is a bit hacky!
        -- The token request use `ClientSecretBasic` by default. (has to pick up one Client Authn Method)
        -- ClientId shall be also be in request body per spec.
        -- However, for some IdPs, e.g. Okta, when using `ClientSecretBasic` to authn Client,
        -- it doesn't allow @client_id@ in the request body
        -- 'daAuthorizationRequestAuthenticationMethod' set the tone for Authorization Request,
        -- hence just follow it in the token request
        AuthorizationCodeTokenRequest
          { trCode :: DeviceCode
    trCode = DeviceCode
    deviceCode
          , trGrantType :: GrantTypeValue
    trGrantType = GrantTypeValue
    GTDeviceCode
          , trClientId :: Maybe ClientId
    trClientId =
              if Maybe ClientAuthenticationMethod
    daAuthorizationRequestAuthenticationMethod Maybe ClientAuthenticationMethod
    -> Maybe ClientAuthenticationMethod -> Bool
    forall a. Eq a => a -> a -> Bool
    == ClientAuthenticationMethod -> Maybe ClientAuthenticationMethod
    forall a. a -> Maybe a
    Just ClientAuthenticationMethod
    ClientSecretBasic
                then Maybe ClientId
    forall a. Maybe a
    Nothing
                else ClientId -> Maybe ClientId
    forall a. a -> Maybe a
    Just ClientId
    daClientId
          }

    instance ToQueryParam (TokenRequest DeviceAuthorizationApplication) where
      toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text
      toQueryParam :: TokenRequest DeviceAuthorizationApplication -> Map Text Text
    toQueryParam AuthorizationCodeTokenRequest {Maybe ClientId
    GrantTypeValue
    DeviceCode
    trCode :: TokenRequest DeviceAuthorizationApplication -> DeviceCode
    trGrantType :: TokenRequest DeviceAuthorizationApplication -> GrantTypeValue
    trClientId :: TokenRequest DeviceAuthorizationApplication -> Maybe ClientId
    trCode :: DeviceCode
    trGrantType :: GrantTypeValue
    trClientId :: Maybe ClientId
    ..} =
        [Map Text Text] -> Map Text Text
    forall (f :: * -> *) k a.
    (Foldable f, Ord k) =>
    f (Map k a) -> Map k a
    Map.unions
          [ DeviceCode -> Map Text Text
    forall a. ToQueryParam a => a -> Map Text Text
    toQueryParam DeviceCode
    trCode
          , GrantTypeValue -> Map Text Text
    forall a. ToQueryParam a => a -> Map Text Text
    toQueryParam GrantTypeValue
    trGrantType
          , Maybe ClientId -> Map Text Text
    forall a. ToQueryParam a => a -> Map Text Text
    toQueryParam Maybe ClientId
    trClientId
          ]

    instance HasUserInfoRequest DeviceAuthorizationApplication