Separate ErrorResponse and SpecialResponse; added SendFile

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 SpecialResponse
-    | HCSpecial ErrorResult
+    | 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)))
+        (\e -> return ([], HCError $ InternalError $ show
-    let contents' =
+                             (e :: Control.Exception.SomeException)))
-            case contents of
+    case contents of
-                HCError e -> Left $ InternalError $ show e
+        HCError e -> do
-                HCSpecial e -> Left e
+            Response _ hs ct c <- runHandler (eh e) safeEh rr y tg cts
-                HCContent a -> Right a
+            let hs' = headers ++ hs
-    case contents' of
-        Left e -> do
-            Response _ hs ct c <- runHandler (eh e) specialEh rr y tg cts
-            let hs' = headers ++ hs ++ getHeaders e
             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
+safeEh :: ErrorResponse -> Handler yesod RepChooser
-specialEh er = do
+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
+specialResponse :: SpecialResponse -> Handler yesod a
-errorResult er = Handler $ \_ -> return ([], HCSpecial er)
+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 :: RedirectType -> String -> Handler yesod a
-redirect = errorResult . Redirect
+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.

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))
+      (\err -> redirect RedirectTemporary
-      redirect
+                  $ "/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

Yesod/Response.hs

@@ -19,13 +19,16 @@
 ---------------------------------------------------------
 module Yesod.Response
     ( Response (..)
-      -- * Abnormal responses
+      -- * Special responses
-    , ErrorResult (..)
+    , RedirectType (..)
-    , getHeaders
+    , 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.
+-- | Different types of redirects.
-data ErrorResult =
+data RedirectType = RedirectPermanent
-    Redirect String
+                  | RedirectTemporary
-    | NotFound
+                  | 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)
+    deriving (Show, Eq)
-instance Exception ErrorResult
 
-getStatus :: ErrorResult -> Int
+getStatus :: ErrorResponse -> Int
-getStatus (Redirect _) = 303
 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)
+headerToPair :: Header -> IO (String, String)
-toPair (AddCookie minutes key value) = do
+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

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) =