{-# 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 <- Object
t Object -> Key -> Parser DeviceCode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"device_code"
    userCode <- t .: "user_code"
    -- https://stackoverflow.com/questions/76696956/shall-it-be-verification-uri-instead-of-verification-url-in-the-device-autho
    verificationUri <- t .: "verification_uri" <|> t .: "verification_url"
    verificationUriComplete <- t .:? "verification_uri_complete"
    expiresIn <- t .: "expires_in"
    interval <- t .:? "interval"
    pure DeviceAuthorizationResponse {..}

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
application :: forall k (i :: k) a. IdpApplication i a -> a
idp :: forall k (i :: k) a. IdpApplication i a -> Idp i
..} 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
        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' = case DeviceAuthorizationRequestParam -> Maybe ClientId
arClientId DeviceAuthorizationRequestParam
deviceAuthReq of
              Maybe ClientId
Nothing -> OAuth2 -> Request -> Request
addBasicAuth OAuth2
oauth2Key Request
req
              Just ClientId
_ -> Request
req
        resp <- httpLbs (urlEncodedBody body req') mgr
        pure $ first ("[conduiteDeviceAuthorizationRequest] " <>) $ handleResponseJSON resp