{-# 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 (Maybe DeviceCode
Value -> Parser [DeviceCode]
Value -> Parser DeviceCode
(Value -> Parser DeviceCode)
-> (Value -> Parser [DeviceCode])
-> Maybe DeviceCode
-> FromJSON DeviceCode
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser DeviceCode
parseJSON :: Value -> Parser DeviceCode
$cparseJSONList :: Value -> Parser [DeviceCode]
parseJSONList :: Value -> Parser [DeviceCode]
$comittedField :: Maybe DeviceCode
omittedField :: Maybe DeviceCode
FromJSON)

instance ToQueryParam DeviceCode where
  toQueryParam :: DeviceCode -> Map Text Text
  toQueryParam :: DeviceCode -> Map Text Text
toQueryParam (DeviceCode Text
dc) = Text -> Text -> Map Text Text
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 = String
-> (Object -> Parser DeviceAuthorizationResponse)
-> Value
-> Parser DeviceAuthorizationResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"parse DeviceAuthorizationResponse" ((Object -> Parser DeviceAuthorizationResponse)
 -> Value -> Parser DeviceAuthorizationResponse)
-> (Object -> Parser DeviceAuthorizationResponse)
-> Value
-> Parser DeviceAuthorizationResponse
forall a b. (a -> b) -> a -> b
$ \Object
t -> do
    DeviceCode
deviceCode <- Object
t Object -> Key -> Parser DeviceCode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"device_code"
    Text
userCode <- Object
t Object -> Key -> Parser Text
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 Object -> Key -> Parser URI
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"verification_uri" Parser URI -> Parser URI -> Parser URI
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Object
t Object -> Key -> Parser URI
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"verification_url"
    Maybe URI
verificationUriComplete <- Object
t Object -> Key -> Parser (Maybe URI)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"verification_uri_complete"
    Integer
expiresIn <- Object
t Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"expires_in"
    Maybe Int
interval <- Object
t Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"interval"
    DeviceAuthorizationResponse -> Parser DeviceAuthorizationResponse
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DeviceAuthorizationResponse {Integer
Maybe Int
Maybe URI
Text
URI
DeviceCode
deviceCode :: DeviceCode
userCode :: Text
verificationUri :: URI
verificationUriComplete :: Maybe URI
expiresIn :: Integer
interval :: Maybe Int
deviceCode :: DeviceCode
userCode :: Text
verificationUri :: URI
verificationUriComplete :: Maybe URI
expiresIn :: Integer
interval :: Maybe Int
..}

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
arScope :: DeviceAuthorizationRequestParam -> Set Scope
arClientId :: DeviceAuthorizationRequestParam -> Maybe ClientId
arExtraParams :: DeviceAuthorizationRequestParam -> Map Text Text
arScope :: Set Scope
arClientId :: Maybe ClientId
arExtraParams :: Map Text Text
..} =
    [Map Text Text] -> Map Text Text
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
      [ Set Scope -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam Set Scope
arScope
      , Maybe ClientId -> Map Text Text
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
idp :: Idp i
application :: a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
application :: forall k (i :: k) a. IdpApplication i a -> a
..} Manager
mgr = do
  case Idp i -> Maybe URI
forall k (i :: k). Idp i -> Maybe URI
idpDeviceAuthorizationEndpoint Idp i
idp of
    Maybe URI
Nothing -> ByteString -> ExceptT ByteString m DeviceAuthorizationResponse
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 = a -> DeviceAuthorizationRequestParam
forall a.
HasDeviceAuthorizationRequest a =>
a -> DeviceAuthorizationRequestParam
mkDeviceAuthorizationRequestParam a
application
          oauth2Key :: OAuth2
oauth2Key = a -> OAuth2
forall a. HasOAuth2Key a => a -> OAuth2
mkOAuth2Key a
application
          body :: [(ByteString, ByteString)]
body = [Map Text Text] -> [(ByteString, ByteString)]
unionMapsToQueryParams [DeviceAuthorizationRequestParam -> Map Text Text
forall a. ToQueryParam a => a -> Map Text Text
toQueryParam DeviceAuthorizationRequestParam
deviceAuthReq]
      m (Either ByteString DeviceAuthorizationResponse)
-> ExceptT ByteString m DeviceAuthorizationResponse
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ByteString DeviceAuthorizationResponse)
 -> ExceptT ByteString m DeviceAuthorizationResponse)
-> (IO (Either ByteString DeviceAuthorizationResponse)
    -> m (Either ByteString DeviceAuthorizationResponse))
-> IO (Either ByteString DeviceAuthorizationResponse)
-> ExceptT ByteString m DeviceAuthorizationResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either ByteString DeviceAuthorizationResponse)
-> m (Either ByteString DeviceAuthorizationResponse)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ByteString DeviceAuthorizationResponse)
 -> ExceptT ByteString m DeviceAuthorizationResponse)
-> IO (Either ByteString DeviceAuthorizationResponse)
-> ExceptT ByteString m DeviceAuthorizationResponse
forall a b. (a -> b) -> a -> b
$ do
        Request
req <- Request -> Request
addDefaultRequestHeaders (Request -> Request) -> IO Request -> IO Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> IO Request
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 <- Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs ([(ByteString, ByteString)] -> Request -> Request
urlEncodedBody [(ByteString, ByteString)]
body Request
req') Manager
mgr
        Either ByteString DeviceAuthorizationResponse
-> IO (Either ByteString DeviceAuthorizationResponse)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ByteString DeviceAuthorizationResponse
 -> IO (Either ByteString DeviceAuthorizationResponse))
-> Either ByteString DeviceAuthorizationResponse
-> IO (Either ByteString DeviceAuthorizationResponse)
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString)
-> Either ByteString DeviceAuthorizationResponse
-> Either ByteString DeviceAuthorizationResponse
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ByteString
"[conduiteDeviceAuthorizationRequest] " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (Either ByteString DeviceAuthorizationResponse
 -> Either ByteString DeviceAuthorizationResponse)
-> Either ByteString DeviceAuthorizationResponse
-> Either ByteString DeviceAuthorizationResponse
forall a b. (a -> b) -> a -> b
$ Response ByteString
-> Either ByteString DeviceAuthorizationResponse
forall a. FromJSON a => Response ByteString -> Either ByteString a
handleResponseJSON Response ByteString
resp