http-conduit 2.0 support
This commit is contained in:
Michael Snoyman
parent
a971bfa8dc
commit
82a0d0d390
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
|
||||
module Web.Authenticate.OAuth
|
||||
( -- * Data types
|
||||
@ -48,6 +49,7 @@ import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Control
|
||||
import Control.Monad.Trans.Resource
|
||||
import Data.Default
|
||||
import qualified Data.IORef as I
|
||||
|
||||
-- | Data type for OAuth client (consumer).
|
||||
--
|
||||
@ -156,7 +158,11 @@ getTemporaryCredentialWithScope :: (MonadResource m, MonadBaseControl IO m)
|
||||
-> m Credential -- ^ Temporay Credential (Request Token & Secret).
|
||||
getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs)
|
||||
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
addScope :: BS.ByteString -> Request -> Request
|
||||
#else
|
||||
addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m
|
||||
#endif
|
||||
addScope scope req | BS.null scope = req
|
||||
| otherwise = urlEncodedBody [("scope", scope)] req
|
||||
|
||||
@ -169,7 +175,11 @@ getTemporaryCredentialProxy :: (MonadResource m, MonadBaseControl IO m)
|
||||
getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m
|
||||
|
||||
getTemporaryCredential' :: (MonadResource m, MonadBaseControl IO m)
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
=> (Request -> Request) -- ^ Request Hook
|
||||
#else
|
||||
=> (Request m -> Request m) -- ^ Request Hook
|
||||
#endif
|
||||
-> OAuth -- ^ OAuth Application
|
||||
-> Manager
|
||||
-> m Credential -- ^ Temporary Credential (Request Token & Secret).
|
||||
@ -225,7 +235,11 @@ getAccessTokenProxy, getTokenCredentialProxy
|
||||
getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p
|
||||
|
||||
getAccessToken' :: (MonadResource m, MonadBaseControl IO m)
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
=> (Request -> Request) -- ^ Request Hook
|
||||
#else
|
||||
=> (Request m -> Request m) -- ^ Request Hook
|
||||
#endif
|
||||
-> OAuth -- ^ OAuth Application
|
||||
-> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
|
||||
-> Manager
|
||||
@ -272,8 +286,13 @@ injectVerifier = insert "oauth_verifier"
|
||||
signOAuth :: (MonadUnsafeIO m)
|
||||
=> OAuth -- ^ OAuth Application
|
||||
-> Credential -- ^ Credential
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
-> Request -- ^ Original Request
|
||||
-> m Request -- ^ Signed OAuth Request
|
||||
#else
|
||||
-> Request m -- ^ Original Request
|
||||
-> m (Request m) -- ^ Signed OAuth Request
|
||||
#endif
|
||||
signOAuth oa crd req = do
|
||||
crd' <- addTimeStamp =<< addNonce crd
|
||||
let tok = injectOAuthToCred oa crd'
|
||||
@ -311,7 +330,11 @@ injectOAuthToCred oa cred =
|
||||
, ("oauth_version", "1.0")
|
||||
] cred
|
||||
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
genSign :: MonadUnsafeIO m => OAuth -> Credential -> Request -> m BS.ByteString
|
||||
#else
|
||||
genSign :: MonadUnsafeIO m => OAuth -> Credential -> Request m -> m BS.ByteString
|
||||
#endif
|
||||
genSign oa tok req =
|
||||
case oauthSignatureMethod oa of
|
||||
HMACSHA1 -> do
|
||||
@ -323,7 +346,11 @@ genSign oa tok req =
|
||||
RSASHA1 pr ->
|
||||
liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req)
|
||||
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
addAuthHeader :: BS.ByteString -> Credential -> Request -> Request
|
||||
#else
|
||||
addAuthHeader :: BS.ByteString -> Credential -> Request a -> Request a
|
||||
#endif
|
||||
addAuthHeader prefix (Credential cred) req =
|
||||
req { requestHeaders = insertMap "Authorization" (renderAuthHeader prefix cred) $ requestHeaders req }
|
||||
|
||||
@ -339,7 +366,11 @@ paramEncode = BS.concatMap escape
|
||||
oct = '%' : replicate (2 - length num) '0' ++ num
|
||||
in BS.pack oct
|
||||
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
getBaseString :: MonadUnsafeIO m => Credential -> Request -> m BSL.ByteString
|
||||
#else
|
||||
getBaseString :: MonadUnsafeIO m => Credential -> Request m -> m BSL.ByteString
|
||||
#endif
|
||||
getBaseString tok req = do
|
||||
let bsMtd = BS.map toUpper $ method req
|
||||
isHttps = secure req
|
||||
@ -359,6 +390,34 @@ getBaseString tok req = do
|
||||
-- So this is OK.
|
||||
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
|
||||
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
toLBS :: MonadUnsafeIO m => RequestBody -> m BS.ByteString
|
||||
toLBS (RequestBodyLBS l) = return $ toStrict l
|
||||
toLBS (RequestBodyBS s) = return s
|
||||
toLBS (RequestBodyBuilder _ b) = return $ toByteString b
|
||||
toLBS (RequestBodyStream _ givesPopper) = toLBS' givesPopper
|
||||
toLBS (RequestBodyStreamChunked givesPopper) = toLBS' givesPopper
|
||||
|
||||
type Popper = IO BS.ByteString
|
||||
type NeedsPopper a = Popper -> IO a
|
||||
type GivesPopper a = NeedsPopper a -> IO a
|
||||
|
||||
toLBS' :: MonadUnsafeIO m => GivesPopper () -> m BS.ByteString
|
||||
-- FIXME probably shouldn't be using MonadUnsafeIO
|
||||
toLBS' gp = unsafeLiftIO $ do
|
||||
ref <- I.newIORef BS.empty
|
||||
gp (go ref)
|
||||
I.readIORef ref
|
||||
where
|
||||
go ref popper =
|
||||
loop id
|
||||
where
|
||||
loop front = do
|
||||
bs <- popper
|
||||
if BS.null bs
|
||||
then I.writeIORef ref $ BS.concat $ front []
|
||||
else loop (front . (bs:))
|
||||
#else
|
||||
toLBS :: MonadUnsafeIO m => RequestBody m -> m BS.ByteString
|
||||
toLBS (RequestBodyLBS l) = return $ toStrict l
|
||||
toLBS (RequestBodyBS s) = return s
|
||||
@ -368,6 +427,7 @@ toLBS (RequestBodySourceChunked src) = toLBS' src
|
||||
|
||||
toLBS' :: MonadUnsafeIO m => Source m Builder -> m BS.ByteString
|
||||
toLBS' src = liftM BS.concat $ src $= builderToByteString $$ CL.consume
|
||||
#endif
|
||||
|
||||
isBodyFormEncoded :: [Header] -> Bool
|
||||
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"
|
||||
@ -379,5 +439,9 @@ compareTuple (a,b) (c,d) =
|
||||
EQ -> compare b d
|
||||
GT -> GT
|
||||
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
addMaybeProxy :: Maybe Proxy -> Request -> Request
|
||||
#else
|
||||
addMaybeProxy :: Maybe Proxy -> Request m -> Request m
|
||||
#endif
|
||||
addMaybeProxy p req = req { proxy = p }
|
||||
|
||||
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
|
||||
-- | This Module provides interface for the instance of 'MonadIO' instead of 'MonadIO'.
|
||||
-- What this module do is just adding 'withManager' or 'runResourceT'.
|
||||
@ -51,7 +52,11 @@ getTemporaryCredentialProxy :: MonadIO m
|
||||
getTemporaryCredentialProxy p oa = liftIO $ withManager $ OA.getTemporaryCredential' (addMaybeProxy p) oa
|
||||
|
||||
getTemporaryCredential' :: MonadIO m
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
=> (Request -> Request) -- ^ Request Hook
|
||||
#else
|
||||
=> (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ Request Hook
|
||||
#endif
|
||||
-> OAuth -- ^ OAuth Application
|
||||
-> m Credential -- ^ Temporary Credential (Request Token & Secret).
|
||||
getTemporaryCredential' hook oa = liftIO $ withManager $ OA.getTemporaryCredential' hook oa
|
||||
@ -75,7 +80,11 @@ getAccessTokenProxy, getTokenCredentialProxy
|
||||
getAccessTokenProxy p oa cr = liftIO $ withManager $ OA.getAccessTokenProxy p oa cr
|
||||
|
||||
getAccessToken' :: MonadIO m
|
||||
#if MIN_VERSION_http_conduit(2, 0, 0)
|
||||
=> (Request -> Request) -- ^ Request Hook
|
||||
#else
|
||||
=> (Request (ResourceT IO) -> Request (ResourceT IO)) -- ^ Request Hook
|
||||
#endif
|
||||
-> OAuth -- ^ OAuth Application
|
||||
-> Credential -- ^ Temporary Credential with oauth_verifier
|
||||
-> m Credential -- ^ Token Credential (Access Token & Secret)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user