Separate ErrorResponse and SpecialResponse; added SendFile
This commit is contained in:
Michael Snoyman
parent
405fb3ac25
commit
309757c22d
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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) =
|
||||
|
||||
Loading…
Reference in New Issue
Block a user