diff --git a/authenticate-oauth/Web/Authenticate/OAuth.hs b/authenticate-oauth/Web/Authenticate/OAuth.hs index c1e1d10e..87ce2f53 100644 --- a/authenticate-oauth/Web/Authenticate/OAuth.hs +++ b/authenticate-oauth/Web/Authenticate/OAuth.hs @@ -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 } diff --git a/authenticate-oauth/Web/Authenticate/OAuth/IO.hs b/authenticate-oauth/Web/Authenticate/OAuth/IO.hs index 3db6fa25..d00a537f 100644 --- a/authenticate-oauth/Web/Authenticate/OAuth/IO.hs +++ b/authenticate-oauth/Web/Authenticate/OAuth/IO.hs @@ -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)