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