Major Auth refactoring

Yesod/Helpers/Auth.hs

@@ -20,66 +20,100 @@
 --
 ---------------------------------------------------------
 module Yesod.Helpers.Auth
-    ( maybeIdentifier
+    ( redirectLogin
-    , authIdentifier
-    , displayName
-    , redirectLogin
     , Auth (..)
     , AuthRoutes (..)
     , siteAuth
     , YesodAuth (..)
     , identKey
     , displayNameKey
+    , Creds (..)
+    , maybeCreds
+    , requireCreds
     ) where
 
-import Web.Encodings
 import qualified Web.Authenticate.Rpxnow as Rpxnow
 import qualified Web.Authenticate.OpenId as OpenId
 
 import Yesod
-import Data.Convertible.Text
 
 import Control.Monad.Attempt
 import Data.Maybe
-import Control.Applicative
+import Control.Monad
-
-import Data.Typeable (Typeable)
-import Control.Exception (Exception)
 
 class Yesod master => YesodAuth master where
+    -- | Default destination on successful login or logout, if no other
+    -- destination exists.
     defaultDest :: master -> Routes master
 
+    -- | Default page to redirect user to for logging in.
     defaultLoginRoute :: master -> Routes master
 
-    onRpxnowLogin :: Rpxnow.Identifier -> GHandler Auth master ()
+    -- | Callback for a successful login.
-    onRpxnowLogin _ = return ()
+    --
+    -- The second parameter can contain various information, depending on login
+    -- mechanism.
+    onLogin :: Creds -> [(String, String)] -> GHandler Auth master ()
+    onLogin _ _ = return ()
 
 data Auth = Auth
     { authIsOpenIdEnabled :: Bool
     , authRpxnowApiKey :: Maybe String
     }
 
-$(mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|
+data AuthType = AuthOpenId | AuthRpxnow
+    deriving (Show, Read, Eq)
+
+-- | User credentials
+data Creds = Creds
+    { credsIdent :: String -- ^ Identifier. Exact meaning depends on 'credsAuthType'.
+    , credsAuthType :: AuthType -- ^ How the user was authenticated
+    , credsEmail :: Maybe String -- ^ Verified e-mail address.
+    , credsDisplayName :: Maybe String -- ^ Display name.
+    }
+    deriving (Show, Read, Eq)
+
+credsKey :: String
+credsKey = "_CREDS"
+
+setCreds :: YesodAuth master
+         => Creds -> [(String, String)] -> GHandler Auth master ()
+setCreds creds extra = do
+    setSession credsKey $ show creds
+    onLogin creds extra
+
+maybeCreds :: GHandler sub master (Maybe Creds)
+maybeCreds = do
+    mcs <- lookupSession credsKey
+    return $ mcs >>= readMay
+  where
+    readMay x = case reads x of
+                    (y, _):_ -> Just y
+                    _ -> Nothing
+
+mkYesodSub "Auth" [''YesodAuth] [$parseRoutes|
 /check                 Check              GET
 /logout                Logout             GET
 /openid                OpenIdR            GET
 /openid/forward        OpenIdForward      GET
 /openid/complete       OpenIdComplete     GET
 /login/rpxnow          RpxnowR
-|])
+|]
 
-data ExpectedSingleParam = ExpectedSingleParam
+testOpenId :: GHandler Auth master ()
-    deriving (Show, Typeable)
+testOpenId = do
-instance Exception ExpectedSingleParam
+    a <- getYesodSub
+    unless (authIsOpenIdEnabled a) notFound
 
 getOpenIdR :: Yesod master => GHandler Auth master RepHtml
 getOpenIdR = do
+    testOpenId
     rr <- getRequest
     case getParams rr "dest" of
         [] -> return ()
         (x:_) -> setUltDestString x
     rtom <- getRouteToMaster
-    let message = cs <$> (listToMaybe $ getParams rr "message")
+    message <- getMessage
     applyLayout "Log in via OpenID" (return ()) [$hamlet|
 $maybe message msg
     %p.message $msg$
@@ -91,33 +125,35 @@ $maybe message msg
 
 getOpenIdForward :: GHandler Auth master ()
 getOpenIdForward = do
+    testOpenId
     rr <- getRequest
     oid <- case getParams rr "openid" of
             [x] -> return x
-            _ -> invalidArgs [("openid", show ExpectedSingleParam)]
+            _ -> invalidArgs [("openid", "Expected single parameter")]
     render <- getUrlRender
     toMaster <- getRouteToMaster
     let complete = render $ toMaster OpenIdComplete
     res <- runAttemptT $ OpenId.getForwardUrl oid complete
     attempt
-      (\err -> redirectParams RedirectTemporary (toMaster OpenIdR)
+      (\err -> do
-                [("message", show err)])
+            setMessage $ cs $ show err
+            redirect RedirectTemporary $ toMaster OpenIdR)
       (redirectString RedirectTemporary)
       res
 
 getOpenIdComplete :: YesodAuth master => GHandler Auth master ()
 getOpenIdComplete = do
+    testOpenId
     rr <- getRequest
     let gets' = reqGetParams rr
     res <- runAttemptT $ OpenId.authenticate gets'
-    renderm <- getUrlRender
     toMaster <- getRouteToMaster
-    let render = renderm . toMaster
+    let onFailure err = do
-    let errurl err = render OpenIdR ++ "?message=" ++ encodeUrl (show err)
+        setMessage $ cs $ show err
-    let onFailure err = redirectString RedirectTemporary $ errurl err
+        redirect RedirectTemporary $ toMaster OpenIdR
     let onSuccess (OpenId.Identifier ident) = do
         y <- getYesod
-        setSession identKey ident
+        setCreds (Creds ident AuthOpenId Nothing Nothing) []
         redirectUltDest RedirectTemporary $ defaultDest y
     attempt onFailure onSuccess res
 
@@ -131,12 +167,15 @@ handleRpxnowR = do
     rr <- getRequest
     pp <- postParams rr
     let token = case getParams rr "token" ++ pp "token" of
-                    [] -> failure MissingToken
+                    [] -> invalidArgs [("token", "Value not supplied")]
                     (x:_) -> x
-    ident <- liftIO $ Rpxnow.authenticate apiKey token
+    Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
-    onRpxnowLogin ident
+    let creds = Creds
-    setSession identKey $ Rpxnow.identifier ident
+                    ident
-    setSession displayNameKey $ getDisplayName ident
+                    AuthRpxnow
+                    (lookup "verifiedEmail" extra)
+                    (getDisplayName extra)
+    setCreds creds extra
     either (redirect RedirectTemporary) (redirectString RedirectTemporary) $
         case pp "dest" of
             (d:_) -> Right d
@@ -146,61 +185,39 @@ handleRpxnowR = do
                     (('#':rest):_) -> Right rest
                     (s:_) -> Right s
 
-
+-- | Get some form of a display name.
-data MissingToken = MissingToken
+getDisplayName :: [(String, String)] -> Maybe String
-    deriving (Show, Typeable)
+getDisplayName extra = helper choices where
-instance Exception MissingToken
-
--- | Get some form of a display name, defaulting to the identifier.
-getDisplayName :: Rpxnow.Identifier -> String
-getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
     choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]
