{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.Req.OAuth2.Internal.AuthCode
( AuthCode(..)
, PromptForCallbackUri
, getAuthCode
) where
import Control.Lens ((^..), (.~), (&))
import Data.Text (Text)
import Network.HTTP.Req.OAuth2.Internal.Types
import Text.URI (QueryParam(..), URI, mkQueryKey, mkQueryValue, unRText)
import Text.URI.Lens (queryParam, uriQuery)
type PromptForCallbackUri = URI -> IO URI
newtype AuthCode = AuthCode Text deriving Show
convertParams :: [(Text, Text)] -> Maybe [QueryParam]
convertParams qs = mapM (\(k, v) -> do
qk <- mkQueryKey k
qv <- mkQueryValue v
return $ QueryParam qk qv) qs
buildAuthUriWithOpts :: URI -> [(Text, Text)] -> Maybe URI
buildAuthUriWithOpts u qs = do
qs' <- convertParams qs
return $ u & uriQuery .~ qs'
getAuthCode :: App -> ClientId -> PromptForCallbackUri -> IO AuthCode
getAuthCode app (ClientId clientId) prompt = do
let Just authUriWithOpts = buildAuthUriWithOpts (appAuthUri app)
[ ("client_id", clientId)
, ("response_type", "code")
, ("scope", "weight")
]
callbackUri <- prompt authUriWithOpts
codeKey <- mkQueryKey "code"
let code = head $ callbackUri ^.. uriQuery . queryParam codeKey
return $ AuthCode (unRText code)