diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 5d964c43..a2f7b13e 100644 --- a/Yesod/Helpers/Auth.hs +++ b/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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 01cdf535..9373776b 100644 --- a/Yesod/Request.hs +++ b/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) diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 294fb6db..7866277b 100644 --- a/Yesod/Yesod.hs +++ b/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