authenticate 1.2.0.1 → 1.2.1

raw patch · 2 files changed

+63/−16 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Web/Authenticate/OpenId.hs +62/−15
• authenticate.cabal +1/−1

@@ -1,10 +1,18 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Web.Authenticate.OpenId-    ( getForwardUrl+    ( -- * Functions+      getForwardUrl     , authenticate+    , authenticateClaimed+      -- * Types     , AuthenticateException (..)     , Identifier (..)+      -- ** Response+    , OpenIdResponse+    , oirOpLocal+    , oirParams+    , oirClaimed     ) where  import Control.Monad.IO.Class@@ -41,7 +49,8 @@     -> m Text -- ^ URL to send the user to. getForwardUrl openid' complete mrealm params manager = do     let realm = fromMaybe complete mrealm-    disc <- normalize openid' >>= flip discover manager+    claimed <- normalize openid'+    disc <- discover claimed manager     let helper s q = return $ T.concat             [ s             , if "?" `T.isInfixOf` s then "&" else "?"@@ -50,21 +59,23 @@     case disc of         Discovery1 server mdelegate -> helper server                 $ ("openid.mode", "checkid_setup")-                : ("openid.identity", maybe openid' id mdelegate)+                : ("openid.identity", maybe (identifier claimed) id mdelegate)                 : ("openid.return_to", complete)                 : ("openid.realm", realm)                 : ("openid.trust_root", complete)                 : params         Discovery2 (Provider p) (Identifier i) itype -> do-            let i' =+            let (claimed', identity') =                     case itype of-                        ClaimedIdent -> i-                        OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"+                        ClaimedIdent -> (identifier claimed, i)+                        OPIdent ->+                            let x = "http://specs.openid.net/auth/2.0/identifier_select"+                             in (x, x)             helper p                 $ ("openid.ns", "http://specs.openid.net/auth/2.0")                 : ("openid.mode", "checkid_setup")-                : ("openid.claimed_id", i')-                : ("openid.identity", i')+                : ("openid.claimed_id", claimed')+                : ("openid.identity", identity')                 : ("openid.return_to", complete)                 : ("openid.realm", realm)                 : params@@ -74,7 +85,23 @@     => [(Text, Text)]     -> Manager     -> m (Identifier, [(Text, Text)])-authenticate params manager = do+authenticate ps m = do+    x <- authenticateClaimed ps m+    return (oirOpLocal x, oirParams x)+{-# DEPRECATED authenticate "Use authenticateClaimed" #-}++data OpenIdResponse = OpenIdResponse+    { oirOpLocal :: Identifier+    , oirParams :: [(Text, Text)]+    , oirClaimed :: Maybe Identifier+    }++authenticateClaimed+    :: (MonadBaseControl IO m, MonadResource m, MonadIO m)+    => [(Text, Text)]+    -> Manager+    -> m OpenIdResponse+authenticateClaimed params manager = do     unless (lookup "openid.mode" params == Just "id_res")         $ liftIO $ throwIO $ case lookup "openid.mode" params of                       Nothing -> AuthenticationException "openid.mode was not found in the params."@@ -88,19 +115,39 @@                 Just i -> return i                 Nothing ->                     liftIO $ throwIO $ AuthenticationException "Missing identity"-    disc <- normalize ident >>= flip discover manager-    let endpoint = case disc of-                    Discovery1 p _ -> p-                    Discovery2 (Provider p) _ _ -> p+    discOP <- normalize ident >>= flip discover manager++    let endpoint d =+            case d of+                Discovery1 p _ -> p+                Discovery2 (Provider p) _ _ -> p     let params' = map (encodeUtf8 *** encodeUtf8)                 $ ("openid.mode", "check_authentication")                 : filter (\(k, _) -> k /= "openid.mode") params-    req' <- liftIO $ parseUrl $ unpack endpoint+    req' <- liftIO $ parseUrl $ unpack $ endpoint discOP     let req = urlEncodedBody params' req'     rsp <- httpLbs req manager     let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp++    claimed <-+        case lookup "openid.claimed_id" params of+            Nothing -> return Nothing+            Just claimed' -> do+                -- need to validate that this provider can speak for the given+                -- claimed identifier+                claimedN <- normalize claimed'+                discC <- discover claimedN manager+                return $+                    if endpoint discOP == endpoint discC+                        then Just claimedN+                        else Nothing+     case lookup "is_valid" rps of-        Just "true" -> return (Identifier ident, rps)+        Just "true" -> return OpenIdResponse+            { oirOpLocal = Identifier ident+            , oirParams  = rps+            , oirClaimed = claimed+            }         _ -> liftIO $ throwIO $ AuthenticationException "OpenID provider did not validate"  -- | Turn a response body into a list of parameters.

@@ -1,5 +1,5 @@ name:            authenticate-version:         1.2.0.1+version:         1.2.1 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman, Hiromi Ishii, Arash Rouhani