{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.OAuth.ThreeLegged (
ThreeLegged (..), parseThreeLegged, P.Callback (..),
P.Verifier,
requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken,
requestTemporaryTokenRaw, requestPermanentTokenRaw,
requestTokenProtocol, requestTokenProtocol'
) where
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Random (MonadRandom)
import qualified Data.ByteString.Lazy as SL
import Data.Data
import qualified Network.HTTP.Client as C
import Network.HTTP.Types (renderQuery)
import qualified Network.OAuth as O
import Network.OAuth.MuLens
import qualified Network.OAuth.Types.Credentials as Cred
import qualified Network.OAuth.Types.Params as P
import Network.URI
data ThreeLegged =
ThreeLegged { ThreeLegged -> Request
temporaryTokenRequest :: C.Request
, ThreeLegged -> Request
resourceOwnerAuthorization :: C.Request
, ThreeLegged -> Request
permanentTokenRequest :: C.Request
, ThreeLegged -> Callback
callback :: P.Callback
}
deriving ( Int -> ThreeLegged -> ShowS
[ThreeLegged] -> ShowS
ThreeLegged -> String
(Int -> ThreeLegged -> ShowS)
-> (ThreeLegged -> String)
-> ([ThreeLegged] -> ShowS)
-> Show ThreeLegged
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreeLegged] -> ShowS
$cshowList :: [ThreeLegged] -> ShowS
show :: ThreeLegged -> String
$cshow :: ThreeLegged -> String
showsPrec :: Int -> ThreeLegged -> ShowS
$cshowsPrec :: Int -> ThreeLegged -> ShowS
Show, Typeable )
parseThreeLegged :: String -> String -> String -> P.Callback -> Maybe ThreeLegged
parseThreeLegged :: String -> String -> String -> Callback -> Maybe ThreeLegged
parseThreeLegged String
a String
b String
c Callback
d =
Request -> Request -> Request -> Callback -> ThreeLegged
ThreeLegged (Request -> Request -> Request -> Callback -> ThreeLegged)
-> Maybe Request
-> Maybe (Request -> Request -> Callback -> ThreeLegged)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
C.parseRequest String
a
Maybe (Request -> Request -> Callback -> ThreeLegged)
-> Maybe Request -> Maybe (Request -> Callback -> ThreeLegged)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
C.parseRequest String
b
Maybe (Request -> Callback -> ThreeLegged)
-> Maybe Request -> Maybe (Callback -> ThreeLegged)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Maybe Request
forall (m :: * -> *). MonadThrow m => String -> m Request
C.parseRequest String
c
Maybe (Callback -> ThreeLegged)
-> Maybe Callback -> Maybe ThreeLegged
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Callback -> Maybe Callback
forall (f :: * -> *) a. Applicative f => a -> f a
pure Callback
d
requestTemporaryTokenRaw
:: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server
-> ThreeLegged -> C.Manager
-> m(C.Response SL.ByteString)
requestTemporaryTokenRaw :: Cred Client
-> Server -> ThreeLegged -> Manager -> m (Response ByteString)
requestTemporaryTokenRaw Cred Client
cr Server
srv (ThreeLegged {Request
Callback
callback :: Callback
permanentTokenRequest :: Request
resourceOwnerAuthorization :: Request
temporaryTokenRequest :: Request
callback :: ThreeLegged -> Callback
permanentTokenRequest :: ThreeLegged -> Request
resourceOwnerAuthorization :: ThreeLegged -> Request
temporaryTokenRequest :: ThreeLegged -> Request
..}) Manager
man = do
Oa Client
oax <- Cred Client -> m (Oa Client)
forall (m :: * -> *) ty.
(MonadRandom m, MonadIO m) =>
Cred ty -> m (Oa ty)
O.freshOa Cred Client
cr
let req :: Request
req = Oa Client -> Server -> Request -> Request
forall ty. Oa ty -> Server -> Request -> Request
O.sign (Oa Client
oax { workflow :: Workflow
P.workflow = Callback -> Workflow
P.TemporaryTokenRequest Callback
callback }) Server
srv Request
temporaryTokenRequest
IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
C.httpLbs Request
req Manager
man
requestTemporaryToken
:: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server
-> ThreeLegged -> C.Manager
-> m (C.Response (Either SL.ByteString (O.Token O.Temporary)))
requestTemporaryToken :: Cred Client
-> Server
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Temporary)))
requestTemporaryToken Cred Client
cr Server
srv ThreeLegged
tl Manager
man = do
Response ByteString
raw <- Cred Client
-> Server -> ThreeLegged -> Manager -> m (Response ByteString)
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Client
-> Server -> ThreeLegged -> Manager -> m (Response ByteString)
requestTemporaryTokenRaw Cred Client
cr Server
srv ThreeLegged
tl Manager
man
Response (Either ByteString (Token Temporary))
-> m (Response (Either ByteString (Token Temporary)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Response (Either ByteString (Token Temporary))
-> m (Response (Either ByteString (Token Temporary))))
-> Response (Either ByteString (Token Temporary))
-> m (Response (Either ByteString (Token Temporary)))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Token Temporary)
forall ty. ByteString -> Either ByteString (Token ty)
tryParseToken (ByteString -> Either ByteString (Token Temporary))
-> Response ByteString
-> Response (Either ByteString (Token Temporary))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString
raw
where
tryParseToken :: ByteString -> Either ByteString (Token ty)
tryParseToken ByteString
lbs = case ByteString -> Maybe (Token ty)
forall ty. ByteString -> Maybe (Token ty)
maybeParseToken ByteString
lbs of
Maybe (Token ty)
Nothing -> ByteString -> Either ByteString (Token ty)
forall a b. a -> Either a b
Left ByteString
lbs
Just Token ty
tok -> Token ty -> Either ByteString (Token ty)
forall a b. b -> Either a b
Right Token ty
tok
maybeParseToken :: ByteString -> Maybe (Token ty)
maybeParseToken ByteString
lbs =
do (Bool
confirmed, Token ty
tok) <- ByteString -> Maybe (Bool, Token ty)
forall ty. ByteString -> Maybe (Bool, Token ty)
O.fromUrlEncoded (ByteString -> Maybe (Bool, Token ty))
-> ByteString -> Maybe (Bool, Token ty)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
SL.toStrict ByteString
lbs
case Server -> Version
P.oAuthVersion Server
srv of
Version
O.OAuthCommunity1 -> Token ty -> Maybe (Token ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Token ty
tok
Version
_ -> if Bool
confirmed then Token ty -> Maybe (Token ty)
forall (m :: * -> *) a. Monad m => a -> m a
return Token ty
tok else String -> Maybe (Token ty)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Must be confirmed"
buildAuthorizationUrl :: O.Cred O.Temporary -> ThreeLegged -> URI
buildAuthorizationUrl :: Cred Temporary -> ThreeLegged -> URI
buildAuthorizationUrl Cred Temporary
cr (ThreeLegged {Request
Callback
callback :: Callback
permanentTokenRequest :: Request
resourceOwnerAuthorization :: Request
temporaryTokenRequest :: Request
callback :: ThreeLegged -> Callback
permanentTokenRequest :: ThreeLegged -> Request
resourceOwnerAuthorization :: ThreeLegged -> Request
temporaryTokenRequest :: ThreeLegged -> Request
..}) =
Request -> URI
C.getUri (Request -> URI) -> Request -> URI
forall a b. (a -> b) -> a -> b
$ Request
resourceOwnerAuthorization {
queryString :: ByteString
C.queryString = Bool -> Query -> ByteString
renderQuery Bool
True [ (ByteString
"oauth_token", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Cred Temporary
cr Cred Temporary
-> ((ByteString -> Constant ByteString ByteString)
-> Cred Temporary -> Constant ByteString (Cred Temporary))
-> ByteString
forall s a. s -> ((a -> Constant a a) -> s -> Constant a s) -> a
^. (Token Temporary -> Constant ByteString (Token Temporary))
-> Cred Temporary -> Constant ByteString (Cred Temporary)
forall ty ty' (f :: * -> *).
(ResourceToken ty, ResourceToken ty', Functor f) =>
(Token ty -> f (Token ty')) -> Cred ty -> f (Cred ty')
Cred.resourceToken ((Token Temporary -> Constant ByteString (Token Temporary))
-> Cred Temporary -> Constant ByteString (Cred Temporary))
-> ((ByteString -> Constant ByteString ByteString)
-> Token Temporary -> Constant ByteString (Token Temporary))
-> (ByteString -> Constant ByteString ByteString)
-> Cred Temporary
-> Constant ByteString (Cred Temporary)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Constant ByteString ByteString)
-> Token Temporary -> Constant ByteString (Token Temporary)
forall (f :: * -> *) ty.
Functor f =>
(ByteString -> f ByteString) -> Token ty -> f (Token ty)
Cred.key)) ]
}
requestPermanentTokenRaw
:: (MonadIO m, MonadRandom m) => O.Cred O.Temporary -> O.Server
-> P.Verifier
-> ThreeLegged -> C.Manager
-> m (C.Response SL.ByteString)
requestPermanentTokenRaw :: Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response ByteString)
requestPermanentTokenRaw Cred Temporary
cr Server
srv ByteString
verifier (ThreeLegged {Request
Callback
callback :: Callback
permanentTokenRequest :: Request
resourceOwnerAuthorization :: Request
temporaryTokenRequest :: Request
callback :: ThreeLegged -> Callback
permanentTokenRequest :: ThreeLegged -> Request
resourceOwnerAuthorization :: ThreeLegged -> Request
temporaryTokenRequest :: ThreeLegged -> Request
..}) Manager
man = do
Oa Temporary
oax <- Cred Temporary -> m (Oa Temporary)
forall (m :: * -> *) ty.
(MonadRandom m, MonadIO m) =>
Cred ty -> m (Oa ty)
O.freshOa Cred Temporary
cr
let req :: Request
req = Oa Temporary -> Server -> Request -> Request
forall ty. Oa ty -> Server -> Request -> Request
O.sign (Oa Temporary
oax { workflow :: Workflow
P.workflow = ByteString -> Workflow
P.PermanentTokenRequest ByteString
verifier }) Server
srv Request
permanentTokenRequest
IO (Response ByteString) -> m (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
C.httpLbs Request
req Manager
man
requestPermanentToken
:: (MonadIO m, MonadRandom m) => O.Cred O.Temporary -> O.Server
-> P.Verifier
-> ThreeLegged -> C.Manager
-> m (C.Response (Either SL.ByteString (O.Token O.Permanent)))
requestPermanentToken :: Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Permanent)))
requestPermanentToken Cred Temporary
cr Server
srv ByteString
verifier ThreeLegged
tl Manager
man = do
Response ByteString
raw <- Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response ByteString)
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response ByteString)
requestPermanentTokenRaw Cred Temporary
cr Server
srv ByteString
verifier ThreeLegged
tl Manager
man
Response (Either ByteString (Token Permanent))
-> m (Response (Either ByteString (Token Permanent)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Response (Either ByteString (Token Permanent))
-> m (Response (Either ByteString (Token Permanent))))
-> Response (Either ByteString (Token Permanent))
-> m (Response (Either ByteString (Token Permanent)))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString (Token Permanent)
forall ty. ByteString -> Either ByteString (Token ty)
tryParseToken (ByteString -> Either ByteString (Token Permanent))
-> Response ByteString
-> Response (Either ByteString (Token Permanent))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response ByteString
raw
where
tryParseToken :: ByteString -> Either ByteString (Token ty)
tryParseToken ByteString
lbs = case ByteString -> Maybe (Token ty)
forall ty. ByteString -> Maybe (Token ty)
maybeParseToken ByteString
lbs of
Maybe (Token ty)
Nothing -> ByteString -> Either ByteString (Token ty)
forall a b. a -> Either a b
Left ByteString
lbs
Just Token ty
tok -> Token ty -> Either ByteString (Token ty)
forall a b. b -> Either a b
Right Token ty
tok
maybeParseToken :: ByteString -> Maybe (Token ty)
maybeParseToken = ((Bool, Token ty) -> Token ty)
-> Maybe (Bool, Token ty) -> Maybe (Token ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool, Token ty) -> Token ty
forall a b. (a, b) -> b
snd (Maybe (Bool, Token ty) -> Maybe (Token ty))
-> (ByteString -> Maybe (Bool, Token ty))
-> ByteString
-> Maybe (Token ty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Bool, Token ty)
forall ty. ByteString -> Maybe (Bool, Token ty)
O.fromUrlEncoded (ByteString -> Maybe (Bool, Token ty))
-> (ByteString -> ByteString)
-> ByteString
-> Maybe (Bool, Token ty)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SL.toStrict
requestTokenProtocol'
:: (MonadIO m, MonadRandom m) => C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged
-> (URI -> m P.Verifier)
-> m (Maybe (O.Cred O.Permanent))
requestTokenProtocol' :: ManagerSettings
-> Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
requestTokenProtocol' ManagerSettings
mset Cred Client
cr Server
srv ThreeLegged
tl URI -> m ByteString
getVerifier = do
Manager
man <- IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
C.newManager ManagerSettings
mset
Response (Either ByteString (Token Temporary))
respTempToken <- Cred Client
-> Server
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Temporary)))
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Client
-> Server
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Temporary)))
requestTemporaryToken Cred Client
cr Server
srv ThreeLegged
tl Manager
man
case Response (Either ByteString (Token Temporary))
-> Either ByteString (Token Temporary)
forall body. Response body -> body
C.responseBody Response (Either ByteString (Token Temporary))
respTempToken of
Left ByteString
_ -> Maybe (Cred Permanent) -> m (Maybe (Cred Permanent))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Cred Permanent)
forall a. Maybe a
Nothing
Right Token Temporary
tok -> do
let tempCr :: Cred Temporary
tempCr = Token Temporary -> Cred Client -> Cred Temporary
O.temporaryCred Token Temporary
tok Cred Client
cr
ByteString
verifier <- URI -> m ByteString
getVerifier (URI -> m ByteString) -> URI -> m ByteString
forall a b. (a -> b) -> a -> b
$ Cred Temporary -> ThreeLegged -> URI
buildAuthorizationUrl Cred Temporary
tempCr ThreeLegged
tl
Response (Either ByteString (Token Permanent))
respPermToken <- Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Permanent)))
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
Cred Temporary
-> Server
-> ByteString
-> ThreeLegged
-> Manager
-> m (Response (Either ByteString (Token Permanent)))
requestPermanentToken Cred Temporary
tempCr Server
srv ByteString
verifier ThreeLegged
tl Manager
man
case Response (Either ByteString (Token Permanent))
-> Either ByteString (Token Permanent)
forall body. Response body -> body
C.responseBody Response (Either ByteString (Token Permanent))
respPermToken of
Left ByteString
_ -> Maybe (Cred Permanent) -> m (Maybe (Cred Permanent))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Cred Permanent)
forall a. Maybe a
Nothing
Right Token Permanent
tok' -> Maybe (Cred Permanent) -> m (Maybe (Cred Permanent))
forall (m :: * -> *) a. Monad m => a -> m a
return (Cred Permanent -> Maybe (Cred Permanent)
forall a. a -> Maybe a
Just (Cred Permanent -> Maybe (Cred Permanent))
-> Cred Permanent -> Maybe (Cred Permanent)
forall a b. (a -> b) -> a -> b
$ Token Permanent -> Cred Client -> Cred Permanent
O.permanentCred Token Permanent
tok' Cred Client
cr)
requestTokenProtocol
:: (MonadIO m, MonadRandom m) => O.Cred O.Client -> O.Server -> ThreeLegged
-> (URI -> m P.Verifier)
-> m (Maybe (O.Cred O.Permanent))
requestTokenProtocol :: Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
requestTokenProtocol = ManagerSettings
-> Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
forall (m :: * -> *).
(MonadIO m, MonadRandom m) =>
ManagerSettings
-> Cred Client
-> Server
-> ThreeLegged
-> (URI -> m ByteString)
-> m (Maybe (Cred Permanent))
requestTokenProtocol' ManagerSettings
C.defaultManagerSettings