{-# LANGUAGE DerivingStrategies #-}

module Network.OAuth2.Experiment.Flows.DeviceAuthorizationRequest where

import Control.Applicative
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Except (ExceptT (..), throwE)
import Data.Aeson.Types
import Data.Bifunctor
import Data.ByteString.Lazy.Char8 qualified as BSL
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Text.Lazy (Text)
import Network.HTTP.Client.Contrib
import Network.HTTP.Conduit
import Network.OAuth.OAuth2 hiding (RefreshToken)
import Network.OAuth2.Experiment.Types
import Network.OAuth2.Experiment.Utils
import URI.ByteString hiding (UserInfo)

-------------------------------------------------------------------------------
--                    Device Authorization Request                           --
-------------------------------------------------------------------------------
newtype DeviceCode = DeviceCode Text
  deriving newtype (Value -> Parser [DeviceCode]
Value -> Parser DeviceCode
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [DeviceCode]
$cparseJSONList :: Value -> Parser [DeviceCode]
parseJSON :: Value -> Parser DeviceCode
$cparseJSON :: Value -> Parser DeviceCode
FromJSON)

instance ToQueryParam DeviceCode where
  toQueryParam :: DeviceCode -> Map Text Text
  toQueryParam :: DeviceCode -> Map Text Text
toQueryParam (DeviceCode Text
dc) = forall k a. k -> a -> Map k a
Map.singleton Text
"device_code" Text
dc

-- | https://www.rfc-editor.org/rfc/rfc8628#section-3.2
data DeviceAuthorizationResponse = DeviceAuthorizationResponse
  { DeviceAuthorizationResponse -> DeviceCode
deviceCode :: DeviceCode
  , DeviceAuthorizationResponse -> Text
userCode :: Text
  , DeviceAuthorizationResponse -> URI
verificationUri :: URI
  , DeviceAuthorizationResponse -> Maybe URI
verificationUriComplete :: Maybe URI
  , DeviceAuthorizationResponse -> Integer
expiresIn :: Integer
  , DeviceAuthorizationResponse -> Maybe Int
interval :: Maybe Int
  }

instance FromJSON DeviceAuthorizationResponse where
  parseJSON :: Value -> Parser DeviceAuthorizationResponse
  parseJSON :: Value -> Parser DeviceAuthorizationResponse
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"parse DeviceAuthorizationResponse" forall a b. (a -> b) -> a -> b
$ \Object
t -> do
    DeviceCode
deviceCode <- Object
t forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"device_code"
    Text
userCode <- Object
t forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user_code"
    -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho
    URI
verificationUri <- Object
t forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"verification_uri" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
t forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"verification_url"
    Maybe URI
verificationUriComplete <- Object
t forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"verification_uri_complete"
    Integer
expiresIn <- Object
t forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"expires_in"
    Maybe Int
interval <- Object
t forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"interval"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure DeviceAuthorizationResponse {Integer
Maybe Int
Maybe URI
Text
URI
DeviceCode
interval :: Maybe Int
expiresIn :: Integer
verificationUriComplete :: Maybe URI
verificationUri :: URI
userCode :: Text
deviceCode :: DeviceCode
interval :: Maybe Int
expiresIn :: Integer
verificationUriComplete :: Maybe URI
verificationUri :: URI
userCode :: Text
deviceCode :: DeviceCode
..}

data DeviceAuthorizationRequestParam = DeviceAuthorizationRequestParam
  { DeviceAuthorizationRequestParam -> Set Scope
arScope :: Set Scope
  , DeviceAuthorizationRequestParam -> Maybe ClientId
arClientId :: Maybe ClientId
  , DeviceAuthorizationRequestParam -> Map Text Text
arExtraParams :: Map Text Text
  }

instance ToQueryParam DeviceAuthorizationRequestParam where
  toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text
  toQueryParam :: DeviceAuthorizationRequestParam -> Map Text Text
toQueryParam DeviceAuthorizationRequestParam {Maybe ClientId
Map Text Text
Set Scope
arExtraParams :: Map Text Text
arClientId :: Maybe ClientId
arScope :: Set Scope
arExtraParams :: DeviceAuthorizationRequestParam -> Map Text Text
arClientId :: DeviceAuthorizationRequestParam -> Maybe ClientId
arScope :: DeviceAuthorizationRequestParam -> Set Scope
..} =
    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 Set Scope
arScope
      , forall a. ToQueryParam a => a -> Map Text Text
toQueryParam Maybe ClientId
arClientId
      , Map Text Text
arExtraParams
      ]

class HasOAuth2Key a => HasDeviceAuthorizationRequest a where
  -- | Create Device Authorization Request parameters
  -- https://www.rfc-editor.org/rfc/rfc8628#section-3.1
  mkDeviceAuthorizationRequestParam :: a -> DeviceAuthorizationRequestParam

-- TODO: There is only (possibly always only) on instance of 'HasDeviceAuthorizationRequest'
-- Maybe consider to hard-code the data type instead of use type class.

-- | Makes Device Authorization Request
-- https://www.rfc-editor.org/rfc/rfc8628#section-3.1
conduitDeviceAuthorizationRequest ::
  (MonadIO m, HasDeviceAuthorizationRequest a) =>
  IdpApplication i a ->
  Manager ->
  ExceptT BSL.ByteString m DeviceAuthorizationResponse
conduitDeviceAuthorizationRequest :: forall {k} (m :: * -> *) a (i :: k).
(MonadIO m, HasDeviceAuthorizationRequest a) =>
IdpApplication i a
-> Manager -> ExceptT ByteString m DeviceAuthorizationResponse
conduitDeviceAuthorizationRequest IdpApplication {a
Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
application :: a
idp :: Idp i
..} Manager
mgr = do
  case forall k (i :: k). Idp i -> Maybe URI
idpDeviceAuthorizationEndpoint Idp i
idp of
    Maybe URI
Nothing -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ByteString
"[conduiteDeviceAuthorizationRequest] Device Authorization Flow is not supported due to miss device_authorization_endpoint."
    Just URI
deviceAuthEndpoint -> do
      let deviceAuthReq :: DeviceAuthorizationRequestParam
deviceAuthReq = forall a.
HasDeviceAuthorizationRequest a =>
a -> DeviceAuthorizationRequestParam
mkDeviceAuthorizationRequestParam a
application
          oauth2Key :: OAuth2
oauth2Key = forall a. HasOAuth2Key a => a -> OAuth2
mkOAuth2Key a
application
          body :: [(ByteString, ByteString)]
body = [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams [forall a. ToQueryParam a => a -> Map Text Text
toQueryParam DeviceAuthorizationRequestParam
deviceAuthReq]
      forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Request
req <- Request -> Request
addDefaultRequestHeaders forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => URI -> m Request
uriToRequest URI
deviceAuthEndpoint
        -- Hacky:
        -- Missing clientId implies ClientSecretBasic authentication method.
        -- See Grant/DeviceAuthorization.hs
        let req' :: Request
req' = case DeviceAuthorizationRequestParam -> Maybe ClientId
arClientId DeviceAuthorizationRequestParam
deviceAuthReq of
              Maybe ClientId
Nothing -> OAuth2 -> Request -> Request
addBasicAuth OAuth2
oauth2Key Request
req
              Just ClientId
_ -> Request
req
        Response ByteString
resp <- forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs ([(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
body Request
req') Manager
mgr
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString
"[conduiteDeviceAuthorizationRequest] " forall a. Semigroup a => a -> a -> a
<>) forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Response ByteString -> Either ByteString a
handleResponseJSON Response ByteString
resp