{-# 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
  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)
    (forall a. a -> Maybe a -> a
fromMaybe Int
5 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 <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (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 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
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
intervalSeconds forall a. Num a => a -> a -> a
* Int
1000000
          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 forall a. Num a => a -> a -> a
+ Int
5
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
newIntervalSeconds forall a. Num a => a -> a -> a
* Int
1000000
          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
_ -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE TokenResponseError
trRespError
    Right OAuth2Token
v -> 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
daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
daAuthorizationRequestExtraParam :: Map Text Text
daScope :: Set Scope
daClientSecret :: ClientSecret
daClientId :: ClientId
daName :: Text
daAuthorizationRequestAuthenticationMethod :: DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
daAuthorizationRequestExtraParam :: DeviceAuthorizationApplication -> Map Text Text
daScope :: DeviceAuthorizationApplication -> Set Scope
daClientSecret :: DeviceAuthorizationApplication -> ClientSecret
daClientId :: DeviceAuthorizationApplication -> ClientId
daName :: DeviceAuthorizationApplication -> Text
..} = 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
daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
daAuthorizationRequestExtraParam :: Map Text Text
daScope :: Set Scope
daClientSecret :: ClientSecret
daClientId :: ClientId
daName :: Text
daAuthorizationRequestAuthenticationMethod :: DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
daAuthorizationRequestExtraParam :: DeviceAuthorizationApplication -> Map Text Text
daScope :: DeviceAuthorizationApplication -> Set Scope
daClientSecret :: DeviceAuthorizationApplication -> ClientSecret
daClientId :: DeviceAuthorizationApplication -> ClientId
daName :: DeviceAuthorizationApplication -> Text
..} =
    DeviceAuthorizationRequestParam
      { arScope :: Set Scope
arScope = Set Scope
daScope
      , arClientId :: Maybe ClientId
arClientId =
          if Maybe ClientAuthenticationMethod
daAuthorizationRequestAuthenticationMethod forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ClientAuthenticationMethod
ClientSecretBasic
            then forall a. Maybe a
Nothing
            else 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
daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
daAuthorizationRequestExtraParam :: Map Text Text
daScope :: Set Scope
daClientSecret :: ClientSecret
daClientId :: ClientId
daName :: Text
daAuthorizationRequestAuthenticationMethod :: DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
daAuthorizationRequestExtraParam :: DeviceAuthorizationApplication -> Map Text Text
daScope :: DeviceAuthorizationApplication -> Set Scope
daClientSecret :: DeviceAuthorizationApplication -> ClientSecret
daClientId :: DeviceAuthorizationApplication -> ClientId
daName :: DeviceAuthorizationApplication -> Text
..} 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ClientAuthenticationMethod
ClientSecretBasic
            then forall a. Maybe a
Nothing
            else 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
trClientId :: Maybe ClientId
trGrantType :: GrantTypeValue
trCode :: DeviceCode
trClientId :: TokenRequest DeviceAuthorizationApplication -> Maybe ClientId
trGrantType :: TokenRequest DeviceAuthorizationApplication -> GrantTypeValue
trCode :: TokenRequest DeviceAuthorizationApplication -> DeviceCode
..} =
    forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      [ forall a. ToQueryParam a => a -> Map Text Text
toQueryParam DeviceCode
trCode
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam GrantTypeValue
trGrantType
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam Maybe ClientId
trClientId
      ]

instance HasUserInfoRequest DeviceAuthorizationApplication