Move to conduits
This commit is contained in:
parent
88c14135b3
commit
dca8501d7f
@ -26,7 +26,7 @@ import Debug.Trace
|
|||||||
-- Libraries
|
-- Libraries
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Network.HTTP.Enumerator
|
import Network.HTTP.Conduit
|
||||||
import qualified Data.ByteString.Char8 as S8
|
import qualified Data.ByteString.Char8 as S8
|
||||||
import Control.Arrow (first)
|
import Control.Arrow (first)
|
||||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
import Control.Monad.IO.Class (MonadIO (liftIO))
|
||||||
@ -46,12 +46,7 @@ data Discovery = Discovery1 Text (Maybe Text)
|
|||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
-- | Attempt to resolve an OpenID endpoint, and user identifier.
|
-- | Attempt to resolve an OpenID endpoint, and user identifier.
|
||||||
discover :: ( MonadIO m
|
discover :: Identifier -> IO Discovery
|
||||||
, Failure AuthenticateException m
|
|
||||||
, Failure HttpException m
|
|
||||||
)
|
|
||||||
=> Identifier
|
|
||||||
-> m Discovery
|
|
||||||
discover ident@(Identifier i) = do
|
discover ident@(Identifier i) = do
|
||||||
res1 <- discoverYADIS ident Nothing 10
|
res1 <- discoverYADIS ident Nothing 10
|
||||||
case res1 of
|
case res1 of
|
||||||
@ -66,13 +61,10 @@ discover ident@(Identifier i) = do
|
|||||||
|
|
||||||
-- | Attempt a YADIS based discovery, given a valid identifier. The result is
|
-- | Attempt a YADIS based discovery, given a valid identifier. The result is
|
||||||
-- an OpenID endpoint, and the actual identifier for the user.
|
-- an OpenID endpoint, and the actual identifier for the user.
|
||||||
discoverYADIS :: ( MonadIO m
|
discoverYADIS :: Identifier
|
||||||
, Failure HttpException m
|
|
||||||
)
|
|
||||||
=> Identifier
|
|
||||||
-> Maybe String
|
-> Maybe String
|
||||||
-> Int -- ^ remaining redirects
|
-> Int -- ^ remaining redirects
|
||||||
-> m (Maybe (Provider, Identifier, IdentType))
|
-> IO (Maybe (Provider, Identifier, IdentType))
|
||||||
discoverYADIS _ _ 0 = failure TooManyRedirects
|
discoverYADIS _ _ 0 = failure TooManyRedirects
|
||||||
discoverYADIS ident mb_loc redirects = do
|
discoverYADIS ident mb_loc redirects = do
|
||||||
let uri = fromMaybe (unpack $ identifier ident) mb_loc
|
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
|
-- | 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.
|
-- will be an endpoint on success, and the actual identifier of the user.
|
||||||
discoverHTML :: ( MonadIO m, Failure HttpException m)
|
discoverHTML :: Identifier -> IO (Maybe Discovery)
|
||||||
=> Identifier
|
|
||||||
-> m (Maybe Discovery)
|
|
||||||
discoverHTML ident'@(Identifier ident) =
|
discoverHTML ident'@(Identifier ident) =
|
||||||
(parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident)
|
(parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident)
|
||||||
|
|
||||||
|
|||||||
@ -1,19 +1,14 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
module Web.Authenticate.BrowserId
|
module Web.Authenticate.BrowserId
|
||||||
( browserIdJs
|
( browserIdJs
|
||||||
, checkAssertion
|
, checkAssertion
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Text (Text)
|
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.Aeson (json, Value (Object, String))
|
||||||
import Data.Attoparsec.Lazy (parse, maybeResult)
|
import Data.Attoparsec.Lazy (parse, maybeResult)
|
||||||
#if MIN_VERSION_aeson(0, 4, 0)
|
|
||||||
import qualified Data.HashMap.Lazy as Map
|
import qualified Data.HashMap.Lazy as Map
|
||||||
#else
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
#endif
|
|
||||||
import Data.Text.Encoding (encodeUtf8)
|
import Data.Text.Encoding (encodeUtf8)
|
||||||
|
|
||||||
-- | Location of the Javascript file hosted by browserid.org
|
-- | Location of the Javascript file hosted by browserid.org
|
||||||
|
|||||||
@ -13,7 +13,7 @@ module Web.Authenticate.Facebook
|
|||||||
, getLogoutUrl
|
, getLogoutUrl
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Network.HTTP.Enumerator
|
import Network.HTTP.Conduit
|
||||||
import Network.HTTP.Types (parseSimpleQuery)
|
import Network.HTTP.Types (parseSimpleQuery)
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||||
|
|||||||
@ -16,7 +16,7 @@ module Web.Authenticate.OAuth
|
|||||||
-- * Utility Methods
|
-- * Utility Methods
|
||||||
paramEncode, addScope, addMaybeProxy
|
paramEncode, addScope, addMaybeProxy
|
||||||
) where
|
) where
|
||||||
import Network.HTTP.Enumerator
|
import Network.HTTP.Conduit
|
||||||
import Data.Data
|
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
|
||||||
@ -36,11 +36,12 @@ import Codec.Crypto.RSA (rsassa_pkcs1_v1_5_sign, ha_SHA1, PrivateKey(..))
|
|||||||
import Network.HTTP.Types (Header)
|
import Network.HTTP.Types (Header)
|
||||||
import Control.Arrow (second)
|
import Control.Arrow (second)
|
||||||
import Blaze.ByteString.Builder (toByteString)
|
import Blaze.ByteString.Builder (toByteString)
|
||||||
import Data.Enumerator (($$), run_, Stream (..), continue)
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
import Data.Monoid (mconcat)
|
|
||||||
import Control.Monad.IO.Class (MonadIO (liftIO))
|
|
||||||
import Data.IORef (newIORef, readIORef, atomicModifyIORef)
|
|
||||||
import Network.HTTP.Types (renderSimpleQuery)
|
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 type for OAuth client (consumer).
|
||||||
data OAuth = OAuth { oauthServerName :: String -- ^ Service name
|
data OAuth = OAuth { oauthServerName :: String -- ^ Service name
|
||||||
@ -226,7 +227,7 @@ injectOAuthToCred oa cred =
|
|||||||
, ("oauth_version", "1.0")
|
, ("oauth_version", "1.0")
|
||||||
] cred
|
] 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 =
|
genSign oa tok req =
|
||||||
case oauthSignatureMethod oa of
|
case oauthSignatureMethod oa of
|
||||||
HMACSHA1 -> do
|
HMACSHA1 -> do
|
||||||
@ -254,7 +255,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 :: MonadIO m => Credential -> Request m -> m BSL.ByteString
|
getBaseString :: ResourceIO 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
|
||||||
@ -274,23 +275,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 :: MonadIO m => RequestBody m -> m BS.ByteString
|
toLBS :: ResourceIO 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 (RequestBodyEnum _ enum) = do
|
toLBS (RequestBodySource _ src) = toLBS' src
|
||||||
i <- liftIO $ newIORef id
|
toLBS (RequestBodySourceChunked src) = toLBS' src
|
||||||
run_ $ enum $$ go i
|
|
||||||
liftIO $ liftM (toByteString . mconcat . ($ [])) $ readIORef i
|
toLBS' :: ResourceIO m => Source m Builder -> m BS.ByteString
|
||||||
where
|
toLBS' src = fmap BS.concat $ runResourceT $ src $= builderToByteString $$ CL.consume
|
||||||
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 :: [Header] -> Bool
|
||||||
isBodyFormEncoded = maybe False (=="application/x-www-form-urlencoded") . lookup "Content-Type"
|
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.Lazy.Encoding (decodeUtf8With)
|
||||||
import Data.Text.Encoding.Error (lenientDecode)
|
import Data.Text.Encoding.Error (lenientDecode)
|
||||||
import Data.Text.Lazy (toStrict)
|
import Data.Text.Lazy (toStrict)
|
||||||
import Network.HTTP.Enumerator
|
import Network.HTTP.Conduit
|
||||||
( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
|
( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
|
||||||
, HttpException, withManager
|
, HttpException, withManager
|
||||||
)
|
)
|
||||||
@ -41,7 +41,7 @@ getForwardUrl
|
|||||||
-> m Text -- ^ URL to send the user to.
|
-> m Text -- ^ URL to send the user to.
|
||||||
getForwardUrl openid' complete mrealm params = do
|
getForwardUrl openid' complete mrealm params = do
|
||||||
let realm = fromMaybe complete mrealm
|
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)
|
let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q)
|
||||||
case disc of
|
case disc of
|
||||||
Discovery1 server mdelegate -> helper server
|
Discovery1 server mdelegate -> helper server
|
||||||
@ -86,7 +86,7 @@ authenticate params = do
|
|||||||
Just i -> return i
|
Just i -> return i
|
||||||
Nothing ->
|
Nothing ->
|
||||||
failure $ AuthenticationException "Missing identity"
|
failure $ AuthenticationException "Missing identity"
|
||||||
disc <- normalize ident >>= discover
|
disc <- liftIO $ normalize ident >>= discover
|
||||||
let endpoint = case disc of
|
let endpoint = case disc of
|
||||||
Discovery1 p _ -> p
|
Discovery1 p _ -> p
|
||||||
Discovery2 (Provider p) _ _ -> p
|
Discovery2 (Provider p) _ _ -> p
|
||||||
|
|||||||
@ -1,6 +1,5 @@
|
|||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
@ -23,8 +22,8 @@ module Web.Authenticate.Rpxnow
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Network.HTTP.Enumerator
|
import Network.HTTP.Conduit
|
||||||
import "transformers" Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Failure
|
import Control.Failure
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: authenticate
|
name: authenticate
|
||||||
version: 0.10.4
|
version: 0.11.0
|
||||||
license: BSD3
|
license: BSD3
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Michael Snoyman, Hiromi Ishii, Arash Rouhani
|
author: Michael Snoyman, Hiromi Ishii, Arash Rouhani
|
||||||
@ -15,8 +15,8 @@ homepage: http://github.com/yesodweb/authenticate
|
|||||||
|
|
||||||
library
|
library
|
||||||
build-depends: base >= 4 && < 5,
|
build-depends: base >= 4 && < 5,
|
||||||
aeson >= 0.3.2.11,
|
aeson >= 0.5,
|
||||||
http-enumerator >= 0.6.5.4 && < 0.8,
|
http-conduit >= 1.0 && < 1.1,
|
||||||
tagsoup >= 0.12 && < 0.13,
|
tagsoup >= 0.12 && < 0.13,
|
||||||
failure >= 0.0.0 && < 0.2,
|
failure >= 0.0.0 && < 0.2,
|
||||||
transformers >= 0.1 && < 0.3,
|
transformers >= 0.1 && < 0.3,
|
||||||
@ -30,14 +30,15 @@ library
|
|||||||
random >= 1.0 && < 1.1,
|
random >= 1.0 && < 1.1,
|
||||||
text >= 0.5 && < 1.0,
|
text >= 0.5 && < 1.0,
|
||||||
http-types >= 0.6 && < 0.7,
|
http-types >= 0.6 && < 0.7,
|
||||||
enumerator >= 0.4.7 && < 0.5,
|
xml-conduit >= 0.5 && < 0.6,
|
||||||
xml-enumerator >= 0.4 && < 0.5,
|
|
||||||
blaze-builder >= 0.2 && < 0.4,
|
blaze-builder >= 0.2 && < 0.4,
|
||||||
attoparsec >= 0.9,
|
attoparsec >= 0.9,
|
||||||
tls >= 0.7 && < 0.9,
|
tls >= 0.7 && < 0.9,
|
||||||
containers,
|
containers,
|
||||||
unordered-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,
|
exposed-modules: Web.Authenticate.Rpxnow,
|
||||||
Web.Authenticate.OpenId,
|
Web.Authenticate.OpenId,
|
||||||
Web.Authenticate.BrowserId,
|
Web.Authenticate.BrowserId,
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user