diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-} +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Web.Authenticate.OAuth ( -- * Data types @@ -14,45 +15,48 @@ authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential, getTokenCredential, getTemporaryCredentialWithScope, getAccessTokenProxy, getTemporaryCredentialProxy, - getTokenCredentialProxy, + getTokenCredentialProxy, getAccessToken', getTemporaryCredential', -- * Utility Methods paramEncode, addScope, addMaybeProxy ) where -import Network.HTTP.Conduit +import Blaze.ByteString.Builder (toByteString, Builder) +import Codec.Crypto.RSA (ha_SHA1, rsassa_pkcs1_v1_5_sign) +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Crypto.Types.PubKey.RSA (PrivateKey (..), PublicKey (..)) +import Data.ByteString.Base64 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Char +import Data.Conduit (Source, ($$), ($=)) +import Data.Conduit.Blaze (builderToByteString) +import qualified Data.Conduit.List as CL +import Data.Default +import Data.Digest.Pure.SHA +import qualified Data.IORef as I +import Data.List (sortBy) +import Data.Maybe +import Data.Time +import Network.HTTP.Conduit +import Network.HTTP.Types (SimpleQuery, parseSimpleQuery) +import Network.HTTP.Types (Header) +import Network.HTTP.Types (renderSimpleQuery, status200) +import Numeric +import System.Random +#if MIN_VERSION_base(4,7,0) +import Data.Data hiding (Proxy (..)) +#else import Data.Data -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.Maybe -import Network.HTTP.Types (parseSimpleQuery, SimpleQuery) -import Control.Exception -import Control.Monad -import Data.List (sortBy) -import System.Random -import Data.Char -import Data.Digest.Pure.SHA -import Data.ByteString.Base64 -import Data.Time -import Numeric -import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1) -import Crypto.Types.PubKey.RSA (PrivateKey(..), PublicKey(..)) -import Network.HTTP.Types (Header) -import Blaze.ByteString.Builder (toByteString) -import Control.Monad.IO.Class (MonadIO) -import Network.HTTP.Types (renderSimpleQuery, status200) -import Data.Conduit (($$), ($=), Source) -import qualified Data.Conduit.List as CL -import Data.Conduit.Blaze (builderToByteString) -import Blaze.ByteString.Builder (Builder) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Control -import Control.Monad.Trans.Resource -import Data.Default +#endif -- | Data type for OAuth client (consumer). --- --- The constructor for this data type is not exposed. --- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance, +-- +-- The constructor for this data type is not exposed. +-- Instead, you should use the 'def' method or 'newOAuth' function to retrieve a default instance, -- and then use the records below to make modifications. -- This approach allows us to add configuration options without breaking backwards compatibility. data OAuth = OAuth { oauthServerName :: String -- ^ Service name (default: @\"\"@) @@ -67,7 +71,7 @@ , oauthAuthorizeUri :: String -- ^ Uri to authorize (default: @\"\"@). -- You MUST specify if you use 'authorizeUrl' or 'authorizeZUrl''; - -- otherwise you can just leave this empty. + -- otherwise you can just leave this empty. , oauthSignatureMethod :: SignMethod -- ^ Signature Method (default: 'HMACSHA1') , oauthConsumerKey :: BS.ByteString @@ -156,7 +160,11 @@ -> 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,14 +177,18 @@ 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). getTemporaryCredential' hook oa manager = do let req = fromJust $ parseUrl $ oauthRequestUri oa crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential - req' <- signOAuth oa crd $ hook (req { method = "POST" }) + req' <- signOAuth oa crd $ hook (req { method = "POST" }) rsp <- httpLbs req' manager if responseStatus rsp == status200 then do @@ -199,7 +211,7 @@ -> String -- ^ URL to authorize authorizeUrl' f oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True queries) where fixed = ("oauth_token", token cr):f oa cr - queries = + queries = case oauthCallback oa of Nothing -> fixed Just callback -> ("oauth_callback", callback):fixed @@ -225,7 +237,11 @@ 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 +288,13 @@ 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 +332,11 @@ , ("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 +348,11 @@ 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 +368,11 @@ 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 +392,34 @@ -- 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 +429,7 @@ 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 +441,9 @@ 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/Web/Authenticate/OAuth/IO.hs b/Web/Authenticate/OAuth/IO.hs --- a/Web/Authenticate/OAuth/IO.hs +++ b/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 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 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) diff --git a/authenticate-oauth.cabal b/authenticate-oauth.cabal --- a/authenticate-oauth.cabal +++ b/authenticate-oauth.cabal @@ -1,6 +1,6 @@ name: authenticate-oauth -version: 1.4.0.7 +version: 1.4.0.8 license: BSD3 license-file: LICENSE author: Hiromi Ishii