diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,25 @@ -Copyright (c)2011, Hiromi ISHII +The following license covers this documentation, and the source code, except +where otherwise indicated. -All rights reserved. +Copyright 2008, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. - * Neither the name of Hiromi ISHII nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/Web/Authenticate/Internal.hs b/Web/Authenticate/Internal.hs deleted file mode 100644 --- a/Web/Authenticate/Internal.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module Web.Authenticate.Internal - ( qsEncode - , qsUrl - , AuthenticateException (..) - ) where - -import Codec.Binary.UTF8.String (encode) -import Numeric (showHex) -import Data.List (intercalate) -import Data.Typeable (Typeable) -import Control.Exception (Exception) - -data AuthenticateException = - RpxnowException String - | NormalizationException String - | DiscoveryException String - | AuthenticationException String - deriving (Show, Typeable) -instance Exception AuthenticateException - -qsUrl :: String -> [(String, String)] -> String -qsUrl s [] = s -qsUrl url pairs = - url ++ delim : intercalate "&" (map qsPair pairs) - where - qsPair (x, y) = qsEncode x ++ '=' : qsEncode y - delim = if '?' `elem` url then '&' else '?' - -qsEncode :: String -> String -qsEncode = - concatMap go . encode - where - go 32 = "+" -- space - go 46 = "." - go 45 = "-" - go 126 = "~" - go 95 = "_" - go c - | 48 <= c && c <= 57 = [w2c c] - | 65 <= c && c <= 90 = [w2c c] - | 97 <= c && c <= 122 = [w2c c] - go c = '%' : showHex c "" - w2c = toEnum . fromEnum diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -2,24 +2,30 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} module Web.Authenticate.OAuth ( -- * Data types - OAuth(..), SignMethod(..), Credential(..), + OAuth(oauthServerName, oauthRequestUri, oauthAccessTokenUri, oauthAuthorizeUri, + oauthSignatureMethod, oauthConsumerKey, oauthConsumerSecret, oauthCallback, + oauthRealm), + def, newOAuth, SignMethod(..), Credential(..), OAuthException(..), -- * Operations for credentials - emptyCredential, insert, delete, inserts, + newCredential, emptyCredential, insert, delete, inserts, -- * Signature - signOAuth, + signOAuth, genSign, -- * Url & operation for authentication - authorizeUrl, getTokenCredential, getTemporaryCredential, + authorizeUrl, authorizeUrl', getAccessToken, getTemporaryCredential, + getTokenCredential, getTemporaryCredentialWithScope, + getAccessTokenProxy, getTemporaryCredentialProxy, + getTokenCredentialProxy, + getAccessToken', getTemporaryCredential', -- * Utility Methods - paramEncode + paramEncode, addScope, addMaybeProxy ) where -import Network.HTTP.Enumerator -import Web.Authenticate.Internal (qsUrl) +import Network.HTTP.Conduit import Data.Data import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Maybe import Control.Applicative -import Network.Wai.Parse +import Network.HTTP.Types (parseSimpleQuery, SimpleQuery) import Control.Exception import Control.Monad import Data.List (sortBy) @@ -29,22 +35,67 @@ import Data.ByteString.Base64 import Data.Time import Numeric -import Network.Wai (ResponseHeader) import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..)) - +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 (ResourceT, ResourceIO, ($$), ($=), 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 Data.Default -- | Data type for OAuth client (consumer). -data OAuth = OAuth { oauthServerName :: String -- ^ Service name - , oauthRequestUri :: String -- ^ URI to request temporary credential - , oauthAccessTokenUri :: String -- ^ Uri to obtain access token - , oauthAuthorizeUri :: String -- ^ Uri to authorize - , oauthSignatureMethod :: SignMethod -- ^ Signature Method - , oauthConsumerKey :: BS.ByteString -- ^ Consumer key - , oauthConsumerSecret :: BS.ByteString -- ^ Consumer Secret - , oauthCallback :: Maybe BS.ByteString -- ^ Callback uri to redirect after authentication +-- +-- 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: @""@) + , oauthRequestUri :: String + -- ^ URI to request temporary credential (default: @""@). + -- You MUST specify if you use 'getTemporaryCredential\'', 'getTemporaryCredentialProxy' + -- 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\''; + -- otherwise you can just leave this empty. + , oauthAuthorizeUri :: String + -- ^ Uri to authorize (default: @""@). + -- You MUST specify if you use 'authorizeUrl' or 'authorizeUrl\''; + -- otherwise you can just leave this empty. + , oauthSignatureMethod :: SignMethod + -- ^ Signature Method (default: 'HMACSHA1') + , oauthConsumerKey :: BS.ByteString + -- ^ Consumer key (You MUST specify) + , oauthConsumerSecret :: BS.ByteString + -- ^ Consumer Secret (You MUST specify) + , oauthCallback :: Maybe BS.ByteString + -- ^ Callback uri to redirect after authentication (default: @Nothing@) + , oauthRealm :: Maybe BS.ByteString + -- ^ Optional authorization realm (default: @Nothing@) } deriving (Show, Eq, Ord, Read, Data, Typeable) +-- | Default value for OAuth datatype. +-- You must specify at least oauthServerName, URIs and Tokens. +newOAuth :: OAuth +newOAuth = OAuth { oauthSignatureMethod = HMACSHA1 + , oauthCallback = Nothing + , oauthRealm = Nothing + , oauthServerName = "" + , oauthRequestUri = "" + , oauthAccessTokenUri = "" + , oauthAuthorizeUri = "" + , oauthConsumerKey = error "You MUST specify oauthConsumerKey parameter." + , oauthConsumerSecret = error "You MUST specify oauthConsumerSecret parameter." + } +instance Default OAuth where + def = newOAuth + -- | Data type for signature method. data SignMethod = PLAINTEXT | HMACSHA1 @@ -65,11 +116,17 @@ emptyCredential :: Credential emptyCredential = Credential [] +-- | 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 = ProtocolException String +data OAuthException = OAuthException String deriving (Show, Eq, Data, Typeable) instance Exception OAuthException @@ -81,31 +138,107 @@ fromStrict = BSL.fromChunks . return -- | Get temporary credential for requesting acces token. -getTemporaryCredential :: OAuth -- ^ OAuth Application - -> IO Credential -- ^ Temporary Credential (Request Token & Secret). -getTemporaryCredential oa = do - let req = fromJust $ parseUrl (oauthRequestUri oa) - req' <- signOAuth oa emptyCredential (req { method = "POST" }) - rsp <- httpLbs req' - let dic = parseQueryString . toStrict . responseBody $ rsp - return $ Credential dic +getTemporaryCredential :: ResourceIO m + => OAuth -- ^ OAuth Application + -> Manager + -> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential = getTemporaryCredential' id +-- | Get temporary credential for requesting access token with Scope parameter. +getTemporaryCredentialWithScope :: ResourceIO m + => BS.ByteString -- ^ Scope parameter string + -> OAuth -- ^ OAuth Application + -> Manager + -> ResourceT m Credential -- ^ Temporay Credential (Request Token & Secret). +getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs) + +addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m +addScope scope req | BS.null scope = req + | otherwise = urlEncodedBody [("scope", scope)] req + +-- | Get temporary credential for requesting access token via the proxy. +getTemporaryCredentialProxy :: ResourceIO m + => Maybe Proxy -- ^ Proxy + -> OAuth -- ^ OAuth Application + -> Manager + -> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m + +getTemporaryCredential' :: ResourceIO m + => (Request m -> Request m) -- ^ Request Hook + -> OAuth -- ^ OAuth Application + -> Manager + -> ResourceT 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 + if statusCode 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) + -- | URL to obtain OAuth verifier. authorizeUrl :: OAuth -- ^ OAuth Application -> Credential -- ^ Temporary Credential (Request Token & Secret) -> String -- ^ URL to authorize -authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)] +authorizeUrl = authorizeUrl' $ \oa -> const [("oauth_consumer_key", oauthConsumerKey oa)] --- | Get Token Credential (Access token & secret). -getTokenCredential :: OAuth -- ^ OAuth Application - -> Credential -- ^ Temporary Credential with oauth_verifier - -> IO Credential -- ^ Token Credential (Access Token & Secret) -getTokenCredential oa cr = do - let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } - rsp <- signOAuth oa cr req >>= httpLbs - let dic = parseQueryString . toStrict . responseBody $ rsp - return $ Credential dic +-- | Convert OAuth and Credential to URL to obatin OAuth Verifier. +-- This takes function to choice parameter to pass to the server other than +-- /oauth_callback/ or /oauth_token/. +authorizeUrl' :: (OAuth -> Credential -> SimpleQuery) + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential (Request Token & Secret) + -> 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 = + case oauthCallback oa of + Nothing -> fixed + Just callback -> ("oauth_callback", callback):fixed + +-- | Get Access token. +getAccessToken, getTokenCredential + :: ResourceIO m + => OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> Manager + -> ResourceT m Credential -- ^ Token Credential (Access Token & Secret) +getAccessToken = getAccessToken' id + +-- | Get Access token via the proxy. +getAccessTokenProxy, getTokenCredentialProxy + :: ResourceIO m + => Maybe Proxy -- ^ Proxy + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> Manager + -> ResourceT m Credential -- ^ Token Credential (Access Token & Secret) +getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p + +getAccessToken' :: ResourceIO m + => (Request m -> Request m) -- ^ Request Hook + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> Manager + -> ResourceT 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 cr req + if statusCode 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) + + +getTokenCredential = getAccessToken +getTokenCredentialProxy = getAccessTokenProxy + insertMap :: Eq a => a -> b -> [(a,b)] -> [(a,b)] insertMap key val = ((key,val):) . filter ((/=key).fst) @@ -130,15 +263,20 @@ delete key = Credential . deleteMap key . unCredential -- | Add OAuth headers & sign to 'Request'. -signOAuth :: OAuth -- ^ OAuth Application +signOAuth :: ResourceIO m + => OAuth -- ^ OAuth Application -> Credential -- ^ Credential - -> Request -- ^ Original Request - -> IO Request -- ^ Signed OAuth Request + -> Request m -- ^ Original Request + -> ResourceT m (Request m) -- ^ Signed OAuth Request signOAuth oa crd req = do crd' <- addTimeStamp =<< addNonce crd let tok = injectOAuthToCred oa crd' - sign = genSign oa tok req - return $ addAuthHeader (insert "oauth_signature" sign tok) req + 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 @@ -150,68 +288,82 @@ showSigMtd HMACSHA1 = "HMAC-SHA1" showSigMtd (RSASHA1 _) = "RSA-SHA1" -addNonce :: Credential -> IO Credential +addNonce :: ResourceIO m => Credential -> ResourceT m Credential addNonce cred = do - nonce <- replicateM 10 (randomRIO ('a','z')) + nonce <- liftIO $ replicateM 10 (randomRIO ('a','z')) -- FIXME very inefficient return $ insert "oauth_nonce" (BS.pack nonce) cred -addTimeStamp :: Credential -> IO Credential +addTimeStamp :: ResourceIO m => Credential -> ResourceT m Credential addTimeStamp cred = do - stamp <- floor . (`diffUTCTime` baseTime) <$> getCurrentTime :: IO Integer - return $ insert "oauth_timestamp" (BS.pack $ show stamp) cred + stamp <- floor . (`diffUTCTime` baseTime) <$> liftIO getCurrentTime + return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred injectOAuthToCred :: OAuth -> Credential -> Credential -injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa) $ - inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) - , ("oauth_consumer_key", oauthConsumerKey oa) - ] cred +injectOAuthToCred oa cred = + inserts [ ("oauth_signature_method", showSigMtd $ oauthSignatureMethod oa) + , ("oauth_consumer_key", oauthConsumerKey oa) + , ("oauth_version", "1.0") + ] cred -genSign :: OAuth -> Credential -> Request -> BS.ByteString +genSign :: ResourceIO m => OAuth -> Credential -> Request m -> ResourceT m BS.ByteString genSign oa tok req = case oauthSignatureMethod oa of - HMACSHA1 -> - let text = getBaseString tok req - key = BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] - in encode $ toStrict $ bytestringDigest $ hmacSha1 (fromStrict key) text + 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 -> - BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] + return $ BS.intercalate "&" $ map paramEncode [oauthConsumerSecret oa, tokenSecret tok] RSASHA1 pr -> - encode $ toStrict $ rsassa_pkcs1_v1_5_sign ha_SHA1 pr (getBaseString tok req) + liftM (encode . toStrict . rsassa_pkcs1_v1_5_sign ha_SHA1 pr) (getBaseString tok req) -addAuthHeader :: Credential -> Request -> Request -addAuthHeader (Credential cred) req = - req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req } +addAuthHeader :: BS.ByteString -> Credential -> Request a -> Request a +addAuthHeader prefix (Credential cred) req = + req { requestHeaders = insertMap "Authorization" (renderAuthHeader prefix cred) $ requestHeaders req } -renderAuthHeader :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString -renderAuthHeader = ("OAuth " `BS.append`). BS.intercalate "," . map (\(a,b) -> BS.concat [paramEncode a, "=\"", paramEncode b, "\""]) . filter ((`notElem` ["oauth_token_secret", "oauth_consumer_secret"]) . fst) +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) -- | Encode a string using the percent encoding method for OAuth. paramEncode :: BS.ByteString -> BS.ByteString paramEncode = BS.concatMap escape where - escape c | isAlpha c || isDigit c || c `elem` "-._~" = BS.singleton c + 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 -getBaseString :: Credential -> Request -> BSL.ByteString -getBaseString tok req = +getBaseString :: ResourceIO m => Credential -> Request m -> ResourceT m BSL.ByteString +getBaseString tok req = do let bsMtd = BS.map toUpper $ method req isHttps = secure req scheme = if isHttps then "https" else "http" bsPort = if (isHttps && port req /= 443) || (not isHttps && port req /= 80) then ':' `BS.cons` BS.pack (show $ port req) else "" bsURI = BS.concat [scheme, "://", host req, bsPort, path req] - bsQuery = queryString req - bsBodyQ = if isBodyFormEncoded $ requestHeaders req - then parseQueryString (toStrict $ requestBody req) else [] - bsAuthParams = filter ((`notElem`["oauth_signature","realm","oauth_version", "oauth_token_secret"]).fst) $ unCredential tok + bsQuery = parseSimpleQuery $ queryString req + bsBodyQ <- if isBodyFormEncoded $ requestHeaders req + then liftM parseSimpleQuery $ toLBS (requestBody 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 allParams = bsQuery++bsBodyQ++bsAuthParams bsParams = BS.intercalate "&" $ map (\(a,b)->BS.concat[a,"=",b]) $ sortBy compareTuple $ map (\(a,b) -> (paramEncode a,paramEncode b)) allParams - in BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] + -- parameter encoding method in OAuth is slight different from ordinary one. + -- So this is OK. + return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] -isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> Bool +toLBS :: ResourceIO m => RequestBody m -> ResourceT 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' :: ResourceIO m => Source m Builder -> ResourceT m BS.ByteString +toLBS' src = fmap BS.concat $ src $= builderToByteString $$ CL.consume + +isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type" compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering @@ -220,3 +372,6 @@ LT -> LT EQ -> compare b d GT -> GT + +addMaybeProxy :: Maybe Proxy -> Request m -> Request m +addMaybeProxy p req = req { proxy = p } diff --git a/Web/Authenticate/OAuth/IO.hs b/Web/Authenticate/OAuth/IO.hs new file mode 100644 --- /dev/null +++ b/Web/Authenticate/OAuth/IO.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} +{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +-- | This Module provides interface for the instance of ResouceIO instead of ResourceT. +-- What this module do is just adding 'withManager' or 'runResourceT'. +module Web.Authenticate.OAuth.IO + ( + module Web.Authenticate.OAuth, + getAccessToken, signOAuth, + getTemporaryCredential, getTemporaryCredentialWithScope, + getTemporaryCredentialProxy, getTemporaryCredential', + getTokenCredential, + getAccessTokenProxy, getTokenCredentialProxy, + getAccessToken', genSign + ) where +import Network.HTTP.Conduit +import qualified Web.Authenticate.OAuth as OA +import Web.Authenticate.OAuth hiding + (getAccessToken, signOAuth, + getTemporaryCredential, getTemporaryCredentialWithScope, + getTemporaryCredentialProxy, getTemporaryCredential', + getTokenCredential, getTemporaryCredentialWithScope, + getAccessTokenProxy, getTemporaryCredentialProxy, + getTokenCredentialProxy, genSign, + getAccessToken', getTemporaryCredential') +import Data.Conduit +import qualified Data.ByteString.Char8 as BS + + +-- | Get temporary credential for requesting acces token. +getTemporaryCredential :: ResourceIO m + => OA.OAuth -- ^ OAuth Application + -> m OA.Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential = withManager . OA.getTemporaryCredential + +-- | Get temporary credential for requesting access token with Scope parameter. +getTemporaryCredentialWithScope :: ResourceIO m + => BS.ByteString -- ^ Scope parameter string + -> OAuth -- ^ OAuth Application + -> m Credential -- ^ Temporay Credential (Request Token & Secret). +getTemporaryCredentialWithScope bs oa = + withManager $ OA.getTemporaryCredentialWithScope bs oa + + +-- | Get temporary credential for requesting access token via the proxy. +getTemporaryCredentialProxy :: ResourceIO m + => Maybe Proxy -- ^ Proxy + -> OAuth -- ^ OAuth Application + -> m Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredentialProxy p oa = withManager $ OA.getTemporaryCredential' (addMaybeProxy p) oa + +getTemporaryCredential' :: ResourceIO m + => (Request m -> Request m) -- ^ Request Hook + -> OAuth -- ^ OAuth Application + -> m Credential -- ^ Temporary Credential (Request Token & Secret). +getTemporaryCredential' hook oa = withManager $ OA.getTemporaryCredential' hook oa + + +-- | Get Access token. +getAccessToken, getTokenCredential + :: ResourceIO m + => OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> m Credential -- ^ Token Credential (Access Token & Secret) +getAccessToken oa cr = withManager $ OA.getAccessToken oa cr + +-- | Get Access token via the proxy. +getAccessTokenProxy, getTokenCredentialProxy + :: ResourceIO m + => Maybe Proxy -- ^ Proxy + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> m Credential -- ^ Token Credential (Access Token & Secret) +getAccessTokenProxy p oa cr = withManager $ OA.getAccessTokenProxy p oa cr + +getAccessToken' :: ResourceIO m + => (Request m -> Request m) -- ^ Request Hook + -> OAuth -- ^ OAuth Application + -> Credential -- ^ Temporary Credential with oauth_verifier + -> m Credential -- ^ Token Credential (Access Token & Secret) +getAccessToken' hook oa cr = withManager $ OA.getAccessToken' hook oa cr + + +getTokenCredential = getAccessToken +getTokenCredentialProxy = getAccessTokenProxy + +-- | Add OAuth headers & sign to 'Request' +signOAuth :: ResourceIO m + => OAuth -- ^ OAuth Application + -> Credential -- ^ Credential + -> Request m -- ^ Original Request + -> m (Request m) -- ^ Signed OAuth Request +signOAuth oa crd req = runResourceT $ OA.signOAuth oa crd req + +genSign :: ResourceIO m => OAuth -> Credential -> Request m -> m BS.ByteString +genSign oa tok req = runResourceT $ OA.genSign oa tok req diff --git a/authenticate-oauth.cabal b/authenticate-oauth.cabal --- a/authenticate-oauth.cabal +++ b/authenticate-oauth.cabal @@ -1,68 +1,35 @@ --- authenticate-oauth.cabal auto-generated by cabal init. For --- additional options, see --- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. --- The name of the package. -Name: authenticate-oauth - --- The package version. See the Haskell package versioning policy --- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for --- standards guiding when and how versions should be incremented. -Version: 0.1 - --- A short (one-line) description of the package. -Synopsis: OAuth client support for authenticate package. - --- A longer description of the package. -Description: OAuth client support for authenticate package. - --- The license under which the package is released. -License: BSD3 - --- The file containing the license text. -License-file: LICENSE - --- The package author(s). -Author: Hiromi ISHII - --- An email address to which users can send suggestions, bug reports, --- and patches. -Maintainer: konn.jinro_at_gmail.com - --- A copyright notice. --- Copyright: - -Category: Web - -Build-type: Simple - --- Extra files to be distributed with the package, such as examples or --- a README. --- Extra-source-files: - --- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.2 +name: authenticate-oauth +version: 1.0.0 +license: BSD3 +license-file: LICENSE +author: Hiromi Ishii +maintainer: Hiromi Ishii +synopsis: Authentication methods for Haskell web applications. +description: OAuth authentication, e.g. Twitter. +category: Web +stability: Stable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://github.com/yesodweb/authenticate -Library - -- Modules exported by the library. - Exposed-modules: Web.Authenticate.OAuth - - -- Packages needed in order to build this package. - Build-depends: base >= 4.0 && < 5.0, - bytestring >= 0.9 && < 1.0, - http-enumerator >= 0.3 && < 0.4, - wai >= 0.3 && < 0.4, utf8-string >= 0.3 && < 0.4, - authenticate >= 0.8 && < 0.9, - RSA >= 1.0 && < 1.1, - time >= 1.1 && < 1.2, - base64-bytestring >= 0.1 && < 0.2, - SHA >= 1.4 && < 1.5, - random >= 1.0 && < 1.1, - wai-extra >= 0.3 && < 0.4 +library + build-depends: base >= 4 && < 5 + , http-conduit >= 1.2 && < 1.3 + , transformers >= 0.1 && < 0.3 + , bytestring >= 0.9 + , RSA >= 1.0 && < 1.1 + , time + , data-default >= 0.3 && < 0.4 + , base64-bytestring >= 0.1 && < 0.2 + , SHA >= 1.4 && < 1.6 + , random + , http-types >= 0.6 && < 0.7 + , blaze-builder + , conduit >= 0.2 && < 0.3 + , blaze-builder-conduit >= 0.2 && < 0.3 + exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO + ghc-options: -Wall - - -- Modules not exported by this package. - Other-modules: Web.Authenticate.Internal - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: - +source-repository head + type: git + location: git://github.com/yesodweb/authenticate.git