Move to conduits
This commit is contained in:
parent
88c14135b3
commit
dca8501d7f
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user