authenticate 1.3.2.10 → 1.3.5.2
raw patch · 9 files changed
Files
- ChangeLog.md +29/−0
- LICENSE +17/−22
- OpenId2/Discovery.hs +33/−27
- README.md +5/−0
- Web/Authenticate/BrowserId.hs +14/−6
- Web/Authenticate/OpenId.hs +5/−7
- Web/Authenticate/OpenId/Providers.hs +1/−0
- Web/Authenticate/Rpxnow.hs +15/−5
- authenticate.cabal +9/−10
+ ChangeLog.md view
@@ -0,0 +1,29 @@+# authenticate changelog++## 1.3.5.2++* Support for aeson-2.2 [#61](https://github.com/yesodweb/authenticate/pull/61)++## 1.3.5.1++* Support for aeson-2.0 [#56](https://github.com/yesodweb/authenticate/pull/56)++## 1.3.5++* Drop tagstream-conduit dep (for GHC 8.8 support)++## 1.3.4++* Relaxed a bunch of type signatures++## 1.3.3.2++* Support for http-conduit-2.2.0 [#47](https://github.com/yesodweb/authenticate/issues/47)++## 1.3.3.1++* License update [#46](https://github.com/yesodweb/authenticate/issues/46)++## 1.3.3++Deprecated Google OpenID support
LICENSE view
@@ -1,25 +1,20 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2008, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
OpenId2/Discovery.hs view
@@ -30,7 +30,7 @@ import qualified Data.ByteString.Char8 as S8 import Control.Arrow (first) import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad (mplus, liftM)+import Control.Monad (mplus, liftM, guard) import qualified Data.CaseInsensitive as CI import Data.Text (Text, unpack) import Data.Text.Lazy (toStrict)@@ -40,19 +40,17 @@ import Control.Applicative ((<$>), (<*>)) import Network.HTTP.Types (status200) import Control.Exception (throwIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadResource)-import Data.Conduit ((=$), ($$), yield)-import Text.HTML.TagStream.Text (tokenStream, Token)-import Text.HTML.TagStream.Types (Token' (TagOpen))-import qualified Data.Conduit.List as CL+import Text.HTML.DOM+import Text.XML.Cursor+import Text.XML (Node (..), Element (..))+import qualified Data.Map as Map data Discovery = Discovery1 Text (Maybe Text) | Discovery2 Provider Identifier IdentType deriving Show -- | Attempt to resolve an OpenID endpoint, and user identifier.-discover :: (MonadBaseControl IO m, MonadIO m, MonadResource m) => Identifier -> Manager -> m Discovery+discover :: MonadIO m => Identifier -> Manager -> m Discovery discover ident@(Identifier i) manager = do res1 <- discoverYADIS ident Nothing 10 manager case res1 of@@ -67,26 +65,38 @@ -- | Attempt a YADIS based discovery, given a valid identifier. The result is -- an OpenID endpoint, and the actual identifier for the user.-discoverYADIS :: (MonadResource m, MonadBaseControl IO m)+discoverYADIS :: MonadIO m => Identifier -> Maybe String -> Int -- ^ remaining redirects -> Manager -> m (Maybe (Provider, Identifier, IdentType))-discoverYADIS _ _ 0 _ = liftIO $ throwIO $ TooManyRedirects+discoverYADIS _ _ 0 _ =+#if MIN_VERSION_http_conduit(2, 2, 0)+ error "discoverYADIS: Too many redirects"+#else+ liftIO $ throwIO $ TooManyRedirects #if MIN_VERSION_http_conduit(1,6,0)- []+ [] #endif+#endif discoverYADIS ident mb_loc redirects manager = do let uri = fromMaybe (unpack $ identifier ident) mb_loc+#if MIN_VERSION_http_conduit(2, 2, 0)+ req <- liftIO $ parseRequest uri+#else req <- liftIO $ parseUrl uri+#endif res <- httpLbs req+#if !MIN_VERSION_http_conduit(2, 2, 0) #if MIN_VERSION_http_conduit(1, 9, 0) { checkStatus = \_ _ _ -> Nothing #else { checkStatus = \_ _ -> Nothing #endif- } manager+ }+#endif+ manager let mloc = fmap S8.unpack $ lookup "x-xrds-location" $ map (first $ map toLower . S8.unpack . CI.original)@@ -129,9 +139,9 @@ -- | 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 :: (MonadResource m, MonadBaseControl IO m) => Identifier -> Manager -> m (Maybe Discovery)+discoverHTML :: MonadIO m => Identifier -> Manager -> m (Maybe Discovery) discoverHTML ident'@(Identifier ident) manager = do- req <- liftIO $ parseUrl $ unpack ident+ req <- liftIO $ parseUrlThrow $ unpack ident lbs <- liftM responseBody $ httpLbs req manager return $ parseHTML ident' . toStrict . decodeUtf8With lenientDecode $ lbs @@ -139,15 +149,17 @@ -- document. parseHTML :: Identifier -> Text -> Maybe Discovery parseHTML ident text0 = do- ls <- yield text0- $$ tokenStream- =$ CL.mapMaybe linkTag- =$ CL.filter isOpenId- =$ CL.consume+ let doc = parseSTChunks [text0]+ cursor = fromDocument doc+ links = map node $ cursor $// element "link"+ ls = do+ NodeElement (Element "link" as _) <- links+ Just rel <- pure $ Map.lookup "rel" as+ Just href <- pure $ Map.lookup "href" as+ guard $ "openid" `T.isPrefixOf` rel+ pure (rel, href) resolve ls where- isOpenId (rel, _x) = "openid" `T.isPrefixOf` rel- resolve1 ls = do server <- lookup "openid.server" ls let delegate = lookup "openid.delegate" ls@@ -160,9 +172,3 @@ return $ Discovery2 (Provider prov) lid ClaimedIdent resolve ls = resolve2 ls `mplus` resolve1 ls----- | Filter out link tags from a list of html tags.-linkTag :: Token -> Maybe (Text, Text)-linkTag (TagOpen "link" as _) = (,) <$> lookup "rel" as <*> lookup "href" as-linkTag _x = Nothing
+ README.md view
@@ -0,0 +1,5 @@+## authenticate++Focus is on third-party authentication methods, such as OpenID and BrowserID.++Note: Facebook support is now provided by [the fb package](http://www.stackage.org/package/fb).
Web/Authenticate/BrowserId.hs view
@@ -1,31 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} module Web.Authenticate.BrowserId ( browserIdJs , checkAssertion ) where import Data.Text (Text)-import Network.HTTP.Conduit (parseUrl, responseBody, httpLbs, Manager, method, urlEncodedBody)+import Network.HTTP.Conduit (parseUrlThrow, responseBody, httpLbs, Manager, method, urlEncodedBody)+#if MIN_VERSION_aeson(2,2,0)+import Data.Aeson (Value (Object, String))+import Data.Aeson.Parser (json)+#else import Data.Aeson (json, Value (Object, String))+#endif import Data.Attoparsec.Lazy (parse, maybeResult)+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as Map+#else import qualified Data.HashMap.Lazy as Map+#endif import Data.Text.Encoding (encodeUtf8)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadResource)+import Control.Monad.IO.Class (MonadIO, liftIO) -- | Location of the Javascript file hosted by browserid.org browserIdJs :: Text browserIdJs = "https://login.persona.org/include.js" -checkAssertion :: (MonadResource m, MonadBaseControl IO m)+checkAssertion :: MonadIO m => Text -- ^ audience -> Text -- ^ assertion -> Manager -> m (Maybe Text) checkAssertion audience assertion manager = do- req' <- liftIO $ parseUrl "https://verifier.login.persona.org/verify"+ req' <- liftIO $ parseUrlThrow "https://verifier.login.persona.org/verify" let req = urlEncodedBody [ ("audience", encodeUtf8 audience) , ("assertion", encodeUtf8 assertion)
Web/Authenticate/OpenId.hs view
@@ -25,7 +25,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy (toStrict) import Network.HTTP.Conduit- ( parseUrl, urlEncodedBody, responseBody, httpLbs+ ( parseUrlThrow, urlEncodedBody, responseBody, httpLbs , Manager ) import Control.Arrow ((***), second)@@ -36,11 +36,9 @@ import Blaze.ByteString.Builder (toByteString) import Network.HTTP.Types (renderQueryText) import Control.Exception (throwIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadResource) getForwardUrl- :: (MonadResource m, MonadBaseControl IO m)+ :: MonadIO m => Text -- ^ The openid the user provided. -> Text -- ^ The URL for this application\'s complete page. -> Maybe Text -- ^ Optional realm@@ -81,7 +79,7 @@ : params authenticate- :: (MonadBaseControl IO m, MonadResource m, MonadIO m)+ :: MonadIO m => [(Text, Text)] -> Manager -> m (Identifier, [(Text, Text)])@@ -97,7 +95,7 @@ } authenticateClaimed- :: (MonadBaseControl IO m, MonadResource m, MonadIO m)+ :: MonadIO m => [(Text, Text)] -> Manager -> m OpenIdResponse@@ -124,7 +122,7 @@ let params' = map (encodeUtf8 *** encodeUtf8) $ ("openid.mode", "check_authentication") : filter (\(k, _) -> k /= "openid.mode") params- req' <- liftIO $ parseUrl $ unpack $ endpoint discOP+ req' <- liftIO $ parseUrlThrow $ unpack $ endpoint discOP let req = urlEncodedBody params' req' rsp <- httpLbs req manager let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp
Web/Authenticate/OpenId/Providers.hs view
@@ -15,6 +15,7 @@ google :: String google = "https://www.google.com/accounts/o8/id"+{-# DEPRECATED google "Google no longer provides OpenID support" #-} yahoo :: String yahoo = "http://me.yahoo.com/"
Web/Authenticate/Rpxnow.hs view
@@ -22,6 +22,9 @@ ) where import Data.Aeson+#if MIN_VERSION_aeson(2,2,0)+import Data.Aeson.Parser (json)+#endif import Network.HTTP.Conduit import Control.Monad.IO.Class import Data.Maybe@@ -35,11 +38,14 @@ import qualified Data.Attoparsec.Lazy as AT import Data.Text (Text) import qualified Data.Aeson.Types+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as Map+import qualified Data.Aeson.Key as Key+#else import qualified Data.HashMap.Lazy as Map+#endif import Control.Applicative ((<$>), (<*>)) import Control.Exception (throwIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (MonadResource) -- | Information received from Rpxnow after a valid login. data Identifier = Identifier@@ -49,7 +55,7 @@ deriving (Eq, Ord, Read, Show, Data, Typeable) -- | Attempt to log a user in.-authenticate :: (MonadResource m, MonadBaseControl IO m)+authenticate :: MonadIO m => String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client. -> Manager@@ -61,7 +67,7 @@ , "&token=" , S.pack token ]- req' <- liftIO $ parseUrl "https://rpxnow.com"+ req' <- liftIO $ parseUrlThrow "https://rpxnow.com" let req = req' { method = "POST"@@ -99,6 +105,10 @@ <*> return (mapMaybe go (Map.toList profile)) where go ("identifier", _) = Nothing- go (k, String v) = Just (k, v)+ go (k, String v) = Just (+#if MIN_VERSION_aeson(2,0,0)+ Key.toText+#endif+ k, v) go _ = Nothing parseProfile _ = mzero
authenticate.cabal view
@@ -1,27 +1,27 @@ name: authenticate-version: 1.3.2.10-license: BSD3+version: 1.3.5.2+license: MIT license-file: LICENSE author: Michael Snoyman, Hiromi Ishii, Arash Rouhani maintainer: Michael Snoyman <michael@snoyman.com> synopsis: Authentication methods for Haskell web applications.-description:- Focus is on third-party authentication methods, such as OpenID and BrowserID.- .- Note: Facebook support is now provided by the fb package: <http://hackage.haskell.org/package/fb>.+description: API docs and the README are available at <http://www.stackage.org/package/authenticate>. category: Web stability: Stable-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple homepage: http://github.com/yesodweb/authenticate+extra-source-files: README.md ChangeLog.md flag network-uri description: Get Network.URI from the network-uri package default: True library- build-depends: base >= 4 && < 5+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5 , aeson >= 0.5+ , attoparsec-aeson >= 2.1 , http-conduit >= 1.5 , transformers >= 0.1 , bytestring >= 0.9@@ -34,9 +34,8 @@ , containers , unordered-containers , conduit >= 0.5- , tagstream-conduit >= 0.5.5+ , html-conduit >= 1.3 , resourcet- , monad-control exposed-modules: Web.Authenticate.Rpxnow, Web.Authenticate.OpenId, Web.Authenticate.BrowserId,