diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs index 963fffe2..c9bff08d 100644 --- a/Hack/Middleware/ClientSession.hs +++ b/Hack/Middleware/ClientSession.hs @@ -12,7 +12,7 @@ import Hack import Web.Encodings import Data.List (partition, intercalate) import Data.Function.Predicate (is, isn't, equals) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Web.ClientSession import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime) import Data.Time.LocalTime () -- Show instance of UTCTime @@ -62,8 +62,7 @@ clientsession cnames key app env = do remoteHost' = remoteHost env now <- getCurrentTime let convertedCookies = - takeJusts $ - map (decodeCookie key now remoteHost') interceptCookies + mapMaybe (decodeCookie key now remoteHost') interceptCookies let env' = env { http = ("Cookie", cookiesRaw) : filter (fst `equals` "Cookie") (http env) ++ nonCookies @@ -82,11 +81,6 @@ clientsession cnames key app env = do let res' = res { headers = newCookies ++ headers' } return res' -takeJusts :: [Maybe a] -> [a] -takeJusts [] = [] -takeJusts (Just x:rest) = x : takeJusts rest -takeJusts (Nothing:rest) = takeJusts rest - setCookie :: Word256 -> UTCTime -- ^ expiration time -> String -- ^ formatted expiration time diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 214f4832..7c96f692 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -103,8 +103,9 @@ runHandler (Handler handler) eh rr y cts = do HCContent a -> Right a case contents' of Left e -> do + -- FIXME doesn't look right Response _ hs ct c <- runHandler (eh e) specialEh rr y cts - let hs' = hs ++ getHeaders e + let hs' = headers ++ hs ++ getHeaders e return $ Response (getStatus e) hs' ct c Right a -> do (ct, c) <- a cts diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index 971ded13..115264a9 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -14,10 +14,8 @@ -- --------------------------------------------------------- module Yesod.Helpers.Auth - ( AuthResource - , authHandler - , authResourcePattern - , RpxnowApiKey (..) + ( authHandler + , YesodAuth (..) ) where import qualified Hack @@ -33,6 +31,10 @@ import Control.Monad.Attempt import Data.Maybe (fromMaybe) +class Yesod a => YesodAuth a where + rpxnowApiKey :: a -> Maybe String + rpxnowApiKey _ = Nothing + data AuthResource = Check | Logout @@ -42,27 +44,19 @@ data AuthResource = | LoginRpxnow deriving (Show, Eq, Enum, Bounded) -newtype RpxnowApiKey = RpxnowApiKey String - -authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler y HtmlObject -authHandler _ Check Get = authCheck -authHandler _ Logout Get = authLogout -authHandler _ Openid Get = authOpenidForm -authHandler _ OpenidForward Get = authOpenidForward -authHandler _ OpenidComplete Get = authOpenidComplete --- two different versions of RPX protocol apparently... -authHandler (Just (RpxnowApiKey key)) LoginRpxnow Get = rpxnowLogin key -authHandler (Just (RpxnowApiKey key)) LoginRpxnow Post = rpxnowLogin key -authHandler _ _ _ = notFound - -authResourcePattern :: AuthResource -> String -- FIXME supply prefix as well -authResourcePattern Check = "/auth/check/" -authResourcePattern Logout = "/auth/logout/" -authResourcePattern Openid = "/auth/openid/" -authResourcePattern OpenidForward = "/auth/openid/forward/" -authResourcePattern OpenidComplete = "/auth/openid/complete/" -authResourcePattern LoginRpxnow = "/auth/login/rpxnow/" +rc :: HasReps x => Handler y x -> Handler y RepChooser +rc = fmap chooseRep +authHandler :: YesodAuth y => Verb -> [String] -> Handler y RepChooser +authHandler Get ["check"] = rc authCheck +authHandler Get ["logout"] = rc authLogout +authHandler Get ["openid"] = rc authOpenidForm +authHandler Get ["openid", "forward"] = rc authOpenidForward +authHandler Get ["openid", "complete"] = rc authOpenidComplete +-- two different versions of RPX protocol apparently, so just accepting all +-- verbs +authHandler _ ["login", "rpxnow"] = rc rpxnowLogin +authHandler _ _ = notFound data OIDFormReq = OIDFormReq (Maybe String) (Maybe String) instance Request OIDFormReq where @@ -80,6 +74,8 @@ authOpenidForm = do [ cs m , Tag "form" [("method", "get"), ("action", "forward/")] [ Tag "label" [("for", "openid")] [cs "OpenID: "] + , EmptyTag "input" [("type", "text"), ("id", "openid"), + ("name", "openid")] , EmptyTag "input" [("type", "submit"), ("value", "Login")] ] ] @@ -126,9 +122,12 @@ chopHash :: String -> String chopHash ('#':rest) = rest chopHash x = x -rpxnowLogin :: String -- ^ api key - -> Handler y HtmlObject -rpxnowLogin apiKey = do +rpxnowLogin :: YesodAuth y => Handler y HtmlObject +rpxnowLogin = do + ay <- getYesod + apiKey <- case rpxnowApiKey ay of + Just x -> return x + Nothing -> notFound token <- anyParam "token" postDest <- postParam "dest" dest' <- case postDest of diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 6e48385f..5298ef87 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -64,15 +64,8 @@ toHackApp :: Yesod y => y -> Hack.Application toHackApp a env = do key <- encryptKey a let app' = toHackApp' a - middleware = - [ gzip - , cleanPath - , jsonp - , methodOverride - , clientsession [authCookieName] key - ] - app = foldr ($) app' middleware - app env + (gzip $ cleanPath $ jsonp $ methodOverride + $ clientsession [authCookieName] key $ app') env toHackApp' :: Yesod y => y -> Hack.Application toHackApp' y env = do