haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

catched up with conduit-0.3

Browse Source
This commit is contained in:
Hiromi Ishii 2012-03-22 15:52:40 +09:00
parent f86bd28b45
commit ab821a32a9
3 changed files with 39 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
authenticate-oauth/Web/Authenticate/OAuth.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving, FlexibleContexts #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Web.Authenticate.OAuth module Web.Authenticate.OAuth
( -- * Data types ( -- * Data types
@ -24,7 +24,6 @@ import Data.Data
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.Maybe import Data.Maybe
import Control.Applicative
import Network.HTTP.Types (parseSimpleQuery, SimpleQuery) import Network.HTTP.Types (parseSimpleQuery, SimpleQuery)
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
@ -40,11 +39,12 @@ import Network.HTTP.Types (Header)
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Network.HTTP.Types (renderSimpleQuery, status200) import Network.HTTP.Types (renderSimpleQuery, status200)
import Data.Conduit (ResourceT, ResourceIO, ($$), ($=), Source) import Data.Conduit (MonadResource, ($$), ($=), Source)
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
import Data.Conduit.Blaze (builderToByteString) import Data.Conduit.Blaze (builderToByteString)
import Blaze.ByteString.Builder (Builder) import Blaze.ByteString.Builder (Builder)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Control
import Data.Default import Data.Default
-- | Data type for OAuth client (consumer). -- | Data type for OAuth client (consumer).
@ -82,6 +82,7 @@ data OAuth = OAuth { oauthServerName :: String -- ^ Service name (default:
data OAuthVersion = OAuth10 -- ^ OAuth protocol ver 1.0 (no oauth_verifier; differs from RFC 5849). 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. | OAuth10a -- ^ OAuth protocol ver 1.0a. This corresponds to community's 1.0a spec and RFC 5849.
| OAuth20 -- ^ OAuth protocol ver 2.0, currently based on community's draft-ietf-oauth-v2-25.
deriving (Show, Eq, Ord, Data, Typeable, Read) deriving (Show, Eq, Ord, Data, Typeable, Read)
-- | Default value for OAuth datatype. -- | Default value for OAuth datatype.
@ -144,18 +145,18 @@ fromStrict :: BS.ByteString -> BSL.ByteString
fromStrict = BSL.fromChunks . return fromStrict = BSL.fromChunks . return
-- | Get temporary credential for requesting acces token. -- | Get temporary credential for requesting acces token.
getTemporaryCredential :: ResourceIO m getTemporaryCredential :: (MonadResource m, MonadBaseControl IO m)
=> OAuth -- ^ OAuth Application => OAuth -- ^ OAuth Application
-> Manager -> Manager
-> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret). -> m Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredential = getTemporaryCredential' id getTemporaryCredential = getTemporaryCredential' id
-- | Get temporary credential for requesting access token with Scope parameter. -- | Get temporary credential for requesting access token with Scope parameter.
getTemporaryCredentialWithScope :: ResourceIO m getTemporaryCredentialWithScope :: (MonadResource m, MonadBaseControl IO m)
=> BS.ByteString -- ^ Scope parameter string => BS.ByteString -- ^ Scope parameter string
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Manager -> Manager
-> ResourceT m Credential -- ^ Temporay Credential (Request Token & Secret). -> m Credential -- ^ Temporay Credential (Request Token & Secret).
getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs) getTemporaryCredentialWithScope bs = getTemporaryCredential' (addScope bs)
addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m addScope :: (MonadIO m) => BS.ByteString -> Request m -> Request m
@ -163,24 +164,24 @@ addScope scope req | BS.null scope = req
| otherwise = urlEncodedBody [("scope", scope)] req | otherwise = urlEncodedBody [("scope", scope)] req
-- | Get temporary credential for requesting access token via the proxy. -- | Get temporary credential for requesting access token via the proxy.
getTemporaryCredentialProxy :: ResourceIO m getTemporaryCredentialProxy :: (MonadResource m, MonadBaseControl IO m)
=> Maybe Proxy -- ^ Proxy => Maybe Proxy -- ^ Proxy
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Manager -> Manager
-> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret). -> m Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m getTemporaryCredentialProxy p oa m = getTemporaryCredential' (addMaybeProxy p) oa m
getTemporaryCredential' :: ResourceIO m getTemporaryCredential' :: (MonadResource m, MonadBaseControl IO m)
=> (Request m -> Request m) -- ^ Request Hook => (Request m -> Request m) -- ^ Request Hook
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Manager -> Manager
-> ResourceT m Credential -- ^ Temporary Credential (Request Token & Secret). -> m Credential -- ^ Temporary Credential (Request Token & Secret).
getTemporaryCredential' hook oa manager = do getTemporaryCredential' hook oa manager = do
let req = fromJust $ parseUrl $ oauthRequestUri oa let req = fromJust $ parseUrl $ oauthRequestUri oa
crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential crd = maybe id (insert "oauth_callback") (oauthCallback oa) $ emptyCredential
req' <- signOAuth oa crd $ hook (req { method = "POST" }) req' <- signOAuth oa crd $ hook (req { method = "POST" })
rsp <- httpLbs req' manager rsp <- httpLbs req' manager
if statusCode rsp == status200 if responseStatus rsp == status200
then do then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic return $ Credential dic
@ -209,33 +210,33 @@ authorizeUrl' f oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery Tru
-- | Get Access token. -- | Get Access token.
getAccessToken, getTokenCredential getAccessToken, getTokenCredential
:: ResourceIO m :: (MonadResource m, MonadBaseControl IO m)
=> OAuth -- ^ OAuth Application => OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
-> Manager -> Manager
-> ResourceT m Credential -- ^ Token Credential (Access Token & Secret) -> m Credential -- ^ Token Credential (Access Token & Secret)
getAccessToken = getAccessToken' id getAccessToken = getAccessToken' id
-- | Get Access token via the proxy. -- | Get Access token via the proxy.
getAccessTokenProxy, getTokenCredentialProxy getAccessTokenProxy, getTokenCredentialProxy
:: ResourceIO m :: (MonadResource m, MonadBaseControl IO m)
=> Maybe Proxy -- ^ Proxy => Maybe Proxy -- ^ Proxy
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
-> Manager -> Manager
-> ResourceT m Credential -- ^ Token Credential (Access Token & Secret) -> m Credential -- ^ Token Credential (Access Token & Secret)
getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p getAccessTokenProxy p = getAccessToken' $ addMaybeProxy p
getAccessToken' :: ResourceIO m getAccessToken' :: (MonadResource m, MonadBaseControl IO m)
=> (Request m -> Request m) -- ^ Request Hook => (Request m -> Request m) -- ^ Request Hook
-> OAuth -- ^ OAuth Application -> OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a) -> Credential -- ^ Temporary Credential (with oauth_verifier if >= 1.0a)
-> Manager -> Manager
-> ResourceT m Credential -- ^ Token Credential (Access Token & Secret) -> m Credential -- ^ Token Credential (Access Token & Secret)
getAccessToken' hook oa cr manager = do getAccessToken' hook oa cr manager = do
let req = hook (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } 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 rsp <- flip httpLbs manager =<< signOAuth oa (if oauthVersion oa == OAuth10 then delete "oauth_verifier" cr else cr) req
if statusCode rsp == status200 if responseStatus rsp == status200
then do then do
let dic = parseSimpleQuery . toStrict . responseBody $ rsp let dic = parseSimpleQuery . toStrict . responseBody $ rsp
return $ Credential dic return $ Credential dic
@ -271,11 +272,11 @@ injectVerifier :: BS.ByteString -> Credential -> Credential
injectVerifier = insert "oauth_verifier" injectVerifier = insert "oauth_verifier"
-- | Add OAuth headers & sign to 'Request'. -- | Add OAuth headers & sign to 'Request'.
signOAuth :: ResourceIO m signOAuth :: (MonadResource m)
=> OAuth -- ^ OAuth Application => OAuth -- ^ OAuth Application
-> Credential -- ^ Credential -> Credential -- ^ Credential
-> Request m -- ^ Original Request -> Request m -- ^ Original Request
-> ResourceT m (Request m) -- ^ Signed OAuth Request -> m (Request m) -- ^ Signed OAuth Request
signOAuth oa crd req = do signOAuth oa crd req = do
crd' <- addTimeStamp =<< addNonce crd crd' <- addTimeStamp =<< addNonce crd
let tok = injectOAuthToCred oa crd' let tok = injectOAuthToCred oa crd'
@ -296,14 +297,14 @@ showSigMtd PLAINTEXT = "PLAINTEXT"
showSigMtd HMACSHA1 = "HMAC-SHA1" showSigMtd HMACSHA1 = "HMAC-SHA1"
showSigMtd (RSASHA1 _) = "RSA-SHA1" showSigMtd (RSASHA1 _) = "RSA-SHA1"
addNonce :: ResourceIO m => Credential -> ResourceT m Credential addNonce :: MonadResource m => Credential -> m Credential
addNonce cred = do addNonce cred = do
nonce <- liftIO $ 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 return $ insert "oauth_nonce" (BS.pack nonce) cred
addTimeStamp :: ResourceIO m => Credential -> ResourceT m Credential addTimeStamp :: MonadResource m => Credential -> m Credential
addTimeStamp cred = do addTimeStamp cred = do
stamp <- floor . (`diffUTCTime` baseTime) <$> liftIO getCurrentTime stamp <- (floor . (`diffUTCTime` baseTime)) `liftM` liftIO getCurrentTime
return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred return $ insert "oauth_timestamp" (BS.pack $ show (stamp :: Integer)) cred
injectOAuthToCred :: OAuth -> Credential -> Credential injectOAuthToCred :: OAuth -> Credential -> Credential
@ -313,7 +314,7 @@ injectOAuthToCred oa cred =
, ("oauth_version", "1.0") , ("oauth_version", "1.0")
] cred ] cred
genSign :: ResourceIO m => OAuth -> Credential -> Request m -> ResourceT m BS.ByteString genSign :: MonadResource m => OAuth -> Credential -> Request m -> m BS.ByteString
genSign oa tok req = genSign oa tok req =
case oauthSignatureMethod oa of case oauthSignatureMethod oa of
HMACSHA1 -> do HMACSHA1 -> do
@ -341,7 +342,7 @@ paramEncode = BS.concatMap escape
oct = '%' : replicate (2 - length num) '0' ++ num oct = '%' : replicate (2 - length num) '0' ++ num
in BS.pack oct in BS.pack oct
getBaseString :: ResourceIO m => Credential -> Request m -> ResourceT m BSL.ByteString getBaseString :: MonadResource m => Credential -> Request m -> m BSL.ByteString
getBaseString tok req = do getBaseString tok req = do
let bsMtd = BS.map toUpper $ method req let bsMtd = BS.map toUpper $ method req
isHttps = secure req isHttps = secure req
@ -361,15 +362,15 @@ getBaseString tok req = do
-- So this is OK. -- So this is OK.
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
toLBS :: ResourceIO m => RequestBody m -> ResourceT m BS.ByteString toLBS :: MonadResource m => RequestBody m -> m BS.ByteString
toLBS (RequestBodyLBS l) = return $ toStrict l toLBS (RequestBodyLBS l) = return $ toStrict l
toLBS (RequestBodyBS s) = return s toLBS (RequestBodyBS s) = return s
toLBS (RequestBodyBuilder _ b) = return $ toByteString b toLBS (RequestBodyBuilder _ b) = return $ toByteString b
toLBS (RequestBodySource _ src) = toLBS' src toLBS (RequestBodySource _ src) = toLBS' src
toLBS (RequestBodySourceChunked src) = toLBS' src toLBS (RequestBodySourceChunked src) = toLBS' src
toLBS' :: ResourceIO m => Source m Builder -> ResourceT m BS.ByteString toLBS' :: MonadResource m => Source m Builder -> m BS.ByteString
toLBS' src = fmap BS.concat $ src $= builderToByteString $$ CL.consume toLBS' src = liftM BS.concat $ src $= builderToByteString $$ CL.consume
isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded :: [Header] -> Bool
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type" isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"

