authenticate-oauth 0.1 → 1.0.0

raw patch · 7 files changed

+380/−207 lines, 7 filesdep +blaze-builderdep +blaze-builder-conduitdep +conduitdep −authenticatedep −http-enumeratordep −utf8-stringdep ~SHAdep ~basedep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-builder, blaze-builder-conduit, conduit, data-default, http-conduit, http-types, transformers

Dependencies removed: authenticate, http-enumerator, utf8-string, wai, wai-extra

Dependency ranges changed: SHA, base, bytestring, random, time

API changes (from Hackage documentation)

Files

• LICENSE +18/−23
• Setup.hs +0/−2
• Setup.lhs +7/−0
• Web/Authenticate/Internal.hs +0/−44
• Web/Authenticate/OAuth.hs +227/−72
• Web/Authenticate/OAuth/IO.hs +95/−0
• authenticate-oauth.cabal +33/−66

@@ -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.

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain

@@ -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

@@ -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 }

@@ -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

@@ -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