{-# 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