Move to conduits

This commit is contained in:
Michael Snoyman 2011-12-27 23:39:24 +02:00
parent 88c14135b3
commit dca8501d7f
7 changed files with 33 additions and 55 deletions

View File

@ -26,7 +26,7 @@ import Debug.Trace
-- Libraries
import Data.Char
import Data.Maybe
import Network.HTTP.Enumerator
import Network.HTTP.Conduit
import qualified Data.ByteString.Char8 as S8
import Control.Arrow (first)
import Control.Monad.IO.Class (MonadIO (liftIO))
@ -46,12 +46,7 @@ data Discovery = Discovery1 Text (Maybe Text)
deriving Show
-- | Attempt to resolve an OpenID endpoint, and user identifier.
discover :: ( MonadIO m
, Failure AuthenticateException m
, Failure HttpException m
)
=> Identifier
-> m Discovery
discover :: Identifier -> IO Discovery
discover ident@(Identifier i) = do
res1 <- discoverYADIS ident Nothing 10
case res1 of
@ -66,13 +61,10 @@ discover ident@(Identifier i) = do
-- | Attempt a YADIS based discovery, given a valid identifier. The result is
-- an OpenID endpoint, and the actual identifier for the user.
discoverYADIS :: ( MonadIO m
, Failure HttpException m
)
=> Identifier
discoverYADIS :: Identifier
-> Maybe String
-> Int -- ^ remaining redirects
-> m (Maybe (Provider, Identifier, IdentType))
-> IO (Maybe (Provider, Identifier, IdentType))
discoverYADIS _ _ 0 = failure TooManyRedirects
discoverYADIS ident mb_loc redirects = do
let uri = fromMaybe (unpack $ identifier ident) mb_loc
@ -120,9 +112,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
-- | Attempt to discover an OpenID endpoint, from an HTML document. The result
-- will be an endpoint on success, and the actual identifier of the user.
discoverHTML :: ( MonadIO m, Failure HttpException m)
=> Identifier
-> m (Maybe Discovery)
discoverHTML :: Identifier -> IO (Maybe Discovery)
discoverHTML ident'@(Identifier ident) =
(parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident)

View File

@ -1,19 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Web.Authenticate.BrowserId
( browserIdJs
, checkAssertion
) where
import Data.Text (Text)
import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody)
import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody)
import Data.Aeson (json, Value (Object, String))
import Data.Attoparsec.Lazy (parse, maybeResult)
#if MIN_VERSION_aeson(0, 4, 0)
import qualified Data.HashMap.Lazy as Map
#else
import qualified Data.Map as Map
#endif
import Data.Text.Encoding (encodeUtf8)
-- | Location of the Javascript file hosted by browserid.org

View File

@ -13,7 +13,7 @@ module Web.Authenticate.Facebook
, getLogoutUrl
) where
import Network.HTTP.Enumerator
import Network.HTTP.Conduit
import Network.HTTP.Types (parseSimpleQuery)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as L8

View File

