{-# 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)
data DeviceAuthorizationApplication = DeviceAuthorizationApplication
{ DeviceAuthorizationApplication -> Text
daName :: Text
, DeviceAuthorizationApplication -> ClientId
daClientId :: ClientId
, DeviceAuthorizationApplication -> ClientSecret
daClientSecret :: ClientSecret
, DeviceAuthorizationApplication -> Set Scope
daScope :: Set Scope
, :: Map Text Text
, DeviceAuthorizationApplication -> Maybe ClientAuthenticationMethod
daAuthorizationRequestAuthenticationMethod :: Maybe ClientAuthenticationMethod
}
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 ->
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
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
}
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 =
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