Continued refactoring; cleaned up Yesod.Handler

Yesod.hs

@@ -1,21 +1,8 @@
 {-# LANGUAGE CPP #-}
----------------------------------------------------------
---
--- Module        : Yesod
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- 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)

Yesod/Content.hs

@@ -4,20 +4,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE Rank2Types #-}
----------------------------------------------------------
+
---
+module Yesod.Content
--- Module        : Yesod.Response
--- Copyright     : Michael Snoyman
--- License       : BSD3
---
--- Maintainer    : Michael Snoyman <michael@snoyman.com>
--- Stability     : Stable
--- Portability   : portable
---
--- Generating responses.
---
----------------------------------------------------------
-module Yesod.Response
     ( -- * 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)

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

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

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

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 ((***))

Yesod/Handler.hs

@@ -23,17 +23,14 @@ module Yesod.Handler
     ( -- * Handler monad
       Handler
     , GHandler
+      -- ** Read information from handler
     , getYesod
     , getYesodMaster
     , getUrlRender
     , getUrlRenderMaster
     , getRoute
-    , getRouteMaster
+      -- * Special responses
-    , runHandler
+    , RedirectType (..)
-    , liftIO
-    , YesodApp (..)
-    , Routes
-      -- * Special handlers
     , 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)
+                HCContent a -> unHandler (f a) rr
-                (HCSpecial e) -> return ([], HCSpecial e)
+                HCError e -> return ([], HCError e)
-                (HCContent a) -> unHandler (f a) rr
+                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))
+-- | Function used internally by Yesod in the process of converting a
-getRouteMaster = do
+-- 'GHandler' into an 'W.Application'. Should not be needed by users.
-    d <- getData
-    return $ handlerToMaster d <$> handlerRoute d
-
 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)

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 }

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 (..))
 

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.Content
-                     Yesod.Response
                      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