@ -16,7 +16,7 @@ module Web.Authenticate.OAuth
-- * Utility Methods
paramEncode, addScope, addMaybeProxy
) where
import Network.HTTP.Enumerator
import Network.HTTP.Conduit
import Data.Data
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
@ -36,11 +36,12 @@ import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))
import Network.HTTP.Types (Header)
import Control.Arrow (second)
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)
import Control.Monad.IO.Class (MonadIO)
import Network.HTTP.Types (renderSimpleQuery)
import Data.Conduit (ResourceIO, runResourceT, ($$), ($=), Source)
import qualified Data.Conduit.List as CL
import Data.Conduit.Blaze (builderToByteString)
import Blaze.ByteString.Builder (Builder)
-- | Data type for OAuth client (consumer).
data OAuth = OAuth { oauthServerName :: String -- ^ Service name
@ -226,7 +227,7 @@ injectOAuthToCred oa cred =
, ("oauth_version", "1.0")
] cred
genSign :: MonadIO m => OAuth -> Credential -> Request m -> m BS.ByteString
genSign :: ResourceIO m => OAuth -> Credential -> Request m -> m BS.ByteString
genSign oa tok req =
case oauthSignatureMethod oa of
HMACSHA1 -> do
@ -254,7 +255,7 @@ paramEncode = BS.concatMap escape
oct = '%' : replicate (2 - length num) '0' ++ num
in BS.pack oct
getBaseString :: MonadIO m => Credential -> Request m -> m BSL.ByteString
getBaseString :: ResourceIO m => Credential -> Request m -> m BSL.ByteString
getBaseString tok req = do
let bsMtd = BS.map toUpper $ method req
isHttps = secure req
@ -274,23 +275,15 @@ getBaseString tok req = do
-- So this is OK.
return $ BSL.intercalate "&" $ map (fromStrict.paramEncode) [bsMtd, bsURI, bsParams]
toLBS :: MonadIO m => RequestBody m -> m BS.ByteString
toLBS :: ResourceIO 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 ()
toLBS (RequestBodySource _ src) = toLBS' src
toLBS (RequestBodySourceChunked src) = toLBS' src
toLBS' :: ResourceIO m => Source m Builder -> m BS.ByteString
toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume
isBodyFormEncoded :: [Header] -> Bool
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"

View File

@ -16,7 +16,7 @@ import Control.Monad (unless)
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy (toStrict)
import Network.HTTP.Enumerator
import Network.HTTP.Conduit
( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
, HttpException, withManager
)
@ -41,7 +41,7 @@ getForwardUrl
-> m Text -- ^ URL to send the user to.
getForwardUrl openid' complete mrealm params = do
let realm = fromMaybe complete mrealm
disc <- normalize openid' >>= discover
disc <- liftIO $ normalize openid' >>= discover
let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q)
case disc of
Discovery1 server mdelegate -> helper server
@ -86,7 +86,7 @@ authenticate params = do
Just i -> return i
Nothing ->
failure $ AuthenticationException "Missing identity"
disc <- normalize ident >>= discover
disc <- liftIO $ normalize ident >>= discover
let endpoint = case disc of
Discovery1 p _ -> p
Discovery2 (Provider p) _ _ -> p

View File

@ -1,6 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
@ -23,8 +22,8 @@ module Web.Authenticate.Rpxnow
) where
import Data.Aeson
import Network.HTTP.Enumerator
import "transformers" Control.Monad.IO.Class
import Network.HTTP.Conduit
import Control.Monad.IO.Class
import Control.Failure
import Data.Maybe
import Control.Monad

View File

@ -1,5 +1,5 @@
name: authenticate
version: 0.10.4
version: 0.11.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman, Hiromi Ishii, Arash Rouhani
@ -15,8 +15,8 @@ homepage: http://github.com/yesodweb/authenticate
library
build-depends: base >= 4 && < 5,
aeson >= 0.3.2.11,
http-enumerator >= 0.6.5.4 && < 0.8,
aeson >= 0.5,
http-conduit >= 1.0 && < 1.1,
tagsoup >= 0.12 && < 0.13,
failure >= 0.0.0 && < 0.2,
transformers >= 0.1 && < 0.3,
@ -30,14 +30,15 @@ library
random >= 1.0 && < 1.1,
text >= 0.5 && < 1.0,
http-types >= 0.6 && < 0.7,
enumerator >= 0.4.7 && < 0.5,
xml-enumerator >= 0.4 && < 0.5,
xml-conduit >= 0.5 && < 0.6,
blaze-builder >= 0.2 && < 0.4,
attoparsec >= 0.9,
tls >= 0.7 && < 0.9,
containers,
unordered-containers,
process >= 1.0.1.1 && < 1.2
process >= 1.0.1.1 && < 1.2,
conduit >= 0.0 && < 0.1,
blaze-builder-conduit >= 0.0 && < 0.1
exposed-modules: Web.Authenticate.Rpxnow,
Web.Authenticate.OpenId,
Web.Authenticate.BrowserId,