{-# 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 Int -> AuthCode -> ShowS
[AuthCode] -> ShowS
AuthCode -> String
(Int -> AuthCode -> ShowS)
-> (AuthCode -> String) -> ([AuthCode] -> ShowS) -> Show AuthCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthCode] -> ShowS
$cshowList :: [AuthCode] -> ShowS
show :: AuthCode -> String
$cshow :: AuthCode -> String
showsPrec :: Int -> AuthCode -> ShowS
$cshowsPrec :: Int -> AuthCode -> ShowS
Show

convertParams :: [(Text, Text)] -> Maybe [QueryParam]
convertParams :: [(Text, Text)] -> Maybe [QueryParam]
convertParams [(Text, Text)]
qs = ((Text, Text) -> Maybe QueryParam)
-> [(Text, Text)] -> Maybe [QueryParam]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Text
k, Text
v) -> do
                RText 'QueryKey
qk <- Text -> Maybe (RText 'QueryKey)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey Text
k
                RText 'QueryValue
qv <- Text -> Maybe (RText 'QueryValue)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryValue)
mkQueryValue Text
v
                QueryParam -> Maybe QueryParam
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryParam -> Maybe QueryParam) -> QueryParam -> Maybe QueryParam
forall a b. (a -> b) -> a -> b
$ RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
qk RText 'QueryValue
qv) [(Text, Text)]
qs

buildAuthUriWithOpts :: URI -> [(Text, Text)] -> Maybe URI
buildAuthUriWithOpts :: URI -> [(Text, Text)] -> Maybe URI
buildAuthUriWithOpts URI
u [(Text, Text)]
qs = do
    [QueryParam]
qs' <- [(Text, Text)] -> Maybe [QueryParam]
convertParams [(Text, Text)]
qs
    URI -> Maybe URI
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> Maybe URI) -> URI -> Maybe URI
forall a b. (a -> b) -> a -> b
$ URI
u URI -> (URI -> URI) -> URI
forall a b. a -> (a -> b) -> b
& ([QueryParam] -> Identity [QueryParam]) -> URI -> Identity URI
Lens' URI [QueryParam]
uriQuery (([QueryParam] -> Identity [QueryParam]) -> URI -> Identity URI)
-> [QueryParam] -> URI -> URI
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [QueryParam]
qs'

-- | Gets OAuth2 authorization code
--
-- Implements standard OAuth2 authorization workflow for web server apps
-- as described <https://aaronparecki.com/oauth-2-simplified/#web-server-apps here>.
--
-- We don't bother with @redirect_uri@ or @state@ since they do not seem
-- to be required.
getAuthCode :: App -> ClientId -> PromptForCallbackUri -> IO AuthCode
getAuthCode :: App -> ClientId -> PromptForCallbackUri -> IO AuthCode
getAuthCode App
app (ClientId Text
clientId) PromptForCallbackUri
prompt = do
    let Just URI
authUriWithOpts = URI -> [(Text, Text)] -> Maybe URI
buildAuthUriWithOpts (App -> URI
appAuthUri App
app)
                                    [ (Text
"client_id", Text
clientId)
                                    , (Text
"response_type", Text
"code")
                                    , (Text
"scope", Text
"weight")
                                    ]
    URI
callbackUri <- PromptForCallbackUri
prompt URI
authUriWithOpts
    RText 'QueryKey
codeKey <- Text -> IO (RText 'QueryKey)
forall (m :: * -> *). MonadThrow m => Text -> m (RText 'QueryKey)
mkQueryKey Text
"code"
    let code :: RText 'QueryValue
code = [RText 'QueryValue] -> RText 'QueryValue
forall a. [a] -> a
head ([RText 'QueryValue] -> RText 'QueryValue)
-> [RText 'QueryValue] -> RText 'QueryValue
forall a b. (a -> b) -> a -> b
$ URI
callbackUri URI
-> Getting (Endo [RText 'QueryValue]) URI (RText 'QueryValue)
-> [RText 'QueryValue]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ([QueryParam] -> Const (Endo [RText 'QueryValue]) [QueryParam])
-> URI -> Const (Endo [RText 'QueryValue]) URI
Lens' URI [QueryParam]
uriQuery (([QueryParam] -> Const (Endo [RText 'QueryValue]) [QueryParam])
 -> URI -> Const (Endo [RText 'QueryValue]) URI)
-> ((RText 'QueryValue
     -> Const (Endo [RText 'QueryValue]) (RText 'QueryValue))
    -> [QueryParam] -> Const (Endo [RText 'QueryValue]) [QueryParam])
-> Getting (Endo [RText 'QueryValue]) URI (RText 'QueryValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RText 'QueryKey -> Traversal' [QueryParam] (RText 'QueryValue)
queryParam RText 'QueryKey
codeKey
    AuthCode -> IO AuthCode
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthCode -> IO AuthCode) -> AuthCode -> IO AuthCode
forall a b. (a -> b) -> a -> b
$ Text -> AuthCode
AuthCode (RText 'QueryValue -> Text
forall (l :: RTextLabel). RText l -> Text
unRText RText 'QueryValue
code)