module Network.OAuth.ThreeLegged (
ThreeLegged (..), parseThreeLegged, P.Callback (..),
P.Verifier,
requestTemporaryToken, buildAuthorizationUrl, requestPermanentToken,
requestTemporaryTokenRaw, requestPermanentTokenRaw,
requestTokenProtocol, requestTokenProtocol'
) where
import Control.Applicative
import Control.Exception as E
import qualified Crypto.Random as R
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 { temporaryTokenRequest :: C.Request
, resourceOwnerAuthorization :: C.Request
, permanentTokenRequest :: C.Request
, callback :: P.Callback
}
deriving ( Show, Typeable )
parseThreeLegged :: String -> String -> String -> P.Callback -> Maybe ThreeLegged
parseThreeLegged a b c d =
ThreeLegged <$> C.parseUrl a
<*> C.parseUrl b
<*> C.parseUrl c
<*> pure d
requestTemporaryTokenRaw
:: R.CPRG gen => O.Cred O.Client -> O.Server
-> ThreeLegged -> C.Manager -> gen
-> IO (C.Response SL.ByteString, gen)
requestTemporaryTokenRaw cr srv (ThreeLegged {..}) man gen = do
(oax, gen') <- O.freshOa cr gen
let req = O.sign (oax { P.workflow = P.TemporaryTokenRequest callback }) srv temporaryTokenRequest
lbs <- C.httpLbs req man
return (lbs, gen')
requestTemporaryToken
:: R.CPRG gen => O.Cred O.Client -> O.Server
-> ThreeLegged -> C.Manager -> gen
-> IO (C.Response (Either SL.ByteString (O.Token O.Temporary)), gen)
requestTemporaryToken cr srv tl man gen = do
(raw, gen') <- requestTemporaryTokenRaw cr srv tl man gen
return (tryParseToken <$> raw, gen')
where
tryParseToken lbs = case maybeParseToken lbs of
Nothing -> Left lbs
Just tok -> Right tok
maybeParseToken lbs =
do (confirmed, tok) <- O.fromUrlEncoded $ SL.toStrict lbs
case P.oAuthVersion srv of
O.OAuthCommunity1 -> return tok
_ -> if confirmed then return tok else fail "Must be confirmed"
buildAuthorizationUrl :: O.Cred O.Temporary -> ThreeLegged -> URI
buildAuthorizationUrl cr (ThreeLegged {..}) =
C.getUri $ resourceOwnerAuthorization {
C.queryString = renderQuery True [ ("oauth_token", Just (cr ^. Cred.resourceToken . Cred.key)) ]
}
requestPermanentTokenRaw
:: R.CPRG gen => O.Cred O.Temporary -> O.Server
-> P.Verifier
-> ThreeLegged -> C.Manager -> gen
-> IO (C.Response SL.ByteString, gen)
requestPermanentTokenRaw cr srv verifier (ThreeLegged {..}) man gen = do
(oax, gen') <- O.freshOa cr gen
let req = O.sign (oax { P.workflow = P.PermanentTokenRequest verifier }) srv permanentTokenRequest
lbs <- C.httpLbs req man
return (lbs, gen')
requestPermanentToken
:: R.CPRG gen => O.Cred O.Temporary -> O.Server
-> P.Verifier
-> ThreeLegged -> C.Manager -> gen
-> IO (C.Response (Either SL.ByteString (O.Token O.Permanent)), gen)
requestPermanentToken cr srv verifier tl man gen = do
(raw, gen') <- requestPermanentTokenRaw cr srv verifier tl man gen
return (tryParseToken <$> raw, gen')
where
tryParseToken lbs = case maybeParseToken lbs of
Nothing -> Left lbs
Just tok -> Right tok
maybeParseToken = fmap snd . O.fromUrlEncoded . SL.toStrict
requestTokenProtocol'
:: C.ManagerSettings -> O.Cred O.Client -> O.Server -> ThreeLegged
-> (URI -> IO P.Verifier)
-> IO (Maybe (O.Cred O.Permanent))
requestTokenProtocol' mset cr srv tl getVerifier = do
entropy <- R.createEntropyPool
E.bracket (C.newManager mset) C.closeManager $ \man -> do
let gen = (R.cprgCreate entropy :: R.SystemRNG)
(respTempToken, gen') <- requestTemporaryToken cr srv tl man gen
case C.responseBody respTempToken of
Left _ -> return Nothing
Right tok -> do
let tempCr = O.temporaryCred tok cr
verifier <- getVerifier $ buildAuthorizationUrl tempCr tl
(respPermToken, _) <- requestPermanentToken tempCr srv verifier tl man gen'
case C.responseBody respPermToken of
Left _ -> return Nothing
Right tok' -> return (Just $ O.permanentCred tok' cr)
requestTokenProtocol
:: O.Cred O.Client -> O.Server -> ThreeLegged
-> (URI -> IO P.Verifier)
-> IO (Maybe (O.Cred O.Permanent))
requestTokenProtocol = requestTokenProtocol' C.defaultManagerSettings