-    helper [] = ident
+    helper [] = Nothing
-    helper (x:xs) = fromMaybe (helper xs) $ lookup x extra
+    helper (x:xs) = maybe (helper xs) Just $ lookup x extra
 
 getCheck :: Yesod master => GHandler Auth master RepHtmlJson
 getCheck = do
-    ident <- maybeIdentifier
+    creds <- maybeCreds
-    dn <- displayName
+    applyLayoutJson "Authentication Status"
-    let arg = (cs $ fromMaybe "" ident, cs $ fromMaybe "" dn)
+        (return ()) (html creds) (json creds)
-    applyLayoutJson "Authentication Status" (return ()) arg html json
   where
-    html (x, y) = [$hamlet|
+    html creds = [$hamlet|
 %h1 Authentication Status
-%dl
+$if isNothing.creds
-    %dt identifier
+    %p Not logged in
-    %dd $x$
+$maybe creds c
-    %dt displayName
+    %p Logged in as $cs.credsIdent.c$
-    %dd $y$
 |]
-    json (ident, dn) =
+    json creds =
-        jsonMap [ ("ident", jsonScalar ident)
+        jsonMap
-                , ("displayName", jsonScalar dn)
+            [ ("ident", jsonScalar $ maybe (cs "") (cs . credsIdent) creds)
-                ]
+            , ("displayName", jsonScalar $ cs $ fromMaybe ""
+                                         $ creds >>= credsDisplayName)
+            ]
 
 getLogout :: YesodAuth master => GHandler Auth master ()
 getLogout = do
     y <- getYesod
-    clearSession identKey
+    clearSession credsKey
     redirectUltDest RedirectTemporary $ defaultDest y
 
--- | Gets the identifier for a user if available.
-maybeIdentifier :: RequestReader m => m (Maybe String)
-maybeIdentifier = do
-    s <- session
-    return $ listToMaybe $ s identKey
-
--- | Gets the display name for a user if available.
-displayName :: RequestReader m => m (Maybe String)
-displayName = do
-    s <- session
-    return $ listToMaybe $ s displayNameKey
-
--- | Gets the identifier for a user. If user is not logged in, redirects them
--- to the login page.
-authIdentifier :: YesodAuth master => GHandler sub master String
-authIdentifier = maybeIdentifier >>= maybe redirectLogin return
-
 -- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie
 -- appropriately.
 redirectLogin :: YesodAuth master => GHandler sub master a
@@ -209,6 +226,9 @@ redirectLogin = do
     setUltDest'
     redirect RedirectTemporary $ defaultLoginRoute y
 
+requireCreds :: YesodAuth master => GHandler sub master Creds
+requireCreds = maybeCreds >>= maybe redirectLogin return
+
 identKey :: String
 identKey = "IDENTIFIER"
 

Yesod/Yesod.hs

@@ -100,18 +100,17 @@ applyLayout t h b =
 applyLayoutJson :: Yesod master
                 => String -- ^ title
                 -> Hamlet (Routes master) IO () -- ^ head
-                -> x
+                -> Hamlet (Routes master) IO () -- ^ body
-                -> (x -> Hamlet (Routes master) IO ())
+                -> Json (Routes master) ()
-                -> (x -> Json (Routes master) ())
                 -> GHandler sub master RepHtmlJson
-applyLayoutJson t h x toH toJ = do
+applyLayoutJson t h html json = do
-    html <- defaultLayout PageContent
+    html' <- defaultLayout PageContent
                 { pageTitle = cs t
                 , pageHead = h
-                , pageBody = toH x
+                , pageBody = html
                 }
-    json <- jsonToContent $ toJ x
+    json' <- jsonToContent json
-    return $ RepHtmlJson html json
+    return $ RepHtmlJson html' json'
 
 applyLayout' :: Yesod master
              => String -- ^ title