From 572df52d034a3d46de99a7e2419c04ff4846b660 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 28 Mar 2011 07:22:53 +0200 Subject: [PATCH] http-enumerator 0.5 --- OpenId2/Discovery.hs | 12 +++--- Web/Authenticate/Facebook.hs | 5 ++- Web/Authenticate/OAuth.hs | 76 ++++++++++++++++++++++++------------ Web/Authenticate/OpenId.hs | 7 ++-- Web/Authenticate/Rpxnow.hs | 5 ++- authenticate.cabal | 7 +++- 6 files changed, 72 insertions(+), 40 deletions(-) diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs index dde4d019..298ea885 100644 --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -29,10 +29,10 @@ import Network.HTTP.Enumerator import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first, (***)) -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM) -import Network.Wai (ciOriginal) +import qualified Data.CaseInsensitive as CI data Discovery = Discovery1 String (Maybe String) | Discovery2 Provider Identifier IdentType @@ -69,11 +69,11 @@ discoverYADIS :: ( MonadIO m discoverYADIS _ _ 0 = failure TooManyRedirects discoverYADIS ident mb_loc redirects = do let uri = fromMaybe (identifier ident) mb_loc - req <- parseUrl uri - res <- httpLbs req + req <- parseUrl $ S8.pack uri + res <- liftIO $ withManager $ httpLbs req let mloc = fmap S8.unpack $ lookup "x-xrds-location" - $ map (first $ map toLower . S8.unpack . ciOriginal) + $ map (first $ map toLower . S8.unpack . CI.original) $ responseHeaders res let mloc' = if mloc == mb_loc then Nothing else mloc case statusCode res of @@ -117,7 +117,7 @@ discoverHTML :: ( MonadIO m, Failure HttpException m) => Identifier -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) = - (parseHTML ident' . BSLU.toString) `liftM` simpleHttp ident + (parseHTML ident' . BSLU.toString) `liftM` simpleHttp (S8.pack ident) -- | Parse out an OpenID endpoint and an actual identifier from an HTML -- document. diff --git a/Web/Authenticate/Facebook.hs b/Web/Authenticate/Facebook.hs index b0945ff6..73cc67c1 100644 --- a/Web/Authenticate/Facebook.hs +++ b/Web/Authenticate/Facebook.hs @@ -11,6 +11,7 @@ import Data.Data (Data) import Data.Typeable (Typeable) import Control.Exception (Exception, throwIO) import Data.Attoparsec.Lazy (parse, eitherResult) +import qualified Data.ByteString.Char8 as S8 data Facebook = Facebook { facebookClientId :: String @@ -48,7 +49,7 @@ accessTokenUrl fb code = concat getAccessToken :: Facebook -> String -> IO AccessToken getAccessToken fb code = do let url = accessTokenUrl fb code - b <- simpleHttp url + b <- simpleHttp $ S8.pack url let (front, back) = splitAt 13 $ L8.unpack b case front of "access_token=" -> return $ AccessToken back @@ -65,7 +66,7 @@ graphUrl (AccessToken s) func = concat getGraphData :: AccessToken -> String -> IO (Either String Value) getGraphData at func = do let url = graphUrl at func - b <- simpleHttp url + b <- simpleHttp $ S8.pack url return $ eitherResult $ parse json b getGraphData' :: AccessToken -> String -> IO Value diff --git a/Web/Authenticate/OAuth.hs b/Web/Authenticate/OAuth.hs index a43e7586..d58ff2bc 100644 --- a/Web/Authenticate/OAuth.hs +++ b/Web/Authenticate/OAuth.hs @@ -30,9 +30,15 @@ import Data.Digest.Pure.SHA 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 Control.Arrow (second) +import qualified Data.ByteString.Char8 as S8 +import Blaze.ByteString.Builder (toByteString) +import Data.Enumerator (($$), run_, Stream (..), continue) +import Data.Monoid (mconcat) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.IORef (newIORef, readIORef, atomicModifyIORef) -- | Data type for OAuth client (consumer). data OAuth = OAuth { oauthServerName :: String -- ^ Service name @@ -85,9 +91,9 @@ fromStrict = BSL.fromChunks . return getTemporaryCredential :: OAuth -- ^ OAuth Application -> IO Credential -- ^ Temporary Credential (Request Token & Secret). getTemporaryCredential oa = do - let req = fromJust $ parseUrl (oauthRequestUri oa) + let req = fromJust $ parseUrl $ S8.pack $ oauthRequestUri oa req' <- signOAuth oa emptyCredential (req { method = "POST" }) - rsp <- httpLbs req' + rsp <- withManager $ httpLbs req' let dic = parseQueryString . toStrict . responseBody $ rsp return $ Credential dic @@ -103,8 +109,8 @@ getAccessToken, getTokenCredential -> Credential -- ^ Temporary Credential with oauth_verifier -> IO Credential -- ^ Token Credential (Access Token & Secret) getAccessToken oa cr = do - let req = (fromJust $ parseUrl $ oauthAccessTokenUri oa) { method = "POST" } - rsp <- signOAuth oa cr req >>= httpLbs + let req = (fromJust $ parseUrl $ S8.pack $ oauthAccessTokenUri oa) { method = "POST" } + rsp <- signOAuth oa cr req >>= withManager . httpLbs let dic = parseQueryString . toStrict . responseBody $ rsp return $ Credential dic @@ -136,12 +142,12 @@ delete key = Credential . deleteMap key . unCredential -- | Add OAuth headers & sign to 'Request'. signOAuth :: OAuth -- ^ OAuth Application -> Credential -- ^ Credential - -> Request -- ^ Original Request - -> IO Request -- ^ Signed OAuth Request + -> Request IO -- ^ Original Request + -> IO (Request IO) -- ^ Signed OAuth Request signOAuth oa crd req = do crd' <- addTimeStamp =<< addNonce crd let tok = injectOAuthToCred oa crd' - sign = genSign oa tok req + sign <- genSign oa tok req return $ addAuthHeader (insert "oauth_signature" sign tok) req baseTime :: UTCTime @@ -171,19 +177,19 @@ injectOAuthToCred oa cred = maybe id (insert "oauth_callback") (oauthCallback oa , ("oauth_version", "1.0") ] cred -genSign :: OAuth -> Credential -> Request -> BS.ByteString +genSign :: MonadIO m => OAuth -> Credential -> Request m -> 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 -> Request a -> Request a addAuthHeader (Credential cred) req = req { requestHeaders = insertMap "Authorization" (renderAuthHeader cred) $ requestHeaders req } @@ -199,24 +205,44 @@ paramEncode = BS.concatMap escape oct = '%' : replicate (2 - length num) '0' ++ num in BS.pack oct -getBaseString :: Credential -> Request -> BSL.ByteString -getBaseString tok req = +getBaseString :: MonadIO m => Credential -> Request m -> 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_token_secret"]).fst) $ unCredential tok + bsQuery = map (second $ fromMaybe "") $ queryString req + bsBodyQ <- if isBodyFormEncoded $ requestHeaders req + then liftM parseQueryString $ toLBS (requestBody req) + else return [] + let bsAuthParams = filter ((`notElem`["oauth_signature","realm", "oauth_token_secret"]).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] + -- FIXME it would be much better to use http-types functions here + return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams] -isBodyFormEncoded :: [(ResponseHeader, BS.ByteString)] -> Bool +toLBS :: MonadIO m => RequestBody m -> m BS.ByteString +toLBS (RequestBodyLBS l) = return $ toStrict l +toLBS (RequestBodyBS s) = return s +toLBS (RequestBodyBuilder _ b) = return $ toByteString b +toLBS (RequestBodyEnum _ enum) = do + i <- liftIO $ newIORef id + run_ $ enum $$ go i + liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i + where + go i = + continue go' + where + go' (Chunks []) = continue go' + go' (Chunks x) = do + liftIO (atomicModifyIORef i $ \y -> (y . (x ++), ())) + continue go' + go' EOF = return () + +isBodyFormEncoded :: [Header] -> Bool isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type" compareTuple :: (Ord a, Ord b) => (a, b) -> (a, b) -> Ordering diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs index 73df129c..bb5cc508 100644 --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -14,10 +14,11 @@ import OpenId2.Types import Web.Authenticate.Internal (qsUrl) import Control.Monad (unless) import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.UTF8 as BSLU import Network.HTTP.Enumerator ( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect - , HttpException + , HttpException, withManager ) import Control.Arrow ((***)) import Data.List (unfoldr) @@ -87,9 +88,9 @@ authenticate params = do let params' = map (BSU.fromString *** BSU.fromString) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params - req' <- parseUrl endpoint + req' <- parseUrl $ S8.pack endpoint let req = urlEncodedBody params' req' - rsp <- httpLbsRedirect req + rsp <- liftIO $ withManager $ httpLbsRedirect req let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp case lookup "is_valid" rps of Just "true" -> return (Identifier ident, rps) diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs index 7ce7e018..23defbe5 100644 --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -71,9 +71,10 @@ authenticate apiKey token = do , requestHeaders = [ ("Content-Type", "application/x-www-form-urlencoded") ] - , requestBody = body + , requestBody = RequestBodyLBS body + , checkCerts = const $ return True } - res <- httpLbsRedirect req + res <- liftIO $ withManager $ httpLbsRedirect req let b = responseBody res unless (200 <= statusCode res && statusCode res < 300) $ liftIO $ throwIO $ StatusCodeException (statusCode res) b diff --git a/authenticate.cabal b/authenticate.cabal index 7bfe432c..05455d66 100644 --- a/authenticate.cabal +++ b/authenticate.cabal @@ -16,7 +16,7 @@ homepage: http://github.com/snoyberg/authenticate/tree/master library build-depends: base >= 4 && < 5, aeson >= 0.3.1.1 && < 0.4, - http-enumerator >= 0.3.0 && < 0.4, + http-enumerator >= 0.5.1 && < 0.6, tagsoup >= 0.6 && < 0.13, failure >= 0.0.0 && < 0.2, transformers >= 0.1 && < 0.3, @@ -24,7 +24,7 @@ library utf8-string >= 0.3 && < 0.4, network >= 2.2.1 && < 2.4, xml >= 1.3.7 && < 1.4, - wai >= 0.3 && < 0.4, + case-insensitive >= 0.2 && < 0.3, RSA >= 1.0 && < 1.1, time >= 1.1 && < 1.3, base64-bytestring >= 0.1 && < 0.2, @@ -32,6 +32,9 @@ library random >= 1.0 && < 1.1, wai-extra >= 0.3 && < 0.4, text >= 0.5 && < 1.0, + http-types >= 0.6 && < 0.7, + enumerator >= 0.4.7 && < 0.5, + blaze-builder >= 0.2 && < 0.4, attoparsec >= 0.8.5 && < 0.9 exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId,