authIdentifier (automatic login redirection)

Yesod/Helpers/Auth.hs

@@ -16,9 +16,9 @@
 module Yesod.Helpers.Auth
     ( authHandler
     , YesodAuth (..)
+    , authIdentifier
     ) where
 
-import qualified Hack
 import Web.Encodings
 import qualified Web.Authenticate.Rpxnow as Rpxnow
 import qualified Web.Authenticate.OpenId as OpenId
@@ -31,10 +31,27 @@ import Control.Monad.Attempt
 
 import Data.Maybe (fromMaybe)
 
-class Yesod a => YesodAuth a where
+class YesodApproot a => YesodAuth a where
+    -- | The following breaks DRY, but I cannot think of a better solution
+    -- right now.
+    --
+    -- The root relative to the application root. Should not begin with a slash
+    -- and should end with one.
+    authRoot :: a -> String
+    authRoot _ = "auth/"
+
+    defaultLoginPath :: a -> String
+    defaultLoginPath a = authRoot a ++ "openid/"
+
     rpxnowApiKey :: a -> Maybe String
     rpxnowApiKey _ = Nothing
 
+getFullAuthRoot :: YesodAuth y => Handler y String
+getFullAuthRoot = do
+    y <- getYesod
+    let (Approot ar) = approot y
+    return $ ar ++ authRoot y
+
 data AuthResource =
     Check
     | Logout
@@ -85,13 +102,11 @@ authOpenidForm = do
         Nothing -> return ()
     return $ cs html
 
-authOpenidForward :: Handler y HtmlObject
+authOpenidForward :: YesodAuth y => Handler y HtmlObject
 authOpenidForward = do
     oid <- getParam "openid"
-    env <- parseEnv
-    let complete = "http://" ++ Hack.serverName env ++ ":" ++
-                   show (Hack.serverPort env) ++
-                   "/auth/openid/complete/"
+    authroot <- getFullAuthRoot
+    let complete = authroot ++ "/openid/complete/"
     res <- runAttemptT $ OpenId.getForwardUrl oid complete
     attempt
       (\err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (show err))
@@ -145,15 +160,24 @@ rpxnowLogin = do
 
 authCheck :: Handler y HtmlObject
 authCheck = do
-    ident <- maybeIdentifier
-    case ident of
-        Nothing -> return $ toHtmlObject [("status", "notloggedin")]
-        Just i -> return $ toHtmlObject
-            [ ("status", "loggedin")
-            , ("ident", i)
-            ]
+    ident <- identifier
+    return $ toHtmlObject [("identifier", fromMaybe "" ident)]
 
 authLogout :: Handler y HtmlObject
 authLogout = do
     deleteCookie authCookieName
     return $ toHtmlObject [("status", "loggedout")]
+
+authIdentifier :: YesodAuth y => Handler y String
+authIdentifier = do
+    mi <- identifier
+    Approot ar <- getApproot
+    case mi of
+        Nothing -> do
+            rp <- requestPath
+            let dest = ar ++ rp
+            liftIO $ print ("authIdentifier", dest, ar, rp)
+            lp <- defaultLoginPath `fmap` getYesod
+            addCookie 120 "DEST" dest
+            redirect $ ar ++ lp
+        Just x -> return x

Yesod/Request.hs

@@ -36,7 +36,6 @@ module Yesod.Request
     , anyParam
     , cookieParam
     , identifier
-    , maybeIdentifier
     , acceptedLanguages
     , requestPath
     , parseEnv
@@ -164,19 +163,10 @@ anyParam = genParam anyParams PostParam -- FIXME
 cookieParam :: (Parameter a, MonadRequestReader m) => ParamName -> m a
 cookieParam = genParam cookies CookieParam
 
--- | Extract the cookie which specifies the identifier for a logged in
--- user.
-identifier :: MonadRequestReader m => m String
-identifier = do
-    mi <- maybeIdentifier
-    case mi of
-        Nothing -> authRequired
-        Just x -> return x
-
 -- | Extract the cookie which specifies the identifier for a logged in
 -- user, if available.
-maybeIdentifier :: MonadRequestReader m => m (Maybe String)
-maybeIdentifier = do
+identifier :: MonadRequestReader m => m (Maybe String)
+identifier = do
     env <- parseEnv
     case lookup authCookieName $ Hack.hackHeaders env of
         Nothing -> return Nothing
@@ -203,7 +193,10 @@ requestPath = do
                 "" -> ""
                 q'@('?':_) -> q'
                 q' -> q'
-    return $! Hack.pathInfo env ++ q
+    return $! dropSlash (Hack.pathInfo env) ++ q
+      where
+        dropSlash ('/':x) = x
+        dropSlash x = x
 
 type PathInfo = [String]
 
@@ -285,9 +278,10 @@ instance Parameter Day where
                 then Right $ fromGregorian y m d
                 else Left $ "Invalid date: " ++ s
 
--- for checkboxes; checks for presence
+-- for checkboxes; checks for presence or a "false" value
 instance Parameter Bool where
     readParams [] = Right False
+    readParams [RawParam _ _ "false"] = Right False
     readParams [_] = Right True
     readParams x = Left $ "Invalid Bool parameter: " ++ show (map paramValue x)
 

Yesod/Yesod.hs

@@ -2,6 +2,7 @@
 module Yesod.Yesod
     ( Yesod (..)
     , YesodApproot (..)
+    , getApproot
     , toHackApp
     ) where
 
@@ -50,6 +51,9 @@ class Yesod a => YesodApproot a where
     -- | An absolute URL to the root of the application.
     approot :: a -> Approot
 
+getApproot :: YesodApproot y => Handler y Approot
+getApproot = approot `fmap` getYesod
+
 defaultErrorHandler :: Yesod y
                     => ErrorResult
                     -> Handler y RepChooser