93
authenticate-oauth/Web/Authenticate/OAuth/IO.hs
View File

@ -1,95 +1,10 @@
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
-- | This Module provides interface for the instance of ResouceIO instead of ResourceT. -- | This module is deprecated due to the interface change at conduit-0.3.
-- What this module do is just adding 'withManager' or 'runResourceT'. -- For now, this package only re-exports 'Web.Authenticate.OAuth' module.
module Web.Authenticate.OAuth.IO module Web.Authenticate.OAuth.IO
{-# DEPRECATED "This module is deprecated; use Web.Authenticate.OAuth instead." #-}
( (
module Web.Authenticate.OAuth, module Web.Authenticate.OAuth,
getAccessToken, signOAuth,
getTemporaryCredential, getTemporaryCredentialWithScope,
getTemporaryCredentialProxy, getTemporaryCredential',
getTokenCredential,
getAccessTokenProxy, getTokenCredentialProxy,
getAccessToken', genSign
) where ) where
import Network.HTTP.Conduit import Web.Authenticate.OAuth
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

9
authenticate-oauth/authenticate-oauth.cabal
View File

@ -1,5 +1,5 @@
name: authenticate-oauth name: authenticate-oauth
version: 1.1 version: 1.2.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Hiromi Ishii author: Hiromi Ishii
@ -14,7 +14,7 @@ homepage: http://github.com/yesodweb/authenticate
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, http-conduit >= 1.2 && < 1.3 , http-conduit >= 1.3 && < 1.4
, transformers >= 0.1 && < 0.3 , transformers >= 0.1 && < 0.3
, bytestring >= 0.9 , bytestring >= 0.9
, RSA >= 1.0 && < 1.1 , RSA >= 1.0 && < 1.1
@ -25,8 +25,9 @@ library
, random , random
, http-types >= 0.6 && < 0.7 , http-types >= 0.6 && < 0.7
, blaze-builder , blaze-builder
, conduit >= 0.2 && < 0.3 , conduit >= 0.3 && < 0.4
, blaze-builder-conduit >= 0.2 && < 0.3 , blaze-builder-conduit >= 0.3 && < 0.4
, monad-control >= 0.3 && < 0.4
exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO exposed-modules: Web.Authenticate.OAuth, Web.Authenticate.OAuth.IO
ghc-options: -Wall ghc-options: -Wall