authenticate 0.7.2.4 → 0.8.0

raw patch · 4 files changed

+48/−34 lines, 4 filesdep +waidep ~http-enumeratorPVP ok

version bump matches the API change (PVP)

Dependencies added: wai

Dependency ranges changed: http-enumerator

API changes (from Hackage documentation)

Files

• OpenId2/Discovery.hs +2/−1
• Web/Authenticate/OpenId.hs +41/−29
• Web/Authenticate/OpenId/Providers.hs +1/−1
• authenticate.cabal +4/−3

@@ -32,6 +32,7 @@ import Control.Monad.IO.Class (MonadIO) import Control.Failure (Failure (failure)) import Control.Monad (mplus, liftM)+import Network.Wai (ciOriginal)  data Discovery = Discovery1 String (Maybe String)                | Discovery2 Provider Identifier@@ -72,7 +73,7 @@     res <- httpLbs req     let mloc = fmap S8.unpack              $ lookup "x-xrds-location"-             $ map (first $ map toLower . S8.unpack)+             $ map (first $ map toLower . S8.unpack . ciOriginal)              $ responseHeaders res     let mloc' = if mloc == mb_loc then Nothing else mloc     case statusCode res of

@@ -23,43 +23,55 @@ import Data.List (unfoldr) import Data.Maybe (fromMaybe) -getForwardUrl :: ( MonadIO m-                 , Failure AuthenticateException m-                 , Failure HttpException m-                 )-              => String -- ^ The openid the user provided.-              -> String -- ^ The URL for this application\'s complete page.-              -> m String -- ^ URL to send the user to.-getForwardUrl openid' complete = do+getForwardUrl+    :: ( MonadIO m+       , Failure AuthenticateException m+       , Failure HttpException m+       )+    => String -- ^ The openid the user provided.+    -> String -- ^ The URL for this application\'s complete page.+    -> Maybe String -- ^ Optional realm+    -> [(String, String)] -- ^ Additional parameters to send to the OpenID provider. These can be useful for using extensions.+    -> m String -- ^ URL to send the user to.+getForwardUrl openid' complete mrealm params = do+    let realm = fromMaybe complete mrealm     disc <- normalize openid' >>= discover     case disc of         Discovery1 server mdelegate ->             return $ qsUrl server-                [ ("openid.mode", "checkid_setup")-                , ("openid.identity", fromMaybe openid' mdelegate)-                , ("openid.return_to", complete)-                , ("openid.trust_root", complete)-                , ("openid.realm", complete)-                ]+                $ ("openid.mode", "checkid_setup")+                : ("openid.identity", fromMaybe openid' mdelegate)+                : ("openid.return_to", complete)+                : ("openid.realm", realm)+                : ("openid.trust_root", complete)+                : params         Discovery2 (Provider p) (Identifier i) ->             return $ qsUrl p-                [ ("openid.ns", "http://specs.openid.net/auth/2.0")-                , ("openid.mode", "checkid_setup")-                , ("openid.claimed_id", i)-                , ("openid.identity", i)-                , ("openid.return_to", complete)-                , ("openid.realm", complete)-                ]+                $ ("openid.ns", "http://specs.openid.net/auth/2.0")+                : ("openid.mode", "checkid_setup")+                : ("openid.claimed_id", i)+                : ("openid.identity", i)+                : ("openid.return_to", complete)+                : ("openid.realm", realm)+                : params -authenticate :: ( MonadIO m-                , Failure AuthenticateException m-                , Failure HttpException m-                )-             => [(String, String)]-             -> m Identifier+authenticate+    :: ( MonadIO m+       , Failure AuthenticateException m+       , Failure HttpException m+       )+    => [(String, String)]+    -> m (Identifier, [(String, String)]) authenticate params = do     unless (lookup "openid.mode" params == Just "id_res")-        $ failure $ AuthenticationException "mode is not id_res"+        $ failure $ case lookup "openid.mode" params of+                      Nothing -> AuthenticationException "openid.mode was not found in the params."+                      (Just m)+                            | m == "error" ->+                                case lookup "openid.error" params of+                                  Nothing -> AuthenticationException "An error occurred, but no error message was provided."+                                  (Just e) -> AuthenticationException e+                            | otherwise -> AuthenticationException $ "mode is " ++ m ++ " but we were expecting id_res."     ident <- case lookup "openid.identity" params of                 Just i -> return i                 Nothing ->@@ -76,7 +88,7 @@     rsp <- httpLbsRedirect req     let rps = parseDirectResponse $ BSLU.toString $ responseBody rsp     case lookup "is_valid" rps of-        Just "true" -> return $ Identifier ident+        Just "true" -> return (Identifier ident, rps)         _ -> failure $ AuthenticationException "OpenID provider did not validate"  -- | Turn a response body into a list of parameters.

@@ -23,7 +23,7 @@ livejournal u = concat ["http://", u, ".livejournal.com/"]  myspace :: String -> String-myspace = (++) "http://myspace.com/"+myspace = (++) "http://www.myspace.com/"  wordpress :: String -> String wordpress u = concat ["http://", u, ".wordpress.com/"]

@@ -1,5 +1,5 @@ name:            authenticate-version:         0.7.2.4+version:         0.8.0 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -17,14 +17,15 @@     build-depends:   base >= 4 && < 5,                      data-object >= 0.3.1 && < 0.4,                      data-object-json >= 0.3.1 && < 0.4,-                     http-enumerator >= 0.2.0 && < 0.3,+                     http-enumerator >= 0.3.0 && < 0.4,                      tagsoup >= 0.6 && < 0.13,                      failure >= 0.0.0 && < 0.2,                      transformers >= 0.1 && < 0.3,                      bytestring >= 0.9 && < 0.10,                      utf8-string >= 0.3 && < 0.4,                      network >= 2.2.1 && < 2.4,-                     xml >= 1.3.7 && < 1.4+                     xml >= 1.3.7 && < 1.4,+                     wai >= 0.3 && < 0.4     exposed-modules: Web.Authenticate.Rpxnow,                      Web.Authenticate.OpenId,                      Web.Authenticate.OpenId.Providers,