diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index d2def0c6..f00c24ef 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -50,6 +50,7 @@ import Control.Monad (liftM, ap) import System.IO import Data.Object.Html +import qualified Data.ByteString.Lazy as BL import Yesod.Parameter @@ -59,8 +60,8 @@ newtype Handler yesod a = Handler { -> IO ([Header], HandlerContents a) } data HandlerContents a = - forall e. Exception e => HCError e - | HCSpecial ErrorResult + HCSpecial SpecialResponse + | HCError ErrorResponse | HCContent a instance Functor (Handler yesod) where @@ -82,7 +83,7 @@ instance Monad (Handler yesod) where instance MonadIO (Handler yesod) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') instance Exception e => Failure e (Handler yesod) where - failure e = Handler $ \_ -> return ([], HCError e) + failure e = Handler $ \_ -> return ([], HCError $ InternalError $ show e) instance RequestReader (Handler yesod) where getRawRequest = Handler $ \(rr, _, _) -> return ([], HCContent rr) invalidParams = invalidArgs . map helper where @@ -95,7 +96,7 @@ instance HasTemplateGroup (Handler yesod) where getTemplateGroup = Handler $ \(_, _, tg) -> return ([], HCContent tg) runHandler :: Handler yesod RepChooser - -> (ErrorResult -> Handler yesod RepChooser) + -> (ErrorResponse -> Handler yesod RepChooser) -> RawRequest -> yesod -> TemplateGroup @@ -104,43 +105,50 @@ runHandler :: Handler yesod RepChooser runHandler (Handler handler) eh rr y tg cts = do (headers, contents) <- Control.Exception.catch (handler (rr, y, tg)) - (\e -> return ([], HCError (e :: Control.Exception.SomeException))) - let contents' = - case contents of - HCError e -> Left $ InternalError $ show e - HCSpecial e -> Left e - HCContent a -> Right a - case contents' of - Left e -> do - Response _ hs ct c <- runHandler (eh e) specialEh rr y tg cts - let hs' = headers ++ hs ++ getHeaders e + (\e -> return ([], HCError $ InternalError $ show + (e :: Control.Exception.SomeException))) + case contents of + HCError e -> do + Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts + let hs' = headers ++ hs return $ Response (getStatus e) hs' ct c - Right a -> do + HCSpecial (Redirect rt loc) -> do + let hs = Header "Location" loc : headers + return $ Response (getRedirectStatus rt) hs TypePlain $ cs "" + HCSpecial (SendFile ct fp) -> do + -- FIXME do error handling on this, or leave it to the app? + -- FIXME avoid lazy I/O by switching to WAI + c <- BL.readFile fp + return $ Response 200 headers ct $ Content c + HCContent a -> do (ct, c) <- a cts return $ Response 200 headers ct c -specialEh :: ErrorResult -> Handler yesod RepChooser -specialEh er = do +safeEh :: ErrorResponse -> Handler yesod RepChooser +safeEh er = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return $ chooseRep $ toHtmlObject "Internal server error" ------ Special handlers -errorResult :: ErrorResult -> Handler yesod a -errorResult er = Handler $ \_ -> return ([], HCSpecial er) +specialResponse :: SpecialResponse -> Handler yesod a +specialResponse er = Handler $ \_ -> return ([], HCSpecial er) + +errorResponse :: ErrorResponse -> Handler yesod a +errorResponse er = Handler $ \_ -> return ([], HCError er) -- | Redirect to the given URL. -redirect :: String -> Handler yesod a -redirect = errorResult . Redirect +redirect :: RedirectType -> String -> Handler yesod a +redirect rt = specialResponse . Redirect rt -- | Return a 404 not found page. Also denotes no handler available. notFound :: Handler yesod a -notFound = errorResult NotFound +notFound = errorResponse NotFound permissionDenied :: Handler yesod a -permissionDenied = errorResult PermissionDenied +permissionDenied = errorResponse PermissionDenied invalidArgs :: [(ParamName, ParamValue)] -> Handler yesod a -invalidArgs = errorResult . InvalidArgs +invalidArgs = errorResponse . InvalidArgs ------- Headers -- | Set the cookie on the client. diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index e9d2fb72..32d941bd 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -109,8 +109,9 @@ authOpenidForward = do let complete = authroot ++ "/openid/complete/" res <- runAttemptT $ OpenId.getForwardUrl oid complete attempt - (\err -> redirect $ "/auth/openid/?message=" ++ encodeUrl (show err)) - redirect + (\err -> redirect RedirectTemporary + $ "/auth/openid/?message=" ++ encodeUrl (show err)) + (redirect RedirectTemporary) res authOpenidComplete :: Handler y HtmlObject @@ -118,12 +119,13 @@ authOpenidComplete = do gets' <- rawGetParams <$> getRawRequest dest <- runRequest $ cookieParam "DEST" res <- runAttemptT $ OpenId.authenticate gets' - let onFailure err = redirect $ "/auth/openid/?message=" + let onFailure err = redirect RedirectTemporary + $ "/auth/openid/?message=" ++ encodeUrl (show err) let onSuccess (OpenId.Identifier ident) = do deleteCookie "DEST" header authCookieName ident - redirect $ fromMaybe "/" dest + redirect RedirectTemporary $ fromMaybe "/" dest attempt onFailure onSuccess res rpxnowLogin :: YesodAuth y => Handler y HtmlObject @@ -146,7 +148,7 @@ rpxnowLogin = do ident <- Rpxnow.authenticate apiKey token header authCookieName $ Rpxnow.identifier ident header authDisplayName $ getDisplayName ident - redirect dest + redirect RedirectTemporary dest -- | Get some form of a display name, defaulting to the identifier. getDisplayName :: Rpxnow.Identifier -> String @@ -170,7 +172,7 @@ authLogout :: YesodAuth y => Handler y HtmlObject authLogout = do deleteCookie authCookieName ar <- getApproot - redirect ar + redirect RedirectTemporary ar -- FIXME check the DEST information authIdentifier :: YesodAuth y => Handler y String @@ -183,5 +185,5 @@ authIdentifier = do let dest = ar ++ rp lp <- defaultLoginPath `fmap` getYesod addCookie 120 "DEST" dest - redirect $ ar ++ lp + redirect RedirectTemporary $ ar ++ lp Just x -> return x diff --git a/Yesod/Response.hs b/Yesod/Response.hs index e3089441..13e9ea99 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -19,13 +19,16 @@ --------------------------------------------------------- module Yesod.Response ( Response (..) - -- * Abnormal responses - , ErrorResult (..) - , getHeaders + -- * Special responses + , RedirectType (..) + , getRedirectStatus + , SpecialResponse (..) + -- * Error responses + , ErrorResponse (..) , getStatus -- * Header , Header (..) - , toPair + , headerToPair -- * Converting to Hack values , responseToHackResponse #if TEST @@ -49,35 +52,45 @@ import qualified Hack import Test.Framework (testGroup, Test) #endif -import Data.Generics -import Control.Exception (Exception) import Data.Convertible.Text (cs) import Web.Mime data Response = Response Int [Header] ContentType Content deriving Show --- | Abnormal return codes. -data ErrorResult = - Redirect String - | NotFound +-- | Different types of redirects. +data RedirectType = RedirectPermanent + | RedirectTemporary + | RedirectSeeOther + deriving (Show, Eq) + +getRedirectStatus :: RedirectType -> Int +getRedirectStatus RedirectPermanent = 301 +getRedirectStatus RedirectTemporary = 302 +getRedirectStatus RedirectSeeOther = 303 + +-- | Special types of responses which should short-circuit normal response +-- processing. +data SpecialResponse = + Redirect RedirectType String + | SendFile ContentType FilePath + deriving (Show, Eq) + +-- | Responses to indicate some form of an error occurred. These are different +-- from 'SpecialResponse' in that they allow for custom error pages. +data ErrorResponse = + NotFound | InternalError String | InvalidArgs [(String, String)] | PermissionDenied - deriving (Show, Typeable) -instance Exception ErrorResult + deriving (Show, Eq) -getStatus :: ErrorResult -> Int -getStatus (Redirect _) = 303 +getStatus :: ErrorResponse -> Int getStatus NotFound = 404 getStatus (InternalError _) = 500 getStatus (InvalidArgs _) = 400 getStatus PermissionDenied = 403 -getHeaders :: ErrorResult -> [Header] -getHeaders (Redirect s) = [Header "Location" s] -getHeaders _ = [] - ----- header stuff -- | Headers to be added to a 'Result'. data Header = @@ -87,21 +100,21 @@ data Header = deriving (Eq, Show) -- | Convert Header to a key/value pair. -toPair :: Header -> IO (String, String) -toPair (AddCookie minutes key value) = do +headerToPair :: Header -> IO (String, String) +headerToPair (AddCookie minutes key value) = do now <- getCurrentTime let expires = addUTCTime (fromIntegral $ minutes * 60) now return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires=" ++ formatW3 expires) -toPair (DeleteCookie key) = return +headerToPair (DeleteCookie key) = return ("Set-Cookie", key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -toPair (Header key value) = return (key, value) +headerToPair (Header key value) = return (key, value) responseToHackResponse :: [String] -- ^ language list -> Response -> IO Hack.Response responseToHackResponse _FIXMEls (Response sc hs ct c) = do - hs' <- mapM toPair hs + hs' <- mapM headerToPair hs let hs'' = ("Content-Type", cs ct) : hs' let asLBS = unContent c return $ Hack.Response sc hs'' asLBS diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index 85b41f4c..3b9411a9 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -43,7 +43,7 @@ class Yesod a where clientSessionDuration = const 120 -- | Output error response pages. - errorHandler :: ErrorResult -> Handler a RepChooser + errorHandler :: ErrorResponse -> Handler a RepChooser errorHandler = defaultErrorHandler -- | The template directory. Blank means no templates. @@ -58,13 +58,11 @@ getApproot :: YesodApproot y => Handler y Approot getApproot = approot `fmap` getYesod defaultErrorHandler :: Yesod y - => ErrorResult + => ErrorResponse -> Handler y RepChooser defaultErrorHandler NotFound = do rr <- getRawRequest return $ chooseRep $ toHtmlObject $ "Not found: " ++ show rr -defaultErrorHandler (Redirect url) = - return $ chooseRep $ toHtmlObject $ "Redirect to: " ++ url defaultErrorHandler PermissionDenied = return $ chooseRep $ toHtmlObject "Permission denied" defaultErrorHandler (InvalidArgs ia) =