authenticate-oauth 1.4.0.8 → 1.7
raw patch · 5 files changed
Files
- ChangeLog.md +21/−0
- README.md +3/−0
- Web/Authenticate/OAuth.hs +433/−195
- Web/Authenticate/OAuth/IO.hs +10/−19
- authenticate-oauth.cabal +13/−15
+ ChangeLog.md view
@@ -0,0 +1,21 @@+## 1.7++* Add support for following new SignMethod `HMACSHA256`, `HMACSHA512`, `RSASHA256`, `RSASHA512`++## 1.6++* Add checkOAuth+* Add support for [oauth_body_hash extension](https://oauth.googlecode.com/svn/spec/ext/body_hash/1.0/oauth-bodyhash.html)+ in `checkOAuth` and `signOAuth`; this might have slightly changed `checkOAuth` behavior.++## 1.5.1.2++* Allow newest transformers++## 1.5.1++* [Add getAccessTokenWith #42](https://github.com/yesodweb/authenticate/pull/42)++## 1.5.0.2++* [Allow RSA-2.1 #41](https://github.com/yesodweb/authenticate/pull/41)
+ README.md view
@@ -0,0 +1,3 @@+## authenticate-oauth++OAuth authentication, e.g. Twitter.
Web/Authenticate/OAuth.hs view
@@ -1,47 +1,60 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings, StandaloneDeriving #-}-{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Web.Authenticate.OAuth ( -- * Data types OAuth, def, newOAuth, oauthServerName, oauthRequestUri, oauthAccessTokenUri, oauthAuthorizeUri, oauthSignatureMethod, oauthConsumerKey, oauthConsumerSecret, oauthCallback, oauthRealm, oauthVersion, OAuthVersion(..), SignMethod(..), Credential(..), OAuthException(..),+ -- ** Access token request+ AccessTokenRequest,+ defaultAccessTokenRequest,+ accessTokenAddAuth,+ accessTokenRequestHook,+ accessTokenOAuth,+ accessTokenTemporaryCredential,+ accessTokenManager, -- * Operations for credentials newCredential, emptyCredential, insert, delete, inserts, injectVerifier, -- * Signature- signOAuth, genSign,+ signOAuth, genSign, checkOAuth, -- * Url & operation for authentication- authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential,- getTokenCredential, getTemporaryCredentialWithScope,- getAccessTokenProxy, getTemporaryCredentialProxy,+ -- ** Temporary credentials+ getTemporaryCredential, getTemporaryCredentialWithScope,+ getTemporaryCredentialProxy, getTemporaryCredential',+ -- ** Authorization URL+ authorizeUrl, authorizeUrl',+ -- ** Attaching auth to requests+ addAuthBody,+ -- ** Finishing authentication+ getAccessToken,+ getAccessTokenProxy,+ getTokenCredential, getTokenCredentialProxy,- getAccessToken', getTemporaryCredential',+ getAccessToken',+ getAccessTokenWith, -- * Utility Methods paramEncode, addScope, addMaybeProxy ) where-import Blaze.ByteString.Builder (toByteString, Builder)-import Codec.Crypto.RSA (ha_SHA1, rsassa_pkcs1_v1_5_sign)++import Blaze.ByteString.Builder (toByteString) import Control.Exception+import Control.Arrow (second) 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 Control.Monad.Trans.Except+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.List as List (sort, find) import Data.Maybe import Data.Time-import Network.HTTP.Conduit+import Network.HTTP.Client import Network.HTTP.Types (SimpleQuery, parseSimpleQuery) import Network.HTTP.Types (Header) import Network.HTTP.Types (renderSimpleQuery, status200)@@ -52,7 +65,13 @@ #else import Data.Data #endif+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1, hashSHA256, hashSHA512) ++----------------------------------------------------------------------+-- Data types++ -- | Data type for OAuth client (consumer). -- -- The constructor for this data type is not exposed.@@ -66,7 +85,7 @@ -- or 'getTemporaryCredential'; otherwise you can just leave this empty. , oauthAccessTokenUri :: String -- ^ Uri to obtain access token (default: @\"\"@).- -- You MUST specify if you use 'getAcessToken' or 'getAccessToken'';+ -- You MUST specify if you use 'getAcessToken' or 'getAccessToken'' or 'getAccessTokenWith'; -- otherwise you can just leave this empty. , oauthAuthorizeUri :: String -- ^ Uri to authorize (default: @\"\"@).@@ -84,12 +103,14 @@ -- ^ Optional authorization realm (default: @Nothing@) , oauthVersion :: OAuthVersion -- ^ OAuth spec version (default: 'OAuth10a')- } deriving (Show, Eq, Ord, Read, Data, Typeable)+ } deriving (Show, Eq, Read, Data, Typeable) + data OAuthVersion = OAuth10 -- ^ OAuth protocol ver 1.0 (no oauth_verifier; differs from RFC 5849). | OAuth10a -- ^ OAuth protocol ver 1.0a. This corresponds to community's 1.0a spec and RFC 5849.- deriving (Show, Eq, Ord, Data, Typeable, Read)+ deriving (Show, Eq, Enum, Ord, Data, Typeable, Read) + -- | Default value for OAuth datatype. -- You must specify at least oauthServerName, URIs and Tokens. newOAuth :: OAuth@@ -108,100 +129,312 @@ instance Default OAuth where def = newOAuth + -- | Data type for signature method. data SignMethod = PLAINTEXT | HMACSHA1+ | HMACSHA256+ | HMACSHA512 | RSASHA1 PrivateKey- deriving (Show, Eq, Ord, Read, Data, Typeable)-deriving instance Ord PrivateKey-deriving instance Ord PublicKey+ | RSASHA256 PrivateKey+ | RSASHA512 PrivateKey+ deriving (Show, Eq, Read, Data, Typeable) --- | Data type for redential.-data Credential = Credential { unCredential :: [(BS.ByteString, BS.ByteString)] }- deriving (Show, Eq, Ord, Read, Data, Typeable) --- | Empty credential.-emptyCredential :: Credential-emptyCredential = Credential []+newtype OAuthException = OAuthException String+ deriving (Show, Eq, Data, Typeable) +instance Exception OAuthException+++-- | Data type for getAccessTokenWith method.+--+-- You can create values of this type using 'defaultAccessTokenRequest'.+--+-- Since 1.5.1+data AccessTokenRequest = AccessTokenRequest {+ accessTokenAddAuth :: (BS.ByteString -> Credential -> Request -> Request)+ -- ^ add auth hook.+ --+ -- Default: addAuthHeader+ --+ -- Since 1.5.1+ , accessTokenRequestHook :: (Request -> Request)+ -- ^ Request Hook.+ --+ -- Default: @id@+ --+ -- Since 1.5.1+ , accessTokenOAuth :: OAuth+ -- ^ OAuth Application+ --+ -- Since 1.5.1+ , accessTokenTemporaryCredential :: Credential+ -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)+ --+ -- Since 1.5.1+ , accessTokenManager :: Manager+ -- ^ Manager+ --+ -- Since 1.5.1+ }++-- | Create a value of type 'AccessTokenRequest' with default values filled in.+--+-- Note that this is a settings type. More information on usage can be found+-- at: <http://www.yesodweb.com/book/settings-types>.+--+-- Since 1.5.1+defaultAccessTokenRequest :: OAuth -> Credential -> Manager -> AccessTokenRequest+defaultAccessTokenRequest oauth cred man = AccessTokenRequest+ { accessTokenAddAuth = addAuthHeader+ , accessTokenRequestHook = id+ , accessTokenOAuth = oauth+ , accessTokenTemporaryCredential = cred+ , accessTokenManager = man+ }++----------------------------------------------------------------------+-- Credentials+++-- | Data type for credential.+newtype Credential = Credential -- we can easily change it back to "data" later if needed, right?+ { unCredential :: [(BS.ByteString, BS.ByteString)] }+ deriving (Show, Eq, Ord, Read, Data, Typeable)++ -- | Convenient function to create 'Credential' with OAuth Token and Token Secret. newCredential :: BS.ByteString -- ^ value for oauth_token -> BS.ByteString -- ^ value for oauth_token_secret -> Credential newCredential tok sec = Credential [("oauth_token", tok), ("oauth_token_secret", sec)] -token, tokenSecret :: Credential -> BS.ByteString-token = fromMaybe "" . lookup "oauth_token" . unCredential-tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential -data OAuthException = OAuthException String- deriving (Show, Eq, Data, Typeable)+-- | Empty credential.+emptyCredential :: Credential+emptyCredential = Credential [] -instance Exception OAuthException -toStrict :: BSL.ByteString -> BS.ByteString-toStrict = BS.concat . BSL.toChunks+-- | Insert an oauth parameter into given 'Credential'.+insert :: BS.ByteString -- ^ Parameter Name+ -> BS.ByteString -- ^ Value+ -> Credential -- ^ Credential+ -> Credential -- ^ Result+insert k v = Credential . insertMap k v . unCredential -fromStrict :: BS.ByteString -> BSL.ByteString-fromStrict = BSL.fromChunks . return +-- | Convenient method for inserting multiple parameters into credential.+inserts :: [(BS.ByteString, BS.ByteString)] -> Credential -> Credential+inserts = flip $ foldr (uncurry insert)+++-- | Remove an oauth parameter for key from given 'Credential'.+delete :: BS.ByteString -- ^ Parameter name+ -> Credential -- ^ Credential+ -> Credential -- ^ Result+delete key = Credential . deleteMap key . unCredential+++-- | Insert @oauth-verifier@ on a 'Credential'.+injectVerifier :: BS.ByteString -> Credential -> Credential+injectVerifier = insert "oauth_verifier"+++----------------------------------------------------------------------+-- Signature++-- | Add OAuth headers & sign to 'Request'.+signOAuth :: MonadIO m+ => OAuth -- ^ OAuth Application+ -> Credential -- ^ Credential+ -> Request -- ^ Original Request+ -> m Request -- ^ Signed OAuth Request+signOAuth oa crd req = signOAuth' oa crd True addAuthHeader req++-- | More flexible signOAuth+signOAuth' :: MonadIO m+ => OAuth -- ^ OAuth Application+ -> Credential -- ^ Credential+ -> Bool -- ^ whether to insert oauth_body_hash or not+ -> (BS.ByteString -> Credential -> Request -> Request) -- ^ signature style+ -> Request -- ^ Original Request+ -> m Request -- ^ Signed OAuth Request+signOAuth' oa crd withHash add_auth req = do+ crd' <- addTimeStamp =<< addNonce crd+ mhash <- moauth_body_hash+ let tok = addHashToCred mhash $ injectOAuthToCred oa crd'+ sign <- genSign oa tok req+ let prefix = case oauthRealm oa of+ Nothing -> "OAuth "+ Just v -> "OAuth realm=\"" `BS.append` v `BS.append` "\","+ return $ add_auth prefix+ (insert "oauth_signature" sign tok)+ req+ where -- adding extension https://oauth.googlecode.com/svn/spec/ext/body_hash/1.0/oauth-bodyhash.html+ moauth_body_hash = if not withHash || isBodyFormEncoded (requestHeaders req)+ then return Nothing+ else (Just+ . encode+ . BSL.toStrict+ . bytestringDigest+ . sha1+ . BSL.fromStrict) `liftM` loadBodyBS req+ -- encodeHash (Just h) = "oauth_body_hash=\"" `BS.append` paramEncode h `BS.append` "\","+ -- encodeHash Nothing = ""+ addHashToCred (Just h) = insert "oauth_body_hash" h+ addHashToCred Nothing = id+++-- | Generate OAuth signature. Used by 'signOAuth'.+genSign :: MonadIO m => OAuth -> Credential -> Request -> m BS.ByteString+genSign oa tok req =+ case oauthSignatureMethod oa of+ HMACSHA1 -> do+ text <- getBaseString tok req+ let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+ return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text+ HMACSHA256 -> do+ text <- getBaseString tok req+ let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+ return $ encode $ toStrict $ bytestringDigest $ hmacSha256 (fromStrict key) text+ HMACSHA512 -> do+ text <- getBaseString tok req+ let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+ return $ encode $ toStrict $ bytestringDigest $ hmacSha512 (fromStrict key) text+ PLAINTEXT ->+ return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]+ RSASHA1 pr ->+ liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA1 pr) (getBaseString tok req)+ RSASHA256 pr ->+ liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA256 pr) (getBaseString tok req)+ RSASHA512 pr ->+ liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign hashSHA512 pr) (getBaseString tok req)++-- | Test existing OAuth signature.+-- Since 1.5.2+checkOAuth :: MonadIO m+ => OAuth -> Credential -> Request+ -> ExceptT OAuthException m Request+checkOAuth oa crd req = if isBodyFormEncoded origHeaders then checkOAuthB oa crd req else do+ case mosig of+ Nothing -> throwE $ OAuthException "oauth_signature parameter not found"+ Just osig -> do+ mhash <- moauth_body_hash+ case (\oh nh -> oh == paramEncode nh) `liftM` moauth_body_hash_orig `ap` mhash of+ Just False -> throwE $ OAuthException "Failed test of oauth_body_hash"+ _ -> let tok = addHashToCred mhash . injectOAuthToCred oa $ inserts (remParams authParams) crd+ in genSign oa tok req+ {requestHeaders = catMaybes [mtypeHeader]}+ >>= \nsig -> if osig == paramEncode nsig+ then return req+ else throwE $ OAuthException "Failed test of oauth_signature"+ where+ origHeaders = requestHeaders req+ mauthHeader = List.find ( ("Authorization" ==) . fst) $ origHeaders+ mtypeHeader = List.find ( ("Content-Type" ==) . fst) $ origHeaders+ authParams = (map parseParam . BS.split ',' . BS.drop 6 . snd) `liftM` mauthHeader+ remParams Nothing = []+ remParams (Just ms) = filter ( not . flip elem+ ("realm" : "oauth_signature" : map fst (unCredential crd))+ . fst) ms+ mosig = fmap snd . join $ List.find (("oauth_signature" ==) . fst) `liftM` authParams+ parseParam = second (BS.takeWhile ('"' /=) . BS.drop 1 . BS.dropWhile ('"' /=))+ . splitEq . BS.dropWhile (' ' ==)+ splitEq s = case BS.elemIndex '=' s of+ Nothing -> (s,"")+ Just i -> BS.splitAt i s+ moauth_body_hash_orig = join $ (fmap snd . List.find ( ("oauth_body_hash" ==) . fst)) `liftM` authParams+ moauth_body_hash = if moauth_body_hash_orig == Nothing+ then return Nothing+ else (Just+ . encode+ . BSL.toStrict+ . bytestringDigest+ . sha1+ . BSL.fromStrict) `liftM` loadBodyBS req+ addHashToCred (Just h) = insert "oauth_body_hash" h+ addHashToCred Nothing = id++checkOAuthB :: MonadIO m+ => OAuth -> Credential -> Request+ -> ExceptT OAuthException m Request+checkOAuthB oa crd req0 = do+ (mosig, reqBody) <- getSig `liftM` loadBodyBS req0+ let req = req0 {requestBody = RequestBodyBS reqBody}+ case mosig of+ "" -> throwE $ OAuthException "oauth_signature parameter not found"+ osig -> do+ nsig <- genSign oa crd req+ if osig == paramEncode nsig+ then return req0+ else throwE $ OAuthException "Failed test of oauth_signature"+ where+ getSig b = let (h1 , r ) = BS.breakSubstring "&oauth_signature=" b+ (sig, h2) = BS.breakSubstring "&" $ BS.drop 17 r+ in (sig, h1 `BS.append` h2)++++----------------------------------------------------------------------+-- Temporary credentails++ -- | Get temporary credential for requesting acces token.-getTemporaryCredential :: (MonadResource m, MonadBaseControl IO m)+getTemporaryCredential :: MonadIO m => OAuth -- ^ OAuth Application -> Manager -> m Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredential = getTemporaryCredential' id + -- | Get temporary credential for requesting access token with Scope parameter.-getTemporaryCredentialWithScope :: (MonadResource m, MonadBaseControl IO m)+getTemporaryCredentialWithScope :: MonadIO m => BS.ByteString -- ^ Scope parameter string -> OAuth -- ^ OAuth Application -> Manager -> 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 -- | Get temporary credential for requesting access token via the proxy.-getTemporaryCredentialProxy :: (MonadResource m, MonadBaseControl IO m)+getTemporaryCredentialProxy :: MonadIO m => Maybe Proxy -- ^ Proxy -> OAuth -- ^ OAuth Application -> Manager -> m Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m -getTemporaryCredential' :: (MonadResource m, MonadBaseControl IO m)-#if MIN_VERSION_http_conduit(2, 0, 0)++getTemporaryCredential' :: MonadIO m => (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" })- rsp <- httpLbs req' manager+ req' <- signOAuth' oa crd False addAuthHeader $ hook (req { method = "POST" })+ rsp <- liftIO $ httpLbs req' manager if responseStatus rsp == status200 then do let dic = parseSimpleQuery . toStrict . responseBody $ rsp return $ Credential dic- else liftIO . throwIO . OAuthException $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp)+ else liftIO . throwIO . OAuthException+ $ "Gaining OAuth Temporary Credential Failed: " ++ BSL.unpack (responseBody rsp) ++----------------------------------------------------------------------+-- Authorization URL++ -- | URL to obtain OAuth verifier. authorizeUrl :: OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential (Request Token & Secret) -> String -- ^ URL to authorize authorizeUrl = authorizeUrl' $ \oa -> const [("oauth_consumer_key", oauthConsumerKey oa)] + -- | Convert OAuth and Credential to URL to authorize. -- This takes function to choice parameter to pass to the server other than -- /oauth_callback/ or /oauth_token/.@@ -217,18 +450,23 @@ Just callback -> ("oauth_callback", callback):fixed +----------------------------------------------------------------------+-- Finishing authentication++ -- | Get Access token. getAccessToken, getTokenCredential- :: (MonadResource m, MonadBaseControl IO m)+ :: MonadIO m => OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) -> Manager -> m Credential -- ^ Token Credential (Access Token & Secret) getAccessToken = getAccessToken' id + -- | Get Access token via the proxy. getAccessTokenProxy, getTokenCredentialProxy- :: (MonadResource m, MonadBaseControl IO m)+ :: MonadIO m => Maybe Proxy -- ^ Proxy -> OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)@@ -236,75 +474,53 @@ -> m Credential -- ^ Token Credential (Access Token & Secret) getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p -getAccessToken' :: (MonadResource m, MonadBaseControl IO m)-#if MIN_VERSION_http_conduit(2, 0, 0)+getAccessToken' :: MonadIO m => (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 -> m Credential -- ^ Token Credential (Access Token & Secret)-getAccessToken' hook oa cr manager = do- let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }- rsp <- flip httpLbs manager =<< signOAuth oa (if oauthVersion oa == OAuth10 then delete "oauth_verifier" cr else cr) req- if responseStatus rsp == status200- then do- let dic = parseSimpleQuery . toStrict . responseBody $ rsp- return $ Credential dic- else liftIO . throwIO . OAuthException $ "Gaining OAuth Token Credential Failed: " ++ BSL.unpack (responseBody rsp)+getAccessToken' hook oauth cr manager = do+ maybe_access_token <- getAccessTokenWith AccessTokenRequest+ { accessTokenAddAuth = addAuthHeader+ , accessTokenRequestHook = hook+ , accessTokenOAuth = oauth+ , accessTokenTemporaryCredential = cr+ , accessTokenManager = manager+ }+ case maybe_access_token of+ Left error_response -> liftIO . throwIO . OAuthException+ $ "Gaining OAuth Token Credential Failed: "+ ++ BSL.unpack (responseBody error_response)+ Right access_token -> return access_token +getAccessTokenWith :: MonadIO m+ => AccessTokenRequest -- ^ extensible parameters+ -> m (Either (Response BSL.ByteString) Credential+ ) -- ^ Token Credential (Access Token & Secret) or the conduit response on failures+getAccessTokenWith params = do+ let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" }+ rsp <- liftIO $ flip httpLbs manager+ =<< signOAuth' oa (if oauthVersion oa == OAuth10+ then delete "oauth_verifier" cr+ else cr) False add_auth req+ if responseStatus rsp == status200+ then do+ let dic = parseSimpleQuery . toStrict . responseBody $ rsp+ return $ Right $ Credential dic+ else+ return $ Left rsp+ where+ add_auth = accessTokenAddAuth params+ hook = accessTokenRequestHook params+ oa = accessTokenOAuth params+ cr = accessTokenTemporaryCredential params+ manager = accessTokenManager params+ getTokenCredential = getAccessToken getTokenCredentialProxy = getAccessTokenProxy -insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)]-insertMap key val = ((key,val):) . filter ((/=key).fst) -deleteMap :: Eq a => a -> [(a,b)] -> [(a,b)]-deleteMap k = filter ((/=k).fst)---- | Insert an oauth parameter into given 'Credential'.-insert :: BS.ByteString -- ^ Parameter Name- -> BS.ByteString -- ^ Value- -> Credential -- ^ Credential- -> Credential -- ^ Result-insert k v = Credential . insertMap k v . unCredential---- | Convenient method for inserting multiple parameters into credential.-inserts :: [(BS.ByteString, BS.ByteString)] -> Credential -> Credential-inserts = flip $ foldr (uncurry insert)---- | Remove an oauth parameter for key from given 'Credential'.-delete :: BS.ByteString -- ^ Parameter name- -> Credential -- ^ Credential- -> Credential -- ^ Result-delete key = Credential . deleteMap key . unCredential--injectVerifier :: BS.ByteString -> Credential -> Credential-injectVerifier = insert "oauth_verifier"---- | Add OAuth headers & sign to 'Request'.-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'- sign <- genSign oa tok req- return $ addAuthHeader prefix (insert "oauth_signature" sign tok) req- where- prefix = case oauthRealm oa of- Nothing -> "OAuth "- Just v -> "OAuth realm=\"" `BS.append` v `BS.append` "\","- baseTime :: UTCTime baseTime = UTCTime day 0 where@@ -313,16 +529,20 @@ showSigMtd :: SignMethod -> BS.ByteString showSigMtd PLAINTEXT = "PLAINTEXT" showSigMtd HMACSHA1 = "HMAC-SHA1"+showSigMtd HMACSHA256 = "HMAC-SHA256"+showSigMtd HMACSHA512 = "HMAC-SHA512" showSigMtd (RSASHA1 _) = "RSA-SHA1"+showSigMtd (RSASHA256 _) = "RSA-SHA256"+showSigMtd (RSASHA512 _) = "RSA-SHA512" -addNonce :: MonadUnsafeIO m => Credential -> m Credential+addNonce :: MonadIO m => Credential -> m Credential addNonce cred = do- nonce <- unsafeLiftIO $ replicateM 10 (randomRIO ('a','z')) -- FIXME very inefficient+ nonce <- liftIO $ replicateM 10 (randomRIO ('a','z')) -- FIXME very inefficient return $ insert "oauth_nonce" (BS.pack nonce) cred -addTimeStamp :: MonadUnsafeIO m => Credential -> m Credential+addTimeStamp :: MonadIO m => Credential -> m Credential addTimeStamp cred = do- stamp <- (floor . (`diffUTCTime` baseTime)) `liftM` unsafeLiftIO getCurrentTime+ stamp <- (floor . (`diffUTCTime` baseTime)) `liftM` liftIO getCurrentTime return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred injectOAuthToCred :: OAuth -> Credential -> Credential@@ -332,47 +552,46 @@ , ("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- text <- getBaseString tok req- let key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]- return $ encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text- PLAINTEXT ->- return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok]- RSASHA1 pr ->- liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) -#if MIN_VERSION_http_conduit(2, 0, 0)+-- | Place the authentication information in a URL encoded body instead of the Authorization header.+--+-- Note that the first parameter is used for realm in addAuthHeader, and this+-- function needs the same type. The parameter, however, is unused.+--+-- Since 1.5.1+addAuthBody :: a -> Credential -> Request -> Request+addAuthBody _ (Credential cred) req = urlEncodedBody (filterCreds cred) req+ 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 } renderAuthHeader :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> BS.ByteString-renderAuthHeader prefix = (prefix `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`elem` ["oauth_token", "oauth_verifier", "oauth_consumer_key", "oauth_signature_method", "oauth_timestamp", "oauth_nonce", "oauth_version", "oauth_callback", "oauth_signature"]) . fst)+renderAuthHeader prefix = (prefix `BS.append`)+ . BS.intercalate ","+ . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""])+ . filterCreds --- | Encode a string using the percent encoding method for OAuth.-paramEncode :: BS.ByteString -> BS.ByteString-paramEncode = BS.concatMap escape- where- escape c | isAscii c && (isAlpha c || isDigit c || c `elem` "-._~") = BS.singleton c- | otherwise = let num = map toUpper $ showHex (ord c) ""- oct = '%' : replicate (2 - length num) '0' ++ num- in BS.pack oct+filterCreds :: [(BS.ByteString, BS.ByteString)] -> [(BS.ByteString, BS.ByteString)]+-- as per http://oauth.net/core/1.0a -- 9.1.1. Normalize Request Parameters+-- everything except "realm" parameter should be encoded+-- 6.1.1, 6.1.2, 6.2.1, 6.3.2 and 7 allow encoding anything in the authorization parameters+-- 6.2.3 is only limited to oauth_token and oauth_verifier (although query params are allowed)+-- 6.3.1 does not allow specifing other params, so no need to filter them (it is an error anyway)+filterCreds = filter (not . flip elem ["realm", "oauth_token_secret"] . fst )+--filterCreds = filter ((`elem` [ "oauth_consumer_key"+-- , "oauth_token"+-- , "oauth_signature"+-- , "oauth_signature_method"+-- , "oauth_timestamp"+-- , "oauth_nonce"+-- , "oauth_verifier"+-- , "oauth_version"+-- , "oauth_callback"+-- ] ) . fst ) -#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 :: MonadIO m => Credential -> Request -> m BSL.ByteString getBaseString tok req = do let bsMtd = BS.map toUpper $ method req isHttps = secure req@@ -382,31 +601,74 @@ bsURI = BS.concat [scheme, "://", host req, bsPort, path req] bsQuery = parseSimpleQuery $ queryString req bsBodyQ <- if isBodyFormEncoded $ requestHeaders req- then liftM parseSimpleQuery $ toLBS (requestBody req)+ then liftM parseSimpleQuery $ loadBodyBS req else return []- let bsAuthParams = filter ((`elem`["oauth_consumer_key","oauth_token", "oauth_version","oauth_signature_method","oauth_timestamp", "oauth_nonce", "oauth_verifier", "oauth_version","oauth_callback"]).fst) $ unCredential tok+ let bsAuthParams = filterCreds $ unCredential tok allParams = bsQuery++bsBodyQ++bsAuthParams- bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple+ bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sort $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams -- parameter encoding method in OAuth is slight different from ordinary one. -- So this is OK.- return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]+ return . BSL.fromStrict $ BS.intercalate "&" $ map 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+----------------------------------------------------------------------+-- Utilities -toLBS' :: MonadUnsafeIO m => GivesPopper () -> m BS.ByteString--- FIXME probably shouldn't be using MonadUnsafeIO-toLBS' gp = unsafeLiftIO $ do+-- | Encode a string using the percent encoding method for OAuth.+paramEncode :: BS.ByteString -> BS.ByteString+paramEncode = BS.concatMap escape+ where+ escape c | isAscii c && (isAlpha c || isDigit c || c `elem` ("-._~" :: String)) = BS.singleton c+ | otherwise = let num = map toUpper $ showHex (ord c) ""+ oct = '%' : replicate (2 - length num) '0' ++ num+ in BS.pack oct+++addScope :: BS.ByteString -> Request -> Request+addScope scope req | BS.null scope = req+ | otherwise = urlEncodedBody [("scope", scope)] req+++token, tokenSecret :: Credential -> BS.ByteString+token = fromMaybe "" . lookup "oauth_token" . unCredential+tokenSecret = fromMaybe "" . lookup "oauth_token_secret" . unCredential+++addMaybeProxy :: Maybe Proxy -> Request -> Request+addMaybeProxy p req = req { proxy = p }+++insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)]+insertMap key val = ((key,val):) . filter ((/=key).fst)++deleteMap :: Eq a => a -> [(a,b)] -> [(a,b)]+deleteMap k = filter ((/=k).fst)+++toStrict :: BSL.ByteString -> BS.ByteString+toStrict = BS.concat . BSL.toChunks++fromStrict :: BS.ByteString -> BSL.ByteString+fromStrict = BSL.fromChunks . return+++loadBodyBS :: MonadIO m => Request -> m BS.ByteString+loadBodyBS = toBS . requestBody++toBS :: MonadIO m => RequestBody -> m BS.ByteString+toBS (RequestBodyLBS l) = return $ toStrict l+toBS (RequestBodyBS s) = return s+toBS (RequestBodyBuilder _ b) = return $ toByteString b+toBS (RequestBodyStream _ givesPopper) = toBS' givesPopper+toBS (RequestBodyStreamChunked givesPopper) = toBS' givesPopper+#if MIN_VERSION_http_client(0, 4, 28)+toBS (RequestBodyIO op) = liftIO op >>= toBS+#else+#endif++toBS' :: MonadIO m => GivesPopper () -> m BS.ByteString+toBS' gp = liftIO $ do ref <- I.newIORef BS.empty gp (go ref) I.readIORef ref@@ -419,31 +681,7 @@ 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-toLBS (RequestBodyBuilder _ b) = return $ toByteString b-toLBS (RequestBodySource _ src) = toLBS' src-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"--compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering-compareTuple (a,b) (c,d) =- case compare a c of- LT -> LT- 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 }
Web/Authenticate/OAuth/IO.hs view
@@ -5,16 +5,16 @@ -- What this module do is just adding 'withManager' or 'runResourceT'. module Web.Authenticate.OAuth.IO {-# DEPRECATED "This module is deprecated; rewrite your code using MonadResource" #-}- ( + ( module Web.Authenticate.OAuth, getAccessToken, getTemporaryCredential, getTemporaryCredentialWithScope, getTemporaryCredentialProxy, getTemporaryCredential', getTokenCredential,- getAccessTokenProxy, getTokenCredentialProxy, + getAccessTokenProxy, getTokenCredentialProxy, getAccessToken' ) where-import Network.HTTP.Conduit+import Network.HTTP.Client import qualified Web.Authenticate.OAuth as OA import Web.Authenticate.OAuth hiding (getAccessToken,@@ -24,7 +24,6 @@ getAccessTokenProxy, getTemporaryCredentialProxy, getTokenCredentialProxy, getAccessToken', getTemporaryCredential')-import Data.Conduit import Control.Monad.IO.Class import qualified Data.ByteString.Char8 as BS @@ -33,7 +32,7 @@ getTemporaryCredential :: MonadIO m => OA.OAuth -- ^ OAuth Application -> m OA.Credential -- ^ Temporary Credential (Request Token & Secret).-getTemporaryCredential = liftIO . withManager . OA.getTemporaryCredential+getTemporaryCredential = liftIO . withManager defaultManagerSettings . OA.getTemporaryCredential -- | Get temporary credential for requesting access token with Scope parameter. getTemporaryCredentialWithScope :: MonadIO m@@ -41,7 +40,7 @@ -> OAuth -- ^ OAuth Application -> m Credential -- ^ Temporay Credential (Request Token & Secret). getTemporaryCredentialWithScope bs oa =- liftIO $ withManager $ OA.getTemporaryCredentialWithScope bs oa+ liftIO $ withManager defaultManagerSettings $ OA.getTemporaryCredentialWithScope bs oa -- | Get temporary credential for requesting access token via the proxy.@@ -49,17 +48,13 @@ => Maybe Proxy -- ^ Proxy -> OAuth -- ^ OAuth Application -> m Credential -- ^ Temporary Credential (Request Token & Secret).-getTemporaryCredentialProxy p oa = liftIO $ withManager $ OA.getTemporaryCredential' (addMaybeProxy p) oa+getTemporaryCredentialProxy p oa = liftIO $ withManager defaultManagerSettings $ 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+getTemporaryCredential' hook oa = liftIO $ withManager defaultManagerSettings $ OA.getTemporaryCredential' hook oa -- | Get Access token.@@ -68,7 +63,7 @@ => OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential with oauth_verifier -> m Credential -- ^ Token Credential (Access Token & Secret)-getAccessToken oa cr = liftIO $ withManager $ OA.getAccessToken oa cr+getAccessToken oa cr = liftIO $ withManager defaultManagerSettings $ OA.getAccessToken oa cr -- | Get Access token via the proxy. getAccessTokenProxy, getTokenCredentialProxy@@ -77,18 +72,14 @@ -> OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential with oauth_verifier -> m Credential -- ^ Token Credential (Access Token & Secret)-getAccessTokenProxy p oa cr = liftIO $ withManager $ OA.getAccessTokenProxy p oa cr+getAccessTokenProxy p oa cr = liftIO $ withManager defaultManagerSettings $ 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)-getAccessToken' hook oa cr = liftIO $ withManager $ OA.getAccessToken' hook oa cr+getAccessToken' hook oa cr = liftIO $ withManager defaultManagerSettings $ OA.getAccessToken' hook oa cr getTokenCredential = getAccessToken
authenticate-oauth.cabal view
@@ -1,36 +1,34 @@-+cabal-version: >= 1.10 name: authenticate-oauth-version: 1.4.0.8+version: 1.7 license: BSD3 license-file: LICENSE author: Hiromi Ishii-maintainer: Hiromi Ishii+maintainer: Hiromi Ishii, Artem Chirkin synopsis: Library to authenticate with OAuth for Haskell web applications.-description: OAuth authentication, e.g. Twitter.+description: API docs and the README are available at <http://www.stackage.org/package/authenticate-oauth>. category: Web stability: Stable-cabal-version: >= 1.6 build-type: Simple homepage: http://github.com/yesodweb/authenticate+extra-source-files: README.md ChangeLog.md library- build-depends: base >= 4 && < 5- , http-conduit >= 1.4- , transformers >= 0.1 && < 0.4+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5+ , http-client >= 0.3+ , transformers >= 0.1 && < 0.6 , bytestring >= 0.9 , crypto-pubkey-types >= 0.1 && < 0.5- , RSA >= 1.2 && < 1.3+ , RSA >= 2.0 && < 2.5 , time , data-default- , base64-bytestring >= 0.1 && < 1.1+ , base64-bytestring >= 0.1 && < 1.3 , SHA >= 1.4 && < 1.7 , random- , http-types >= 0.6 && < 0.9+ , http-types >= 0.6 , blaze-builder- , conduit >= 0.4- , resourcet >= 0.3 && < 0.5- , blaze-builder-conduit >= 0.4- , monad-control >= 0.3 && < 0.4+ , transformers-compat >= 0.3 exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO ghc-options: -Wall