authenticateClaimed

authenticate/Web/Authenticate/OpenId.hs

@@ -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
@@ -77,7 +85,23 @@ authenticate
     => [(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."
@@ -91,19 +115,39 @@ authenticate params manager = do
                 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.

authenticate/openid2.hs

@@ -41,7 +41,7 @@ getForwardR = do
 getCompleteR :: Handler RepHtml
 getCompleteR = do
     params <- reqGetParams `fmap` getRequest
-    (ident, retparams) <- withManager $ authenticate params
+    oir <- withManager $ authenticateClaimed params
     defaultLayout $ do
         toWidget [lucius|
 table {
@@ -60,13 +60,20 @@ th {
 <p>Successfully logged in.
 <table>
     <tr>
-        <th>Ident
-        <td>#{show ident}
+        <th>OP Local
+        <td>#{identifier $ oirOpLocal oir}
+    <tr>
+        <th>Claimed
+        <td>
+            $maybe c <- oirClaimed oir
+                \#{identifier c}
+            $nothing
+                <i>none
     <tr>
         <th>Params
         <td>
             <table>
-                $forall (k, v) <- retparams
+                $forall (k, v) <- oirParams oir
                     <tr>
                         <th>#{k}
                         <td>#{v}