authenticate-oauth 1.5.1.2 → 1.7
raw patch · 3 files changed
Files
- ChangeLog.md +10/−0
- Web/Authenticate/OAuth.hs +169/−28
- authenticate-oauth.cabal +8/−6
ChangeLog.md view
@@ -1,3 +1,13 @@+## 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
Web/Authenticate/OAuth.hs view
@@ -17,7 +17,7 @@ -- * Operations for credentials newCredential, emptyCredential, insert, delete, inserts, injectVerifier, -- * Signature- signOAuth, genSign,+ signOAuth, genSign, checkOAuth, -- * Url & operation for authentication -- ** Temporary credentials getTemporaryCredential, getTemporaryCredentialWithScope,@@ -39,9 +39,11 @@ import Blaze.ByteString.Builder (toByteString) import Control.Exception+import Control.Arrow (second) import Control.Monad import Control.Monad.IO.Class (MonadIO, liftIO)-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@@ -49,7 +51,7 @@ import Data.Default import Data.Digest.Pure.SHA import qualified Data.IORef as I-import Data.List (sort)+import Data.List as List (sort, find) import Data.Maybe import Data.Time import Network.HTTP.Client@@ -63,7 +65,7 @@ #else import Data.Data #endif-import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1)+import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, hashSHA1, hashSHA256, hashSHA512) ----------------------------------------------------------------------@@ -131,11 +133,15 @@ -- | Data type for signature method. data SignMethod = PLAINTEXT | HMACSHA1+ | HMACSHA256+ | HMACSHA512 | RSASHA1 PrivateKey+ | RSASHA256 PrivateKey+ | RSASHA512 PrivateKey deriving (Show, Eq, Read, Data, Typeable) -data OAuthException = OAuthException String+newtype OAuthException = OAuthException String deriving (Show, Eq, Data, Typeable) instance Exception OAuthException@@ -192,9 +198,10 @@ -- Credentials --- | Data type for redential.-data Credential = Credential { unCredential :: [(BS.ByteString, BS.ByteString)] }- deriving (Show, Eq, Ord, Read, Data, Typeable)+-- | 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.@@ -243,24 +250,40 @@ -> Credential -- ^ Credential -> Request -- ^ Original Request -> m Request -- ^ Signed OAuth Request-signOAuth oa crd req = signOAuth' oa crd addAuthHeader req+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 add_auth req = do+signOAuth' oa crd withHash add_auth req = do crd' <- addTimeStamp =<< addNonce crd- let tok = injectOAuthToCred oa crd'+ mhash <- moauth_body_hash+ let tok = addHashToCred mhash $ injectOAuthToCred oa crd' sign <- genSign oa tok req- return $ add_auth prefix (insert "oauth_signature" sign tok) req- where- prefix = case oauthRealm oa of- Nothing -> "OAuth "- Just v -> "OAuth realm=\"" `BS.append` v `BS.append` "\","+ 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'.@@ -271,12 +294,88 @@ 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 @@ -315,13 +414,14 @@ 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 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) ----------------------------------------------------------------------@@ -381,17 +481,29 @@ -> Manager -> m Credential -- ^ Token Credential (Access Token & Secret) 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)+ 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+ -> 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) add_auth req+ 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@@ -417,7 +529,11 @@ 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 :: MonadIO m => Credential -> m Credential addNonce cred = do@@ -451,10 +567,28 @@ 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, "\""]) . filterCreds+renderAuthHeader prefix = (prefix `BS.append`)+ . BS.intercalate ","+ . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""])+ . filterCreds filterCreds :: [(BS.ByteString, BS.ByteString)] -> [(BS.ByteString, BS.ByteString)]-filterCreds = filter ((`elem` ["oauth_token", "oauth_verifier", "oauth_consumer_key", "oauth_signature_method", "oauth_timestamp", "oauth_nonce", "oauth_version", "oauth_callback", "oauth_signature"]) . fst)+-- 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 ) getBaseString :: MonadIO m => Credential -> Request -> m BSL.ByteString@@ -467,15 +601,15 @@ bsURI = BS.concat [scheme, "://", host req, bsPort, path req] bsQuery = parseSimpleQuery $ queryString req bsBodyQ <- if isBodyFormEncoded $ requestHeaders req- then liftM parseSimpleQuery $ toBS (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]) $ 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] ----------------------------------------------------------------------@@ -519,12 +653,19 @@ 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
authenticate-oauth.cabal view
@@ -1,32 +1,34 @@+cabal-version: >= 1.10 name: authenticate-oauth-version: 1.5.1.2+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: 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+ 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 >= 2.0 && < 2.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 , blaze-builder+ , transformers-compat >= 0.3 exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO ghc-options: -Wall