From 09b07a5aad74aa2f117f70b181430a677a18ad86 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 23 Apr 2010 12:04:45 -0700 Subject: [PATCH] Continued refactoring; cleaned up Yesod.Handler --- Yesod.hs | 25 ++------ Yesod/{Response.hs => Content.hs} | 55 +---------------- Yesod/Definitions.hs | 6 +- Yesod/Dispatch.hs | 3 +- Yesod/Form.hs | 2 +- Yesod/Hamlet.hs | 3 +- Yesod/Handler.hs | 99 +++++++++++++++++++------------ Yesod/Json.hs | 12 ++-- Yesod/Yesod.hs | 3 +- yesod.cabal | 13 ++-- 10 files changed, 92 insertions(+), 129 deletions(-) rename Yesod/{Response.hs => Content.hs} (75%) diff --git a/Yesod.hs b/Yesod.hs index 988a4baf..bc15e2d4 100644 --- a/Yesod.hs +++ b/Yesod.hs @@ -1,21 +1,8 @@ {-# LANGUAGE CPP #-} ---------------------------------------------------------- --- --- Module : Yesod --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Lightweight framework for designing RESTful APIs. --- ---------------------------------------------------------- module Yesod ( module Yesod.Request - , module Yesod.Response + , module Yesod.Content , module Yesod.Yesod , module Yesod.Definitions , module Yesod.Handler @@ -27,25 +14,25 @@ module Yesod , Application , Method (..) , cs + , liftIO ) where #if TEST -import Yesod.Response hiding (testSuite) -import Yesod.Request hiding (testSuite) import Web.Mime hiding (testSuite) import Yesod.Json hiding (testSuite) #else -import Yesod.Response -import Yesod.Request import Web.Mime import Yesod.Json #endif +import Yesod.Content +import Yesod.Request import Yesod.Dispatch import Yesod.Form import Yesod.Yesod import Yesod.Definitions -import Yesod.Handler +import Yesod.Handler hiding (runHandler) import Network.Wai (Application, Method (..)) import Yesod.Hamlet import Data.Convertible.Text (cs) +import Control.Monad.IO.Class (liftIO) diff --git a/Yesod/Response.hs b/Yesod/Content.hs similarity index 75% rename from Yesod/Response.hs rename to Yesod/Content.hs index 0f1f9f3e..dfafc456 100644 --- a/Yesod/Response.hs +++ b/Yesod/Content.hs @@ -4,20 +4,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} ---------------------------------------------------------- --- --- Module : Yesod.Response --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- Generating responses. --- ---------------------------------------------------------- -module Yesod.Response + +module Yesod.Content ( -- * Content Content (..) , toContent @@ -31,13 +19,6 @@ module Yesod.Response , RepHtmlJson (..) , RepPlain (..) , RepXml (..) - -- * Special responses - , RedirectType (..) - , SpecialResponse (..) - -- * Error responses - , ErrorResponse (..) - -- * Header - , Header (..) ) where import Data.Maybe (mapMaybe) @@ -50,7 +31,6 @@ import Data.Convertible.Text import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -import Yesod.Request import Web.Mime -- | There are two different methods available for providing content in the @@ -149,34 +129,3 @@ instance HasReps RepPlain where newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (TypeXml, c) - --- | Different types of redirects. -data RedirectType = RedirectPermanent - | RedirectTemporary - | RedirectSeeOther - deriving (Show, Eq) - --- | 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 [(ParamName, ParamError)] - | PermissionDenied - | BadMethod String - deriving (Show, Eq) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie Int String String - | DeleteCookie String - | Header String String - deriving (Eq, Show) diff --git a/Yesod/Definitions.hs b/Yesod/Definitions.hs index fb51a1ed..a6140165 100644 --- a/Yesod/Definitions.hs +++ b/Yesod/Definitions.hs @@ -15,7 +15,8 @@ -- --------------------------------------------------------- module Yesod.Definitions - ( Approot + ( -- * Type synonyms + Approot , Language -- * Constant values , authCookieName @@ -24,9 +25,12 @@ module Yesod.Definitions , langKey , destCookieName , destCookieTimeout + -- * Other + , Routes ) where import Data.ByteString.Char8 (pack, ByteString) +import Web.Routes.Quasi (Routes) -- | An absolute URL to the base of this application. This can almost be done -- programatically, but due to ambiguities in different ways of doing URL diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 6fcd0822..3e356561 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -11,10 +11,11 @@ module Yesod.Dispatch ) where import Yesod.Handler -import Yesod.Response +import Yesod.Content import Yesod.Definitions import Yesod.Yesod import Yesod.Request +import Yesod.Internal import Web.Routes.Quasi import Language.Haskell.TH.Syntax diff --git a/Yesod/Form.hs b/Yesod/Form.hs index 4f01afd5..04f1ed9a 100644 --- a/Yesod/Form.hs +++ b/Yesod/Form.hs @@ -20,7 +20,6 @@ module Yesod.Form ) where import Yesod.Request -import Yesod.Response (ErrorResponse) import Yesod.Handler import Control.Applicative hiding (optional) import Data.Time (Day) @@ -28,6 +27,7 @@ import Data.Convertible.Text import Control.Monad.Attempt import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class (MonadIO) +import Yesod.Internal noParamNameError :: String noParamNameError = "No param name (miscalling of Yesod.Form library)" diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index ab185393..6492e557 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -21,8 +21,9 @@ module Yesod.Hamlet import Text.Hamlet import Text.Hamlet.Monad (outputHtml) -import Yesod.Response +import Yesod.Content import Yesod.Handler +import Yesod.Definitions import Data.Convertible.Text import Data.Object import Control.Arrow ((***)) diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index 8bc3fce9..00ae8ec4 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -23,17 +23,14 @@ module Yesod.Handler ( -- * Handler monad Handler , GHandler + -- ** Read information from handler , getYesod , getYesodMaster , getUrlRender , getUrlRenderMaster , getRoute - , getRouteMaster - , runHandler - , liftIO - , YesodApp (..) - , Routes - -- * Special handlers + -- * Special responses + , RedirectType (..) , redirect , sendFile , notFound @@ -44,12 +41,16 @@ module Yesod.Handler , addCookie , deleteCookie , header + -- * Internal Yesod + , runHandler + , YesodApp (..) ) where import Yesod.Request -import Yesod.Response +import Yesod.Content +import Yesod.Internal +import Yesod.Definitions import Web.Mime -import Web.Routes.Quasi (Routes) import Control.Exception hiding (Handler) import Control.Applicative @@ -73,6 +74,21 @@ data HandlerData sub master = HandlerData , handlerToMaster :: Routes sub -> Routes master } +-- | A generic handler monad, which can have a different subsite and master +-- site. This monad is a combination of reader for basic arguments, a writer +-- for headers, and an error-type monad for handling special responses. +newtype GHandler sub master a = Handler { + unHandler :: HandlerData sub master -> IO ([Header], HandlerContents a) +} + +-- | A 'GHandler' limited to the case where the master and sub sites are the +-- same. This is the usual case for application writing; only code written +-- specifically as a subsite need been concerned with the more general variety. +type Handler yesod = GHandler yesod yesod + +-- | An extension of the basic WAI 'W.Application' datatype to provide extra +-- features needed by Yesod. Users should never need to use this directly, as +-- the 'GHandler' monad and template haskell code should hide it away. newtype YesodApp = YesodApp { unYesodApp :: (ErrorResponse -> YesodApp) @@ -81,17 +97,11 @@ newtype YesodApp = YesodApp -> IO (W.Status, [Header], ContentType, Content) } ------- Handler monad -newtype GHandler sub master a = Handler { - unHandler :: HandlerData sub master - -> IO ([Header], HandlerContents a) -} -type Handler yesod = GHandler yesod yesod - data HandlerContents a = - HCSpecial SpecialResponse + HCContent a | HCError ErrorResponse - | HCContent a + | HCSendFile ContentType FilePath + | HCRedirect RedirectType String instance Functor (GHandler sub master) where fmap = liftM @@ -105,9 +115,10 @@ instance Monad (GHandler sub master) where (headers, c) <- handler rr (headers', c') <- case c of - (HCError e) -> return ([], HCError e) - (HCSpecial e) -> return ([], HCSpecial e) - (HCContent a) -> unHandler (f a) rr + HCContent a -> unHandler (f a) rr + HCError e -> return ([], HCError e) + HCSendFile ct fp -> return ([], HCSendFile ct fp) + HCRedirect rt url -> return ([], HCRedirect rt url) return (headers ++ headers', c') instance MonadIO (GHandler sub master) where liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i') @@ -119,28 +130,31 @@ instance RequestReader (GHandler sub master) where getData :: GHandler sub master (HandlerData sub master) getData = Handler $ \r -> return ([], HCContent r) +-- | Get the application argument. getYesod :: GHandler sub master sub getYesod = handlerSub <$> getData +-- | Get the master site appliation argument. getYesodMaster :: GHandler sub master master getYesodMaster = handlerMaster <$> getData +-- | Get the URL rendering function. getUrlRender :: GHandler sub master (Routes sub -> String) getUrlRender = do d <- getData return $ handlerRender d . handlerToMaster d +-- | Get the URL rendering function for the master site. getUrlRenderMaster :: GHandler sub master (Routes master -> String) getUrlRenderMaster = handlerRender <$> getData +-- | Get the route requested by the user. If this is a 404 response- where the +-- user requested an invalid route- this function will return 'Nothing'. getRoute :: GHandler sub master (Maybe (Routes sub)) getRoute = handlerRoute <$> getData -getRouteMaster :: GHandler sub master (Maybe (Routes master)) -getRouteMaster = do - d <- getData - return $ handlerToMaster d <$> handlerRoute d - +-- | Function used internally by Yesod in the process of converting a +-- 'GHandler' into an 'W.Application'. Should not be needed by users. runHandler :: HasReps c => GHandler sub master c -> (Routes master -> String) @@ -171,45 +185,48 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do c <- BL.readFile fp return (W.Status200, headers, ct, cs c) case contents of - HCError e -> handleError e - HCSpecial (Redirect rt loc) -> do - let hs = Header "Location" loc : headers - return (getRedirectStatus rt, hs, TypePlain, cs "") - HCSpecial (SendFile ct fp) -> Control.Exception.catch - (sendFile' ct fp) - (handleError . toErrorHandler) HCContent a -> do (ct, c) <- chooseRep a cts return (W.Status200, headers, ct, c) + HCError e -> handleError e + HCRedirect rt loc -> do + let hs = Header "Location" loc : headers + return (getRedirectStatus rt, hs, TypePlain, cs "") + HCSendFile ct fp -> Control.Exception.catch + (sendFile' ct fp) + (handleError . toErrorHandler) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er return (W.Status500, [], TypePlain, cs "Internal Server Error") ------- Special handlers -specialResponse :: SpecialResponse -> GHandler sub master a -specialResponse er = Handler $ \_ -> return ([], HCSpecial er) - -- | Redirect to the given URL. redirect :: RedirectType -> String -> GHandler sub master a -redirect rt = specialResponse . Redirect rt +redirect rt url = Handler $ \_ -> return ([], HCRedirect rt url) +-- | Bypass remaining handler code and output the given file. +-- +-- For some backends, this is more efficient than reading in the file to +-- memory, since they can optimize file sending via a system call to sendfile. sendFile :: ContentType -> FilePath -> GHandler sub master a -sendFile ct = specialResponse . SendFile ct +sendFile ct fp = Handler $ \_ -> return ([], HCSendFile ct fp) -- | Return a 404 not found page. Also denotes no handler available. notFound :: Failure ErrorResponse m => m a notFound = failure NotFound +-- | Return a 405 method not supported page. badMethod :: (RequestReader m, Failure ErrorResponse m) => m a badMethod = do w <- waiRequest failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w +-- | Return a 403 permission denied page. permissionDenied :: Failure ErrorResponse m => m a permissionDenied = failure PermissionDenied +-- | Return a 400 invalid arguments page. invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a invalidArgs = failure . InvalidArgs @@ -243,3 +260,9 @@ getRedirectStatus :: RedirectType -> W.Status getRedirectStatus RedirectPermanent = W.Status301 getRedirectStatus RedirectTemporary = W.Status302 getRedirectStatus RedirectSeeOther = W.Status303 + +-- | Different types of redirects. +data RedirectType = RedirectPermanent + | RedirectTemporary + | RedirectSeeOther + deriving (Show, Eq) diff --git a/Yesod/Json.hs b/Yesod/Json.hs index b6848e9c..6b81db07 100644 --- a/Yesod/Json.hs +++ b/Yesod/Json.hs @@ -20,15 +20,10 @@ import Control.Applicative import Data.Text (Text) import Web.Encodings import Yesod.Hamlet +import Yesod.Definitions import Control.Monad (when) -#if TEST -import Yesod.Response hiding (testSuite) -import Data.Text.Lazy (unpack) -import qualified Data.Text as T -#else -import Yesod.Response -#endif import Yesod.Handler +import Yesod.Content #if TEST import Test.Framework (testGroup, Test) @@ -36,7 +31,8 @@ import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.HUnit hiding (Test) import Test.QuickCheck -import Control.Monad (when) +import Data.Text.Lazy (unpack) +import qualified Data.Text as T #endif newtype Json url m a = Json { unJson :: Hamlet url m a } diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index e2a1888b..eea29116 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -8,7 +8,7 @@ module Yesod.Yesod , getApproot ) where -import Yesod.Response +import Yesod.Content import Yesod.Request import Yesod.Hamlet import Yesod.Handler @@ -18,6 +18,7 @@ import Network.Wai.Middleware.ClientSession import qualified Network.Wai as W import Yesod.Definitions import Yesod.Json +import Yesod.Internal import Web.Routes.Quasi (QuasiSite (..)) diff --git a/yesod.cabal b/yesod.cabal index eacce498..2aee6820 100644 --- a/yesod.cabal +++ b/yesod.cabal @@ -54,19 +54,20 @@ library web-routes-quasi >= 0.0 && < 0.1, hamlet >= 0.0 && < 0.1 exposed-modules: Yesod - Yesod.Request - Yesod.Response + Yesod.Content Yesod.Definitions + Yesod.Dispatch Yesod.Form Yesod.Hamlet - Yesod.Json Yesod.Handler - Yesod.Dispatch + Yesod.Internal + Yesod.Json + Yesod.Request Yesod.Yesod - Yesod.Helpers.Auth - Yesod.Helpers.Static Yesod.Helpers.AtomFeed + Yesod.Helpers.Auth Yesod.Helpers.Sitemap + Yesod.Helpers.Static Web.Mime ghc-options: -Wall