diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/OpenId2/Discovery.hs b/OpenId2/Discovery.hs --- a/OpenId2/Discovery.hs +++ b/OpenId2/Discovery.hs @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/Web/Authenticate/BrowserId.hs b/Web/Authenticate/BrowserId.hs --- a/Web/Authenticate/BrowserId.hs +++ b/Web/Authenticate/BrowserId.hs @@ -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) diff --git a/Web/Authenticate/OpenId.hs b/Web/Authenticate/OpenId.hs --- a/Web/Authenticate/OpenId.hs +++ b/Web/Authenticate/OpenId.hs @@ -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 diff --git a/Web/Authenticate/OpenId/Providers.hs b/Web/Authenticate/OpenId/Providers.hs --- a/Web/Authenticate/OpenId/Providers.hs +++ b/Web/Authenticate/OpenId/Providers.hs @@ -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/" diff --git a/Web/Authenticate/Rpxnow.hs b/Web/Authenticate/Rpxnow.hs --- a/Web/Authenticate/Rpxnow.hs +++ b/Web/Authenticate/Rpxnow.hs @@ -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 diff --git a/authenticate.cabal b/authenticate.cabal --- a/authenticate.cabal +++ b/authenticate.cabal @@ -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 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: . +description: API docs and the README are available at . 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,