From 91f98c480ea8b2b86fc7dd0e0b49b4c57fb31ee0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Jan 2013 11:12:25 +0200 Subject: [PATCH 001/165] Removed instance Exception ErrorResponse --- yesod-core/Yesod/Handler.hs | 4 ++-- yesod-core/Yesod/Internal.hs | 1 - 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 2d3ceac3..554263dd 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -463,8 +463,8 @@ runHandler handler mrender sroute tomr master sub upload log' = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of - Just x -> x - Nothing -> InternalError $ T.pack $ show e + Just (HCError x) -> x + _ -> InternalError $ T.pack $ show e istate <- liftIO $ I.newIORef GHState { ghsSession = initSession , ghsRBC = Nothing diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index d1560e30..23ebc15f 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -59,7 +59,6 @@ data ErrorResponse = | PermissionDenied Text | BadMethod H.Method deriving (Show, Eq, Typeable) -instance Exception ErrorResponse ----- header stuff -- | Headers to be added to a 'Result'. From f78559d7ed5615722bbf36185806164cd8008ec3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 15 Jan 2013 11:23:21 +0200 Subject: [PATCH 002/165] Remove deprecated Yesod.Widget functions (fixes #469) --- yesod-core/Yesod/Widget.hs | 80 ++++++-------------------- yesod-core/test/YesodCoreTest/Media.hs | 2 +- 2 files changed, 17 insertions(+), 65 deletions(-) diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index bd94bd39..2a4ec532 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -6,8 +6,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} --- FIXME Should we remove the older names here (addJulius, etc)? - -- | Widgets combine HTML with JS and CSS dependencies with a unique identifier -- generator, allowing you to create truly modular HTML components. module Yesod.Widget @@ -22,22 +20,14 @@ module Yesod.Widget , ToWidget (..) , ToWidgetHead (..) , ToWidgetBody (..) + , ToWidgetMedia (..) -- * Creating -- ** Head of page , setTitle , setTitleI - , addHamletHead - , addHtmlHead -- ** Body - , addHamlet - , addHtml - , addWidget , addSubWidget -- ** CSS - , addCassius - , addCassiusMedia - , addLucius - , addLuciusMedia , addStylesheet , addStylesheetAttrs , addStylesheetRemote @@ -45,8 +35,6 @@ module Yesod.Widget , addStylesheetEither , CssBuilder (..) -- ** Javascript - , addJulius - , addJuliusBody , addScript , addScriptAttrs , addScriptRemote @@ -139,6 +127,21 @@ instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub ma instance ToWidget sub master Html where toWidget = toWidget . const +-- | Allows adding some CSS to the page with a specific media type. +-- +-- Since 1.2 +class ToWidgetMedia sub master a where + -- | Add the given content to the page, but only for the given media type. + -- + -- Since 1.2 + toWidgetMedia :: Text -- ^ media value + -> a + -> GWidget sub master () +instance render ~ RY master => ToWidgetMedia sub master (render -> Css) where + toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x +instance render ~ RY master => ToWidgetMedia sub master (render -> CssBuilder) where + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty + class ToWidgetBody sub master a where toWidgetBody :: a -> GWidget sub master () @@ -175,48 +178,6 @@ setTitleI msg = do mr <- lift getMessageRender setTitle $ toHtml $ mr msg -{-# DEPRECATED addHamletHead, addHtmlHead "Use toWidgetHead instead" #-} -{-# DEPRECATED addHamlet, addHtml, addCassius, addLucius, addJulius "Use toWidget instead" #-} -{-# DEPRECATED addJuliusBody "Use toWidgetBody instead" #-} -{-# DEPRECATED addWidget "addWidget can be omitted" #-} - --- | Add a 'Hamlet' to the head tag. -addHamletHead :: HtmlUrl (Route master) -> GWidget sub master () -addHamletHead = toWidgetHead - --- | Add a 'Html' to the head tag. -addHtmlHead :: Html -> GWidget sub master () -addHtmlHead = toWidgetHead . const - --- | Add a 'Hamlet' to the body tag. -addHamlet :: HtmlUrl (Route master) -> GWidget sub master () -addHamlet = toWidget - --- | Add a 'Html' to the body tag. -addHtml :: Html -> GWidget sub master () -addHtml = toWidget - --- | Add another widget. This is defined as 'id', by can help with types, and --- makes widget blocks look more consistent. -addWidget :: GWidget sub master () -> GWidget sub master () -addWidget = id - --- | Add some raw CSS to the style tag. Applies to all media types. -addCassius :: CssUrl (Route master) -> GWidget sub master () -addCassius = toWidget - --- | Identical to 'addCassius'. -addLucius :: CssUrl (Route master) -> GWidget sub master () -addLucius = toWidget - --- | Add some raw CSS to the style tag, for a specific media type. -addCassiusMedia :: Text -> CssUrl (Route master) -> GWidget sub master () -addCassiusMedia m x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just m) $ \r -> fromLazyText $ renderCss $ x r) mempty mempty - --- | Identical to 'addCassiusMedia'. -addLuciusMedia :: Text -> CssUrl (Route master) -> GWidget sub master () -addLuciusMedia = addCassiusMedia - -- | Link to the specified local stylesheet. addStylesheet :: Route master -> GWidget sub master () addStylesheet = flip addStylesheetAttrs [] @@ -255,15 +216,6 @@ addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty --- | Include raw Javascript in the page's script tag. -addJulius :: JavascriptUrl (Route master) -> GWidget sub master () -addJulius = toWidget - --- | Add a new script tag to the body with the contents of this 'Julius' --- template. -addJuliusBody :: JavascriptUrl (Route master) -> GWidget sub master () -addJuliusBody = toWidgetBody - -- | Content for a web page. By providing this datatype, we can easily create -- generic site templates, which would have the type signature: -- diff --git a/yesod-core/test/YesodCoreTest/Media.hs b/yesod-core/test/YesodCoreTest/Media.hs index 490b6bdb..09bd1d2f 100644 --- a/yesod-core/test/YesodCoreTest/Media.hs +++ b/yesod-core/test/YesodCoreTest/Media.hs @@ -27,7 +27,7 @@ instance Yesod Y where getRootR :: Handler RepHtml getRootR = defaultLayout $ do toWidget [lucius|foo1{bar:baz}|] - addCassiusMedia "screen" [lucius|foo2{bar:baz}|] + toWidgetMedia "screen" [lucius|foo2{bar:baz}|] toWidget [lucius|foo3{bar:baz}|] getStaticR :: Handler RepHtml From ed53b2030841cbb5a38c20195307931bcc83cd91 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 12 Feb 2013 15:42:45 +0200 Subject: [PATCH 003/165] Merge yesod-json functionality into yesod-core (closes #487) --- sources.txt | 1 - yesod-core/Yesod/Core.hs | 2 + .../Yesod => yesod-core/Yesod/Core}/Json.hs | 16 ++------ yesod-core/yesod-core.cabal | 2 + yesod-json/LICENSE | 20 ---------- yesod-json/README | 0 yesod-json/Setup.lhs | 7 ---- yesod-json/yesod-json.cabal | 37 ------------------- 8 files changed, 8 insertions(+), 77 deletions(-) rename {yesod-json/Yesod => yesod-core/Yesod/Core}/Json.hs (92%) delete mode 100644 yesod-json/LICENSE delete mode 100644 yesod-json/README delete mode 100755 yesod-json/Setup.lhs delete mode 100644 yesod-json/yesod-json.cabal diff --git a/sources.txt b/sources.txt index 3830938b..ef9a273b 100644 --- a/sources.txt +++ b/sources.txt @@ -1,6 +1,5 @@ ./yesod-routes ./yesod-core -./yesod-json ./yesod-static ./yesod-persistent ./yesod-newsfeed diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 7268d6cb..e8f65d6a 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -55,6 +55,7 @@ module Yesod.Core , module Yesod.Request , module Yesod.Widget , module Yesod.Message + , module Yesod.Core.Json ) where import Yesod.Internal.Core @@ -65,6 +66,7 @@ import Yesod.Handler import Yesod.Request import Yesod.Widget import Yesod.Message +import Yesod.Core.Json import Control.Monad.Logger diff --git a/yesod-json/Yesod/Json.hs b/yesod-core/Yesod/Core/Json.hs similarity index 92% rename from yesod-json/Yesod/Json.hs rename to yesod-core/Yesod/Core/Json.hs index eb46612a..64cb7cc5 100644 --- a/yesod-json/Yesod/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Yesod.Json +module Yesod.Core.Json ( -- * Convert from a JSON value defaultLayoutJson , jsonToRepJson @@ -26,7 +26,7 @@ import Yesod.Content ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) , RepJson (RepJson), Content (ContentBuilder) ) -import Yesod.Core (defaultLayout, Yesod) +import Yesod.Internal.Core (defaultLayout, Yesod) import Yesod.Widget (GWidget) import Yesod.Routes.Class import Control.Arrow (second) @@ -49,15 +49,7 @@ import Data.Conduit (($$)) import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) import qualified Data.ByteString.Char8 as B8 -import Safe (headMay) - -#if !MIN_VERSION_yesod_core(1, 1, 5) -instance ToContent J.Value where - toContent = flip ContentBuilder Nothing - . Blaze.fromLazyText - . toLazyText - . fromValue -#endif +import Data.Maybe (listToMaybe) -- | Provide both an HTML and JSON representation for a piece of -- data, using the default layout for the HTML output @@ -133,6 +125,6 @@ jsonOrRedirect r j = do acceptsJson :: Yesod master => GHandler sub master Bool acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) . join - . fmap (headMay . parseHttpAccept) + . fmap (listToMaybe . parseHttpAccept) . lookup "Accept" . requestHeaders <$> waiRequest diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 1a2e86cf..250e1ef8 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -85,9 +85,11 @@ library , lifted-base >= 0.1 , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 + , attoparsec-conduit exposed-modules: Yesod.Content Yesod.Core + Yesod.Core.Json Yesod.Dispatch Yesod.Handler Yesod.Request diff --git a/yesod-json/LICENSE b/yesod-json/LICENSE deleted file mode 100644 index d9f04179..00000000 --- a/yesod-json/LICENSE +++ /dev/null @@ -1,20 +0,0 @@ -Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/yesod-json/README b/yesod-json/README deleted file mode 100644 index e69de29b..00000000 diff --git a/yesod-json/Setup.lhs b/yesod-json/Setup.lhs deleted file mode 100755 index 06e2708f..00000000 --- a/yesod-json/Setup.lhs +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/yesod-json/yesod-json.cabal b/yesod-json/yesod-json.cabal deleted file mode 100644 index c9115f04..00000000 --- a/yesod-json/yesod-json.cabal +++ /dev/null @@ -1,37 +0,0 @@ -name: yesod-json -version: 1.1.2 -license: MIT -license-file: LICENSE -author: Michael Snoyman -maintainer: Michael Snoyman -synopsis: Generate content for Yesod using the aeson package. -category: Web, Yesod -stability: Stable -cabal-version: >= 1.6 -build-type: Simple -homepage: http://www.yesodweb.com/ -description: Generate content for Yesod using the aeson package. - -library - build-depends: base >= 4 && < 5 - , yesod-core >= 1.1 && < 1.2 - , yesod-routes >= 1.1 && < 1.2 - , aeson >= 0.5 - , text >= 0.8 && < 1.0 - , shakespeare-js >= 1.0 && < 1.2 - , vector >= 0.9 - , containers >= 0.2 - , blaze-builder - , attoparsec-conduit >= 0.5 && < 0.6 - , conduit >= 0.5 && < 0.6 - , transformers >= 0.2.2 && < 0.4 - , wai >= 1.3 && < 1.4 - , wai-extra >= 1.3 && < 1.4 - , bytestring >= 0.9 - , safe >= 0.2 && < 0.4 - exposed-modules: Yesod.Json - ghc-options: -Wall - -source-repository head - type: git - location: https://github.com/yesodweb/yesod From 23ee947ba19241a8d31269535891f8b475076261 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 12 Feb 2013 15:49:59 +0200 Subject: [PATCH 004/165] IsContent instance for ResumableSource #466 --- yesod-core/Yesod/Content.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index 0ececbb8..efb2cae5 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -65,7 +65,8 @@ import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) import Data.String (IsString (fromString)) import Network.Wai (FilePart) -import Data.Conduit (Source, ResourceT, Flush) +import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput) +import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Aeson as J import Data.Aeson.Encode (fromValue) @@ -110,6 +111,17 @@ instance ToContent String where instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing +instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where + toContent src = ContentSource $ mapOutput toFlushBuilder src +instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where + toContent (ResumableSource src _) = toContent src + +class ToFlushBuilder a where toFlushBuilder :: a -> Flush Builder +instance ToFlushBuilder (Flush Builder) where toFlushBuilder = id +instance ToFlushBuilder Builder where toFlushBuilder = Chunk +instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString +instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString + -- | A function which gives targetted representations of content based on the -- content-types the user accepts. type ChooseRep = From 397004767e11487e610584c95090bbc55eaf67c7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 12 Feb 2013 16:59:37 +0200 Subject: [PATCH 005/165] Remove yesod-json deps --- yesod-auth/yesod-auth.cabal | 1 - yesod/yesod.cabal | 1 - 2 files changed, 2 deletions(-) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 89ef3d7d..7a2c284d 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -27,7 +27,6 @@ library , hamlet >= 1.1 && < 1.2 , shakespeare-css >= 1.0 && < 1.1 , shakespeare-js >= 1.0.2 && < 1.2 - , yesod-json >= 1.1 && < 1.2 , containers , unordered-containers , yesod-form >= 1.1 && < 1.3 diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index c09189af..0370c4ca 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -29,7 +29,6 @@ library build-depends: base >= 4.3 && < 5 , yesod-core >= 1.1.5 && < 1.2 , yesod-auth >= 1.1 && < 1.2 - , yesod-json >= 1.1 && < 1.2 , yesod-persistent >= 1.1 && < 1.2 , yesod-form >= 1.1 && < 1.3 , yesod-default >= 1.1.3 && < 1.2 From afd700753c0b92e32fe6bb0766a90d9bc93c4bc7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 05:26:34 +0200 Subject: [PATCH 006/165] Use RequestBodyLength --- yesod-core/Yesod/Handler.hs | 18 +++++++------- yesod-core/Yesod/Internal/Core.hs | 24 +++++++------------ yesod-core/Yesod/Internal/Request.hs | 15 ++++-------- .../test/YesodCoreTest/InternalRequest.hs | 18 +++++++------- .../test/YesodCoreTest/RequestBodySize.hs | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 6 files changed, 37 insertions(+), 44 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index ccc3a0c4..81fb01e0 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -179,7 +179,6 @@ import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Control.Monad.Base import Yesod.Routes.Class -import Data.Word (Word64) import Language.Haskell.TH.Syntax (Loc) class YesodSubRoute s y where @@ -193,7 +192,7 @@ data HandlerData sub master = HandlerData , handlerRender :: Route master -> [(Text, Text)] -> Text , handlerToMaster :: Route sub -> Route master , handlerState :: I.IORef GHState - , handlerUpload :: Word64 -> FileUpload + , handlerUpload :: W.RequestBodyLength -> FileUpload , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () } @@ -313,7 +312,9 @@ runRequestBody :: GHandler s m RequestBodyContents runRequestBody = do hd <- ask let getUpload = handlerUpload hd - len = reqBodySize $ handlerRequest hd + len = W.requestBodyLength + $ reqWaiRequest + $ handlerRequest hd upload = getUpload len x <- get case ghsRBC x of @@ -422,9 +423,10 @@ handlerToIO = -- Let go of the request body, cache and response headers. let oldReq = handlerRequest oldHandlerData oldWaiReq = reqWaiRequest oldReq - newWaiReq = oldWaiReq { W.requestBody = mempty } - newReq = oldReq { reqWaiRequest = newWaiReq - , reqBodySize = 0 } + newWaiReq = oldWaiReq { W.requestBody = mempty + , W.requestBodyLength = W.KnownLength 0 + } + newReq = oldReq { reqWaiRequest = newWaiReq } clearedOldHandlerData = oldHandlerData { handlerRequest = err "handlerRequest never here" , handlerState = err "handlerState never here" } @@ -457,7 +459,7 @@ runHandler :: HasReps c -> (Route sub -> Route master) -> master -> sub - -> (Word64 -> FileUpload) + -> (W.RequestBodyLength -> FileUpload) -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> YesodApp runHandler handler mrender sroute tomr master sub upload log' = @@ -872,7 +874,7 @@ getSession = liftM ghsSession get handlerToYAR :: (HasReps a, HasReps b) => master -- ^ master site foundation -> sub -- ^ sub site foundation - -> (Word64 -> FileUpload) + -> (W.RequestBodyLength -> FileUpload) -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index cd3f0c02..60b801a0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternGuards #-} -- | The basic typeclass for a Yesod application. module Yesod.Internal.Core ( -- * Type classes @@ -360,13 +361,12 @@ $doctype 5 -- | How to store uploaded files. -- -- Default: When the request body is greater than 50kb, store in a temp - -- file. Otherwise, store in memory. - fileUpload :: a - -> Word64 -- ^ request body size - -> FileUpload - fileUpload _ size - | size > 50000 = FileUploadDisk tempFileBackEnd - | otherwise = FileUploadMemory lbsBackEnd + -- file. For chunked request bodies, store in a temp file. Otherwise, store + -- in memory. + fileUpload :: a -> W.RequestBodyLength -> FileUpload + fileUpload _ (W.KnownLength size) + | size <= 50000 = FileUploadMemory lbsBackEnd + fileUpload _ _ = FileUploadDisk tempFileBackEnd -- | Should we log the given log source/level combination. -- @@ -433,13 +433,13 @@ defaultYesodRunner :: Yesod master -> Maybe (SessionBackend master) -> W.Application defaultYesodRunner logger handler' master sub murl toMasterRoute msb req - | maxLen < len = return tooLargeResponse + | W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ _ = return [] now <- liftIO getCurrentTime -- FIXME remove in next major version bump (session, saveSession) <- liftIO $ do maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb - rr <- liftIO $ parseWaiRequest req session (isJust msb) len maxLen + rr <- liftIO $ parseWaiRequest req session (isJust msb) maxLen let h = {-# SCC "h" #-} do case murl of Nothing -> handler @@ -474,11 +474,6 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req return $ yarToResponse yar extraHeaders where maxLen = maximumContentLength master $ fmap toMasterRoute murl - len = fromMaybe 0 $ lookup "content-length" (W.requestHeaders req) >>= readMay - readMay s = - case reads $ S8.unpack s of - [] -> Nothing - (x, _):_ -> Just x handler = yesodMiddleware handler' data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text @@ -920,7 +915,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) - , reqBodySize = 0 } fakeContentType = [] _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 661456c8..a85bfe52 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -53,21 +53,15 @@ data Request = Request , reqLangs :: [Text] -- | A random, session-specific token used to prevent CSRF attacks. , reqToken :: Maybe Text - -- | Size of the request body. - -- - -- Note: in the presence of chunked request bodies, this value will be 0, - -- even though data is available. - , reqBodySize :: Word64 -- FIXME Consider in the future using a Maybe to represent chunked bodies } parseWaiRequest :: W.Request -> [(Text, ByteString)] -- ^ session -> Bool - -> Word64 -- ^ actual length... might be meaningless, see 'reqBodySize' -> Word64 -- ^ maximum allowed body size -> IO Request -parseWaiRequest env session' useToken bodySize maxBodySize = - parseWaiRequest' env session' useToken bodySize maxBodySize <$> newStdGen +parseWaiRequest env session' useToken maxBodySize = + parseWaiRequest' env session' useToken maxBodySize <$> newStdGen -- | Impose a limit on the size of the request body. limitRequestBody :: Word64 -> W.Request -> W.Request @@ -98,12 +92,11 @@ parseWaiRequest' :: RandomGen g => W.Request -> [(Text, ByteString)] -- ^ session -> Bool - -> Word64 -> Word64 -- ^ max body size -> g -> Request -parseWaiRequest' env session' useToken bodySize maxBodySize gen = - Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token bodySize +parseWaiRequest' env session' useToken maxBodySize gen = + Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token where gets' = queryToQueryText $ W.queryString env gets'' = map (second $ fromMaybe "") gets' diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index 38194886..5344aa38 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -38,19 +38,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest [] False 0 1000 g + r = parseWaiRequest' defaultRequest [] False 1000 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 0 1000 g + r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 1000 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where - r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g + r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 1000 g generateToken :: Bool generateToken = reqToken r /= Nothing where - r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 0 1000 g + r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 1000 g langSpecs :: Spec @@ -64,21 +64,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest - { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 0 1000 g + { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 1000 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where - r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 0 1000 g + r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 1000 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] - } [] False 0 1000 g + } [] False 1000 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where - r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 0 1000 g + r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 1000 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where @@ -87,7 +87,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] - } [("_LANG", "en-SESSION")] False 0 10000 g + } [("_LANG", "en-SESSION")] False 10000 g internalRequestTest :: Spec diff --git a/yesod-core/test/YesodCoreTest/RequestBodySize.hs b/yesod-core/test/YesodCoreTest/RequestBodySize.hs index 937b887a..7d5fddbe 100644 --- a/yesod-core/test/YesodCoreTest/RequestBodySize.hs +++ b/yesod-core/test/YesodCoreTest/RequestBodySize.hs @@ -75,6 +75,10 @@ caseHelper name path body statusChunked statusNonChunked = describe name $ do then [("content-length", S8.pack $ show $ S.length body)] else [] , requestMethod = "POST" + , requestBodyLength = + if includeLength + then KnownLength $ fromIntegral $ S.length body + else ChunkedBody } $ L.fromChunks $ map S.singleton $ S.unpack body specs :: Spec diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 16215a81..3e6654fa 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -50,7 +50,7 @@ library build-depends: base >= 4.3 && < 5 , time >= 1.1.4 , yesod-routes >= 1.1 && < 1.2 - , wai >= 1.3 && < 1.5 + , wai >= 1.4 && < 1.5 , wai-extra >= 1.3 && < 1.4 , bytestring >= 0.9.1.4 , text >= 0.7 && < 0.12 From 20091656aaf67a658d5c0aee0be4f59dd4d6ba90 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 10:08:20 +0200 Subject: [PATCH 007/165] Make Felipe's session code the default (#415) --- yesod-core/Yesod/Core.hs | 1 - yesod-core/Yesod/Internal/Core.hs | 64 ++++------------------------ yesod-core/Yesod/Internal/Session.hs | 31 -------------- 3 files changed, 9 insertions(+), 87 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index e8f65d6a..583efeb9 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -35,7 +35,6 @@ module Yesod.Core , SessionBackend (..) , defaultClientSessionBackend , clientSessionBackend - , clientSessionBackend2 , clientSessionDateCacher , loadClientSession , Header(..) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 60b801a0..31c25ba8 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -26,8 +26,6 @@ module Yesod.Internal.Core , defaultClientSessionBackend , clientSessionBackend , loadClientSession - , clientSessionBackend2 - , loadClientSession2 , clientSessionDateCacher , BackendSession -- * jsLoader @@ -48,7 +46,6 @@ import Yesod.Handler hiding (lift, getExpires) import Control.Monad.Logger (logErrorS) import Yesod.Routes.Class -import Data.Time (UTCTime, addUTCTime, getCurrentTime) import Data.Word (Word64) import Control.Arrow ((***)) @@ -435,10 +432,9 @@ defaultYesodRunner :: Yesod master defaultYesodRunner logger handler' master sub murl toMasterRoute msb req | W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do - let dontSaveSession _ _ = return [] - now <- liftIO getCurrentTime -- FIXME remove in next major version bump + let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ do - maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req now) msb + maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb rr <- liftIO $ parseWaiRequest req session (isJust msb) maxLen let h = {-# SCC "h" #-} do case murl of @@ -468,7 +464,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req newSess (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) (reqToken rr) - sessionHeaders <- liftIO (saveSession nsToken now) + sessionHeaders <- liftIO (saveSession nsToken) return $ ("Content-Type", ct) : map headerToPair sessionHeaders _ -> return [] return $ yarToResponse yar extraHeaders @@ -755,67 +751,25 @@ defaultClientSessionBackend = do key <- CS.getKey CS.defaultKeyFile let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout - return $ clientSessionBackend2 key getCachedDate - + return $ clientSessionBackend key getCachedDate clientSessionBackend :: Yesod master - => CS.Key -- ^ The encryption key - -> Int -- ^ Inactive session valitity in minutes - -> SessionBackend master -clientSessionBackend key timeout = SessionBackend - { sbLoadSession = loadClientSession key timeout "_SESSION" - } -{-# DEPRECATED clientSessionBackend "Please use clientSessionBackend2, which is more efficient." #-} - -loadClientSession :: Yesod master - => CS.Key - -> Int -- ^ timeout - -> S8.ByteString -- ^ session name - -> master - -> W.Request - -> UTCTime - -> IO (BackendSession, SaveSession) -loadClientSession key timeout sessionName master req now = return (sess, save) - where - sess = fromMaybe [] $ do - raw <- lookup "Cookie" $ W.requestHeaders req - val <- lookup sessionName $ parseCookies raw - let host = "" -- fixme, properly lock sessions to client address - decodeClientSessionOld key now host val - save sess' now' = do - -- We should never cache the IV! Be careful! - iv <- liftIO CS.randomIV - return [AddCookie def - { setCookieName = sessionName - , setCookieValue = sessionVal iv - , setCookiePath = Just (cookiePath master) - , setCookieExpires = Just expires - , setCookieDomain = cookieDomain master - , setCookieHttpOnly = True - }] - where - host = "" -- fixme, properly lock sessions to client address - expires = fromIntegral (timeout * 60) `addUTCTime` now' - sessionVal iv = encodeClientSessionOld key iv expires host sess' -{-# DEPRECATED loadClientSession "Please use loadClientSession2, which is more efficient." #-} - -clientSessionBackend2 :: Yesod master => CS.Key -- ^ The encryption key -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' -> SessionBackend master -clientSessionBackend2 key getCachedDate = +clientSessionBackend key getCachedDate = SessionBackend { - sbLoadSession = \master req -> const $ loadClientSession2 key getCachedDate "_SESSION" master req + sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req } -loadClientSession2 :: Yesod master +loadClientSession :: Yesod master => CS.Key -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' -> S8.ByteString -- ^ session name -> master -> W.Request -> IO (BackendSession, SaveSession) -loadClientSession2 key getCachedDate sessionName master req = load +loadClientSession key getCachedDate sessionName master req = load where load = do date <- getCachedDate @@ -825,7 +779,7 @@ loadClientSession2 key getCachedDate sessionName master req = load val <- lookup sessionName $ parseCookies raw let host = "" -- fixme, properly lock sessions to client address decodeClientSession key date host val - save date sess' _ = do + save date sess' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV return [AddCookie def diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index ab17b698..dac74a41 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -1,13 +1,10 @@ module Yesod.Internal.Session ( encodeClientSession - , encodeClientSessionOld , decodeClientSession - , decodeClientSessionOld , clientSessionDateCacher , ClientSessionDateCache(..) , BackendSession , SaveSession - , SaveSessionOld , SessionBackend(..) ) where @@ -30,17 +27,11 @@ import qualified Network.Wai as W type BackendSession = [(Text, S8.ByteString)] type SaveSession = BackendSession -- ^ The session contents after running the handler - -> UTCTime -- FIXME remove this in the next major version bump - -> IO [Header] - -type SaveSessionOld = BackendSession -- ^ The session contents after running the handler - -> UTCTime -> IO [Header] newtype SessionBackend master = SessionBackend { sbLoadSession :: master -> W.Request - -> UTCTime -- FIXME remove this in the next major version bump -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session } @@ -137,25 +128,3 @@ posixDayLength_int64 = 86400 diffTimeScale :: DiffTime diffTimeScale = 1e12 - -encodeClientSessionOld :: CS.Key - -> CS.IV - -> UTCTime -- ^ expire time - -> ByteString -- ^ remote host - -> [(Text, ByteString)] -- ^ session - -> ByteString -- ^ cookie value -encodeClientSessionOld key iv expire rhost session' = - CS.encrypt key iv $ encode $ SessionCookie (Left expire) rhost session' - -decodeClientSessionOld :: CS.Key - -> UTCTime -- ^ current time - -> ByteString -- ^ remote host field - -> ByteString -- ^ cookie value - -> Maybe [(Text, ByteString)] -decodeClientSessionOld key now rhost encrypted = do - decrypted <- CS.decrypt key encrypted - SessionCookie (Left expire) rhost' session' <- - either (const Nothing) Just $ decode decrypted - guard $ expire > now - guard $ rhost' == rhost - return session' From 98613278d4f695f2cd608d69044fceb414db2d11 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 11:02:53 +0200 Subject: [PATCH 008/165] Yesod.Core.Types created, but it's a mess --- yesod-core/Yesod/Content.hs | 30 +- yesod-core/Yesod/Core.hs | 4 +- yesod-core/Yesod/Core/Json.hs | 9 +- yesod-core/Yesod/Core/Time.hs | 29 ++ yesod-core/Yesod/Core/Trans/Class.hs | 15 + yesod-core/Yesod/Core/Types.hs | 417 +++++++++++++++++++++++++++ yesod-core/Yesod/Dispatch.hs | 15 +- yesod-core/Yesod/Handler.hs | 123 +------- yesod-core/Yesod/Internal.hs | 88 +----- yesod-core/Yesod/Internal/Cache.hs | 8 +- yesod-core/Yesod/Internal/Core.hs | 30 +- yesod-core/Yesod/Internal/Request.hs | 29 +- yesod-core/Yesod/Internal/Session.hs | 66 +---- yesod-core/Yesod/Message.hs | 6 - yesod-core/Yesod/Widget.hs | 101 +------ yesod-core/yesod-core.cabal | 8 +- 16 files changed, 492 insertions(+), 486 deletions(-) create mode 100644 yesod-core/Yesod/Core/Time.hs create mode 100644 yesod-core/Yesod/Core/Trans/Class.hs create mode 100644 yesod-core/Yesod/Core/Types.hs delete mode 100644 yesod-core/Yesod/Message.hs diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index efb2cae5..41f6d208 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -63,8 +63,6 @@ import Data.Monoid (mempty) import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) -import Data.String (IsString (fromString)) -import Network.Wai (FilePart) import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput) import Data.Conduit.Internal (ResumableSource (ResumableSource)) @@ -72,19 +70,12 @@ import qualified Data.Aeson as J import Data.Aeson.Encode (fromValue) import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Text.Lazy.Builder (toLazyText) - -data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length. - | ContentSource !(Source (ResourceT IO) (Flush Builder)) - | ContentFile !FilePath !(Maybe FilePart) - | ContentDontEvaluate !Content +import Yesod.Core.Types -- | Zero-length enumerator. emptyContent :: Content emptyContent = ContentBuilder mempty $ Just 0 -instance IsString Content where - fromString = toContent - -- | Anything which can be converted into 'Content'. Most of the time, you will -- want to use the 'ContentBuilder' constructor. An easier approach will be to use -- a pre-defined 'toContent' function, such as converting your data into a lazy @@ -122,12 +113,6 @@ instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString --- | A function which gives targetted representations of content based on the --- content-types the user accepts. -type ChooseRep = - [ContentType] -- ^ list of content-types user accepts, ordered by preference - -> IO (ContentType, Content) - -- | Any type which can be converted to representations. class HasReps a where chooseRep :: a -> ChooseRep @@ -170,27 +155,20 @@ instance HasReps [(ContentType, Content)] where where go = simpleContentType -newtype RepHtml = RepHtml Content instance HasReps RepHtml where chooseRep (RepHtml c) _ = return (typeHtml, c) -newtype RepJson = RepJson Content instance HasReps RepJson where chooseRep (RepJson c) _ = return (typeJson, c) -data RepHtmlJson = RepHtmlJson Content Content instance HasReps RepHtmlJson where chooseRep (RepHtmlJson html json) = chooseRep [ (typeHtml, html) , (typeJson, json) ] -newtype RepPlain = RepPlain Content instance HasReps RepPlain where chooseRep (RepPlain c) _ = return (typePlain, c) -newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (typeXml, c) -type ContentType = B.ByteString -- FIXME Text? - typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -256,12 +234,6 @@ formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" formatRFC822 :: UTCTime -> T.Text formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" --- | Prevents a response body from being fully evaluated before sending the --- request. --- --- Since 1.1.0 -newtype DontFullyEvaluate a = DontFullyEvaluate a - instance HasReps a => HasReps (DontFullyEvaluate a) where chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 583efeb9..4f3dfa2f 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -53,8 +53,8 @@ module Yesod.Core , module Yesod.Handler , module Yesod.Request , module Yesod.Widget - , module Yesod.Message , module Yesod.Core.Json + , module Text.Shakespeare.I18N ) where import Yesod.Internal.Core @@ -64,8 +64,8 @@ import Yesod.Dispatch import Yesod.Handler import Yesod.Request import Yesod.Widget -import Yesod.Message import Yesod.Core.Json +import Text.Shakespeare.I18N import Control.Monad.Logger diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index ce98fb96..42f26777 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -24,7 +24,7 @@ module Yesod.Core.Json import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect) import Yesod.Content ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) - , RepJson (RepJson), Content (ContentBuilder) + , RepJson (RepJson) ) import Yesod.Internal.Core (defaultLayout, Yesod) import Yesod.Widget (GWidget) @@ -35,16 +35,9 @@ import Control.Monad (join) import qualified Data.Aeson as J import qualified Data.Aeson.Parser as JP import Data.Aeson ((.=)) -import qualified Data.Aeson.Encode as JE -import Data.Aeson.Encode (fromValue) import Data.Conduit.Attoparsec (sinkParser) import Data.Text (Text, pack) import qualified Data.Vector as V -import Text.Julius (ToJavascript (..)) -import Data.Text.Lazy.Builder (fromLazyText) -import Data.Text.Lazy.Encoding (decodeUtf8) -import Data.Text.Lazy.Builder (toLazyText) -import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze import Data.Conduit import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) diff --git a/yesod-core/Yesod/Core/Time.hs b/yesod-core/Yesod/Core/Time.hs new file mode 100644 index 00000000..371159df --- /dev/null +++ b/yesod-core/Yesod/Core/Time.hs @@ -0,0 +1,29 @@ +module Yesod.Core.Time + ( putTime + , getTime + ) where + +import Data.Int (Int64) +import Data.Serialize (Get, Put, Serialize (..)) +import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), + DiffTime, UTCTime (..)) + +putTime :: UTCTime -> Put +putTime (UTCTime d t) = + let d' = fromInteger $ toModifiedJulianDay d + t' = fromIntegral $ fromEnum (t / diffTimeScale) + in put (d' * posixDayLength_int64 + min posixDayLength_int64 t') + +getTime :: Get UTCTime +getTime = do + val <- get + let (d, t) = val `divMod` posixDayLength_int64 + d' = ModifiedJulianDay $! fromIntegral d + t' = fromIntegral t + d' `seq` t' `seq` return (UTCTime d' t') + +posixDayLength_int64 :: Int64 +posixDayLength_int64 = 86400 + +diffTimeScale :: DiffTime +diffTimeScale = 1e12 diff --git a/yesod-core/Yesod/Core/Trans/Class.hs b/yesod-core/Yesod/Core/Trans/Class.hs new file mode 100644 index 00000000..a4d362b5 --- /dev/null +++ b/yesod-core/Yesod/Core/Trans/Class.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +module Yesod.Core.Trans.Class (MonadLift (..)) where + +import Control.Monad.Trans.Class + +-- | The standard @MonadTrans@ class only allows lifting for monad +-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their +-- types do not express that they actually are transformers. This replacement +-- class accounts for this. +class MonadLift base m | m -> base where + lift :: base a -> m a +instance (Monad m, MonadTrans t) => MonadLift m (t m) where + lift = Control.Monad.Trans.Class.lift diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs new file mode 100644 index 00000000..49c57f13 --- /dev/null +++ b/yesod-core/Yesod/Core/Types.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Yesod.Core.Types where + +import qualified Blaze.ByteString.Builder as BBuilder +import qualified Blaze.ByteString.Builder.Char.Utf8 +import Control.Applicative (Applicative (..)) +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.Exception (Exception, throwIO) +import Control.Failure (Failure (..)) +import Control.Monad (liftM) +import Control.Monad.Base (MonadBase (liftBase)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (LogLevel, LogSource, + MonadLogger (..)) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Monad.Trans.Resource (MonadResource (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Conduit (Flush, MonadThrow (..), + MonadUnsafeIO (..), + ResourceT, Source) +import Data.IntMap (IntMap) +import Data.IORef (IORef) +import Data.Map (Map, unionWith) +import Data.Monoid (Any, Endo (..), Last (..), + Monoid (..)) +import Data.Serialize (Serialize (..), + putByteString) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as TBuilder +import Data.Time (UTCTime) +import Data.Typeable (Typeable) +import Language.Haskell.TH.Syntax (Loc) +import qualified Network.HTTP.Types as H +import Network.Wai (FilePart, + RequestBodyLength) +import qualified Network.Wai as W +import qualified Network.Wai.Parse as NWP +import System.Log.FastLogger (LogStr, toLogStr) +import Text.Blaze.Html (Html) +import Text.Hamlet (HtmlUrl) +import Text.Julius (JavascriptUrl) +import Web.Cookie (SetCookie) +import Yesod.Core.Time (getTime, putTime) +import Yesod.Core.Trans.Class (MonadLift (..)) +import Yesod.Routes.Class (RenderRoute (..)) + +-- Sessions +type BackendSession = [(Text, ByteString)] + +type SaveSession = BackendSession -- ^ The session contents after running the handler + -> IO [Header] + +newtype SessionBackend master = SessionBackend + { sbLoadSession :: master + -> W.Request + -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session + } + +data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)] + deriving (Show, Read) +instance Serialize SessionCookie where + put (SessionCookie a b c) = do + either putTime putByteString a + put b + put (map (first T.unpack) c) + + get = do + a <- getTime + b <- get + c <- map (first T.pack) <$> get + return $ SessionCookie (Left a) b c + +data ClientSessionDateCache = + ClientSessionDateCache { + csdcNow :: !UTCTime + , csdcExpires :: !UTCTime + , csdcExpiresSerialized :: !ByteString + } deriving (Eq, Show) + +-- | The parsed request information. +data Request = Request + { reqGetParams :: [(Text, Text)] + , reqCookies :: [(Text, Text)] + , reqWaiRequest :: W.Request + -- | Languages which the client supports. + , reqLangs :: [Text] + -- | A random, session-specific token used to prevent CSRF attacks. + , reqToken :: Maybe Text + } + +-- | A tuple containing both the POST parameters and submitted files. +type RequestBodyContents = + ( [(Text, Text)] + , [(Text, FileInfo)] + ) + +data FileInfo = FileInfo + { fileName :: Text + , fileContentType :: Text + , fileSource :: Source (ResourceT IO) ByteString + , fileMove :: FilePath -> IO () + } + +data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) + | FileUploadDisk (NWP.BackEnd FilePath) + | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) + +-- | How to determine the root of the application for constructing URLs. +-- +-- Note that future versions of Yesod may add new constructors without bumping +-- the major version number. As a result, you should /not/ pattern match on +-- @Approot@ values. +data Approot master = ApprootRelative -- ^ No application root. + | ApprootStatic Text + | ApprootMaster (master -> Text) + | ApprootRequest (master -> W.Request -> Text) + +type ResolvedApproot = Text + +data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text + deriving (Eq, Show, Read) + +data ScriptLoadPosition master + = BottomOfBody + | BottomOfHeadBlocking + | BottomOfHeadAsync (BottomOfHeadAsync master) + +type BottomOfHeadAsync master + = [Text] -- ^ urls to load asynchronously + -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion + -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of + +newtype Cache = Cache (IntMap Any) + deriving Monoid + +newtype CacheKey a = CacheKey Int + +type Texts = [Text] + +-- | Wrap up a normal WAI application as a Yesod subsite. +newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } + +data HandlerData sub master = HandlerData + { handlerRequest :: Request + , handlerSub :: sub + , handlerMaster :: master + , handlerRoute :: Maybe (Route sub) + , handlerRender :: Route master -> [(Text, Text)] -> Text + , handlerToMaster :: Route sub -> Route master + , handlerState :: IORef GHState + , handlerUpload :: RequestBodyLength -> FileUpload + , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + } + +-- | A generic handler monad, which can have a different subsite and master +-- site. We define a newtype for better error message. +newtype GHandler sub master a = GHandler + { unGHandler :: HandlerData sub master -> ResourceT IO a + } + +data GHState = GHState + { ghsSession :: SessionMap + , ghsRBC :: Maybe RequestBodyContents + , ghsIdent :: Int + , ghsCache :: Cache + , ghsHeaders :: Endo [Header] + } + +type SessionMap = Map Text ByteString + +-- | 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) + -> Request + -> [ContentType] + -> SessionMap + -> ResourceT IO YesodAppResult + } + +data YesodAppResult + = YARWai W.Response + | YARPlain H.Status [Header] ContentType Content SessionMap + +-- | A generic widget, allowing specification of both the subsite and master +-- site datatypes. While this is simply a @WriterT@, we define a newtype for +-- better error messages. +newtype GWidget sub master a = GWidget + { unGWidget :: GHandler sub master (a, GWData (Route master)) + } + +instance (a ~ ()) => Monoid (GWidget sub master a) where + mempty = return () + mappend x y = x >> y + +type RY master = Route master -> [(Text, Text)] -> Text + +-- | Newtype wrapper allowing injection of arbitrary content into CSS. +-- +-- Usage: +-- +-- > toWidget $ CssBuilder "p { color: red }" +-- +-- Since: 1.1.3 +newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } + +-- | Content for a web page. By providing this datatype, we can easily create +-- generic site templates, which would have the type signature: +-- +-- > PageContent url -> HtmlUrl url +data PageContent url = PageContent + { pageTitle :: Html + , pageHead :: HtmlUrl url + , pageBody :: HtmlUrl url + } + +data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content and optional content length. + | ContentSource !(Source (ResourceT IO) (Flush BBuilder.Builder)) + | ContentFile !FilePath !(Maybe FilePart) + | ContentDontEvaluate !Content + +-- | A function which gives targetted representations of content based on the +-- content-types the user accepts. +type ChooseRep = + [ContentType] -- ^ list of content-types user accepts, ordered by preference + -> IO (ContentType, Content) + +newtype RepHtml = RepHtml Content +newtype RepJson = RepJson Content +data RepHtmlJson = RepHtmlJson Content Content +newtype RepPlain = RepPlain Content +newtype RepXml = RepXml Content + +type ContentType = ByteString -- FIXME Text? + +-- | Prevents a response body from being fully evaluated before sending the +-- request. +-- +-- Since 1.1.0 +newtype DontFullyEvaluate a = DontFullyEvaluate a + +-- | 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 Text + | InvalidArgs [Text] + | PermissionDenied Text + | BadMethod H.Method + deriving (Show, Eq, Typeable) + +----- header stuff +-- | Headers to be added to a 'Result'. +data Header = + AddCookie SetCookie + | DeleteCookie ByteString ByteString + | Header ByteString ByteString + deriving (Eq, Show) + +data Location url = Local url | Remote Text + deriving (Show, Eq) + +newtype UniqueList x = UniqueList ([x] -> [x]) + +data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } + deriving (Show, Eq) +data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } + deriving (Show, Eq) +newtype Title = Title { unTitle :: Html } + +newtype Head url = Head (HtmlUrl url) + deriving Monoid +newtype Body url = Body (HtmlUrl url) + deriving Monoid + +type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder + +data GWData a = GWData + { gwdBody :: !(Body a) + , gwdTitle :: !(Last Title) + , gwdScripts :: !(UniqueList (Script a)) + , gwdStylesheets :: !(UniqueList (Stylesheet a)) + , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type + , gwdJavascript :: !(Maybe (JavascriptUrl a)) + , gwdHead :: !(Head a) + } +instance Monoid (GWData a) where + mempty = GWData mempty mempty mempty mempty mempty mempty mempty + mappend (GWData a1 a2 a3 a4 a5 a6 a7) + (GWData b1 b2 b3 b4 b5 b6 b7) = GWData + (a1 `mappend` b1) + (a2 `mappend` b2) + (a3 `mappend` b3) + (a4 `mappend` b4) + (unionWith mappend a5 b5) + (a6 `mappend` b6) + (a7 `mappend` b7) + +data HandlerContents = + HCContent H.Status ChooseRep + | HCError ErrorResponse + | HCSendFile ContentType FilePath (Maybe FilePart) + | HCRedirect H.Status Text + | HCCreated Text + | HCWai W.Response + deriving Typeable + +instance Show HandlerContents where + show _ = "Cannot show a HandlerContents" +instance Exception HandlerContents + +-- Instances for GWidget +instance Functor (GWidget sub master) where + fmap f (GWidget x) = GWidget (fmap (first f) x) +instance Applicative (GWidget sub master) where + pure a = GWidget $ pure (a, mempty) + GWidget f <*> GWidget v = + GWidget $ k <$> f <*> v + where + k (a, wa) (b, wb) = (a b, wa `mappend` wb) +instance Monad (GWidget sub master) where + return = pure + GWidget x >>= f = GWidget $ do + (a, wa) <- x + (b, wb) <- unGWidget (f a) + return (b, wa `mappend` wb) +instance MonadIO (GWidget sub master) where + liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO +instance MonadBase IO (GWidget sub master) where + liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase +instance MonadBaseControl IO (GWidget sub master) where + data StM (GWidget sub master) a = + StW (StM (GHandler sub master) (a, GWData (Route master))) + liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> + liftM (\x -> (x, mempty)) + (f $ liftM StW . runInBase . unGWidget) + restoreM (StW base) = GWidget $ restoreM base + +instance MonadUnsafeIO (GWidget sub master) where + unsafeLiftIO = liftIO +instance MonadThrow (GWidget sub master) where + monadThrow = liftIO . throwIO +instance MonadResource (GWidget sub master) where + liftResourceT = lift . liftResourceT + +instance MonadLogger (GWidget sub master) where + monadLoggerLog a b c = lift . monadLoggerLog a b c + +instance MonadLift (GHandler sub master) (GWidget sub master) where + lift = GWidget . fmap (\x -> (x, mempty)) + +instance MonadLift (ResourceT IO) (GHandler sub master) where + lift = GHandler . const + +-- Instances for GHandler +instance Functor (GHandler sub master) where + fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) +instance Applicative (GHandler sub master) where + pure = GHandler . const . pure + GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r +instance Monad (GHandler sub master) where + return = pure + GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r +instance MonadIO (GHandler sub master) where + liftIO = GHandler . const . lift +instance MonadBase IO (GHandler sub master) where + liftBase = GHandler . const . lift +-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s +-- @fork@ function is incompatible with the underlying @ResourceT@ system. +-- Instead, if you must fork a separate thread, you should use +-- @resourceForkIO@. +-- +-- Using fork usually leads to an exception that says +-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed +-- after cleanup. Please contact the maintainers.\" +instance MonadBaseControl IO (GHandler sub master) where + data StM (GHandler sub master) a = StH (StM (ResourceT IO) a) + liftBaseWith f = GHandler $ \reader -> + liftBaseWith $ \runInBase -> + f $ liftM StH . runInBase . (\(GHandler r) -> r reader) + restoreM (StH base) = GHandler $ const $ restoreM base + +instance MonadUnsafeIO (GHandler sub master) where + unsafeLiftIO = liftIO +instance MonadThrow (GHandler sub master) where + monadThrow = liftIO . throwIO +instance MonadResource (GHandler sub master) where + liftResourceT = lift . liftResourceT + +instance MonadLogger (GHandler sub master) where + monadLoggerLog a b c d = GHandler $ \hd -> + liftIO $ handlerLog hd a b c (toLogStr d) + +instance Exception e => Failure e (GHandler sub master) where + failure = liftIO . throwIO + +instance Monoid (UniqueList x) where + mempty = UniqueList id + UniqueList x `mappend` UniqueList y = UniqueList $ x . y + +instance IsString Content where + fromString = flip ContentBuilder Nothing . Blaze.ByteString.Builder.Char.Utf8.fromString + +instance RenderRoute WaiSubsite where + data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)] + deriving (Show, Eq, Read, Ord) + renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 1e193880..dc752019 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -33,7 +33,6 @@ import Control.Applicative ((<$>), (<*>)) import Prelude hiding (exp) import Yesod.Internal.Core import Yesod.Handler hiding (lift) -import Yesod.Widget (GWidget) import Web.PathPieces import Language.Haskell.TH @@ -56,8 +55,7 @@ import Yesod.Routes.TH import Yesod.Content (chooseRep) import Yesod.Routes.Parse import System.Log.FastLogger (Logger) - -type Texts = [Text] +import Yesod.Core.Types -- | Generates URL datatype and site function for the given 'Resource's. This -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter. @@ -210,14 +208,3 @@ sendRedirect y segments' env = then dest else (dest `mappend` Blaze.ByteString.Builder.fromByteString (W.rawQueryString env)) - --- | Wrap up a normal WAI application as a Yesod subsite. -newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } - -instance RenderRoute WaiSubsite where - data Route WaiSubsite = WaiSubsiteRoute [Text] [(Text, Text)] - deriving (Show, Eq, Read, Ord) - renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) - -instance YesodDispatch WaiSubsite master where - yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 81fb01e0..90e7f759 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -129,11 +129,8 @@ import Control.Exception hiding (Handler, catch, finally) import Control.Applicative import Control.Monad (liftM) -import Control.Failure (Failure (failure)) import Control.Monad.IO.Class -import Control.Monad.Trans.Class (MonadTrans) -import qualified Control.Monad.Trans.Class import System.IO import qualified Network.Wai as W @@ -163,7 +160,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString) import Data.Text (Text) -import Yesod.Message (RenderMessage (..)) +import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup @@ -172,30 +169,18 @@ import System.Log.FastLogger import Control.Monad.Logger import qualified Yesod.Internal.Cache as Cache -import Yesod.Internal.Cache (mkCacheKey, CacheKey) +import Yesod.Internal.Cache (mkCacheKey) import qualified Data.IORef as I import Control.Exception.Lifted (catch) -import Control.Monad.Trans.Control import Control.Monad.Trans.Resource -import Control.Monad.Base import Yesod.Routes.Class import Language.Haskell.TH.Syntax (Loc) +import Yesod.Core.Types +import Yesod.Core.Trans.Class class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y -data HandlerData sub master = HandlerData - { handlerRequest :: Request - , handlerSub :: sub - , handlerMaster :: master - , handlerRoute :: Maybe (Route sub) - , handlerRender :: Route master -> [(Text, Text)] -> Text - , handlerToMaster :: Route sub -> Route master - , handlerState :: I.IORef GHState - , handlerUpload :: W.RequestBodyLength -> FileUpload - , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () - } - handlerSubData :: (Route sub -> Route master) -> (master -> sub) -> Route sub @@ -270,38 +255,6 @@ toMasterHandlerMaybe :: (Route sub -> Route master) -> GHandler sub' master a toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) --- | A generic handler monad, which can have a different subsite and master --- site. We define a newtype for better error message. -newtype GHandler sub master a = GHandler - { unGHandler :: HandlerData sub master -> ResourceT IO a - } - -data GHState = GHState - { ghsSession :: SessionMap - , ghsRBC :: Maybe RequestBodyContents - , ghsIdent :: Int - , ghsCache :: Cache.Cache - , ghsHeaders :: Endo [Header] - } - -type SessionMap = Map.Map Text S.ByteString - --- | 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) - -> Request - -> [ContentType] - -> SessionMap - -> ResourceT IO YesodAppResult - } - -data YesodAppResult - = YARWai W.Response - | YARPlain H.Status [Header] ContentType Content SessionMap - getRequest :: GHandler s m Request getRequest = handlerRequest `liftM` ask @@ -1003,71 +956,3 @@ local :: (HandlerData sub' master' -> HandlerData sub master) -> GHandler sub master a -> GHandler sub' master' a local f (GHandler x) = GHandler $ \r -> x $ f r - --- | The standard @MonadTrans@ class only allows lifting for monad --- transformers. While @GHandler@ and @GWidget@ should allow lifting, their --- types do not express that they actually are transformers. This replacement --- class accounts for this. -class MonadLift base m | m -> base where - lift :: base a -> m a -instance (Monad m, MonadTrans t) => MonadLift m (t m) where - lift = Control.Monad.Trans.Class.lift -instance MonadLift (ResourceT IO) (GHandler sub master) where - lift = GHandler . const - --- Instances for GHandler -instance Functor (GHandler sub master) where - fmap f (GHandler x) = GHandler $ \r -> fmap f (x r) -instance Applicative (GHandler sub master) where - pure = GHandler . const . pure - GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r -instance Monad (GHandler sub master) where - return = pure - GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r -instance MonadIO (GHandler sub master) where - liftIO = GHandler . const . lift -instance MonadBase IO (GHandler sub master) where - liftBase = GHandler . const . lift --- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s --- @fork@ function is incompatible with the underlying @ResourceT@ system. --- Instead, if you must fork a separate thread, you should use --- @resourceForkIO@. --- --- Using fork usually leads to an exception that says --- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed --- after cleanup. Please contact the maintainers.\" -instance MonadBaseControl IO (GHandler sub master) where - data StM (GHandler sub master) a = StH (StM (ResourceT IO) a) - liftBaseWith f = GHandler $ \reader -> - liftBaseWith $ \runInBase -> - f $ liftM StH . runInBase . (\(GHandler r) -> r reader) - restoreM (StH base) = GHandler $ const $ restoreM base - -instance MonadUnsafeIO (GHandler sub master) where - unsafeLiftIO = liftIO -instance MonadThrow (GHandler sub master) where - monadThrow = liftIO . throwIO -instance MonadResource (GHandler sub master) where -#if MIN_VERSION_resourcet(0,4,0) - liftResourceT = lift . liftResourceT -#else - allocate a = lift . allocate a - register = lift . register - release = lift . release - resourceMask = lift . resourceMask -#endif - -instance MonadLogger (GHandler sub master) where -#if MIN_VERSION_monad_logger(0, 3, 0) - monadLoggerLog a b c d = do - hd <- ask - liftIO $ handlerLog hd a b c (toLogStr d) -#else - monadLoggerLog a c d = monadLoggerLogSource a "" c d - monadLoggerLogSource a b c d = do - hd <- ask - liftIO $ handlerLog hd a b c (toLogStr d) -#endif - -instance Exception e => Failure e (GHandler sub master) where - failure = liftIO . throwIO diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index 23ebc15f..1ea65523 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -30,108 +30,24 @@ module Yesod.Internal , tokenKey ) where -import Text.Hamlet (HtmlUrl, Html) +import Text.Hamlet (HtmlUrl) import Text.Blaze.Html (toHtml) -import Text.Julius (JavascriptUrl) -import Data.Monoid (Monoid (..), Last) import Data.List (nub) -import Data.Text (Text) - -import Data.Typeable (Typeable) -import Control.Exception (Exception) - -import qualified Network.HTTP.Types as H import Data.String (IsString) -import qualified Data.Map as Map -import Data.Text.Lazy.Builder (Builder) -import Web.Cookie (SetCookie (..)) -import Data.ByteString (ByteString) -import qualified Network.Wai as W -import Yesod.Content (ChooseRep, ContentType) - --- | 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 Text - | InvalidArgs [Text] - | PermissionDenied Text - | BadMethod H.Method - deriving (Show, Eq, Typeable) - ------ header stuff --- | Headers to be added to a 'Result'. -data Header = - AddCookie SetCookie - | DeleteCookie ByteString ByteString - | Header ByteString ByteString - deriving (Eq, Show) +import Yesod.Core.Types langKey :: IsString a => a langKey = "_LANG" -data Location url = Local url | Remote Text - deriving (Show, Eq) locationToHtmlUrl :: Location url -> HtmlUrl url locationToHtmlUrl (Local url) render = toHtml $ render url [] locationToHtmlUrl (Remote s) _ = toHtml s -newtype UniqueList x = UniqueList ([x] -> [x]) -instance Monoid (UniqueList x) where - mempty = UniqueList id - UniqueList x `mappend` UniqueList y = UniqueList $ x . y runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] toUnique :: x -> UniqueList x toUnique = UniqueList . (:) -data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } - deriving (Show, Eq) -data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } - deriving (Show, Eq) -newtype Title = Title { unTitle :: Html } - -newtype Head url = Head (HtmlUrl url) - deriving Monoid -newtype Body url = Body (HtmlUrl url) - deriving Monoid - tokenKey :: IsString a => a tokenKey = "_TOKEN" - -type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder - -data GWData a = GWData - { gwdBody :: !(Body a) - , gwdTitle :: !(Last Title) - , gwdScripts :: !(UniqueList (Script a)) - , gwdStylesheets :: !(UniqueList (Stylesheet a)) - , gwdCss :: !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type - , gwdJavascript :: !(Maybe (JavascriptUrl a)) - , gwdHead :: !(Head a) - } -instance Monoid (GWData a) where - mempty = GWData mempty mempty mempty mempty mempty mempty mempty - mappend (GWData a1 a2 a3 a4 a5 a6 a7) - (GWData b1 b2 b3 b4 b5 b6 b7) = GWData - (a1 `mappend` b1) - (a2 `mappend` b2) - (a3 `mappend` b3) - (a4 `mappend` b4) - (Map.unionWith mappend a5 b5) - (a6 `mappend` b6) - (a7 `mappend` b7) - -data HandlerContents = - HCContent H.Status ChooseRep - | HCError ErrorResponse - | HCSendFile ContentType FilePath (Maybe W.FilePart) - | HCRedirect H.Status Text - | HCCreated Text - | HCWai W.Response - deriving Typeable - -instance Show HandlerContents where - show _ = "Cannot show a HandlerContents" -instance Exception HandlerContents diff --git a/yesod-core/Yesod/Internal/Cache.hs b/yesod-core/Yesod/Internal/Cache.hs index 4aec0d29..0fc2d2a1 100644 --- a/yesod-core/Yesod/Internal/Cache.hs +++ b/yesod-core/Yesod/Internal/Cache.hs @@ -14,15 +14,9 @@ import qualified Data.IntMap as Map import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL)) import Language.Haskell.TH (appE) import Data.Unique (hashUnique, newUnique) -import GHC.Exts (Any) import Unsafe.Coerce (unsafeCoerce) -import Data.Monoid (Monoid) import Control.Applicative ((<$>)) - -newtype Cache = Cache (Map.IntMap Any) - deriving Monoid - -newtype CacheKey a = CacheKey Int +import Yesod.Core.Types -- | Generate a new 'CacheKey'. Be sure to give a full type signature. mkCacheKey :: Q Exp diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 31c25ba8..f0b9764c 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -5,6 +5,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE FlexibleInstances #-} -- | The basic typeclass for a Yesod application. module Yesod.Internal.Core ( -- * Type classes @@ -95,6 +96,7 @@ import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerP import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) import System.Log.FastLogger.Date (ZonedDate) import System.IO (stdout) +import Yesod.Core.Types yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version @@ -126,18 +128,6 @@ class YesodDispatch sub master where -> W.Application yesodRunner = defaultYesodRunner --- | How to determine the root of the application for constructing URLs. --- --- Note that future versions of Yesod may add new constructors without bumping --- the major version number. As a result, you should /not/ pattern match on --- @Approot@ values. -data Approot master = ApprootRelative -- ^ No application root. - | ApprootStatic Text - | ApprootMaster (master -> Text) - | ApprootRequest (master -> W.Request -> Text) - -type ResolvedApproot = Text - -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. class RenderRoute a => Yesod a where @@ -472,9 +462,6 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req maxLen = maximumContentLength master $ fmap toMasterRoute murl handler = yesodMiddleware handler' -data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text - deriving (Eq, Show, Read) - -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). @@ -664,16 +651,6 @@ $newline never : attrs ) -data ScriptLoadPosition master - = BottomOfBody - | BottomOfHeadBlocking - | BottomOfHeadAsync (BottomOfHeadAsync master) - -type BottomOfHeadAsync master - = [Text] -- ^ urls to load asynchronously - -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion - -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of - left :: Either a b -> Maybe a left (Left x) = Just x left _ = Nothing @@ -874,3 +851,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} + +instance YesodDispatch WaiSubsite master where + yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index a85bfe52..74539a48 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -43,17 +43,7 @@ import Data.Conduit.Binary (sourceFile, sinkFile) import Data.Word (Word64) import Control.Monad.IO.Class (liftIO) import Control.Exception (throwIO) - --- | The parsed request information. -data Request = Request - { reqGetParams :: [(Text, Text)] - , reqCookies :: [(Text, Text)] - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [Text] - -- | A random, session-specific token used to prevent CSRF attacks. - , reqToken :: Maybe Text - } +import Yesod.Core.Types parseWaiRequest :: W.Request -> [(Text, ByteString)] -- ^ session @@ -149,19 +139,6 @@ randomString len = take len . map toChar . randomRs (0, 61) | i < 52 = toEnum $ i + fromEnum 'a' - 26 | otherwise = toEnum $ i + fromEnum '0' - 52 --- | A tuple containing both the POST parameters and submitted files. -type RequestBodyContents = - ( [(Text, Text)] - , [(Text, FileInfo)] - ) - -data FileInfo = FileInfo - { fileName :: Text - , fileContentType :: Text - , fileSource :: Source (ResourceT IO) ByteString - , fileMove :: FilePath -> IO () - } - mkFileInfoLBS :: Text -> Text -> L.ByteString -> FileInfo mkFileInfoLBS name ct lbs = FileInfo name ct (sourceList $ L.toChunks lbs) (\fp -> L.writeFile fp lbs) @@ -170,7 +147,3 @@ mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourc mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) - -data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) - | FileUploadDisk (NWP.BackEnd FilePath) - | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index dac74a41..0dc0de9e 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -8,32 +8,16 @@ module Yesod.Internal.Session , SessionBackend(..) ) where -import Yesod.Internal (Header(..)) import qualified Web.ClientSession as CS -import Data.Int (Int64) import Data.Serialize import Data.Time import Data.ByteString (ByteString) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad (forever, guard) -import Data.Text (Text, pack, unpack) -import Control.Arrow (first) -import Control.Applicative ((<$>)) - -import qualified Data.ByteString.Char8 as S8 +import Data.Text (Text) +import Yesod.Core.Types +import Yesod.Core.Time import qualified Data.IORef as I -import qualified Network.Wai as W - -type BackendSession = [(Text, S8.ByteString)] - -type SaveSession = BackendSession -- ^ The session contents after running the handler - -> IO [Header] - -newtype SessionBackend master = SessionBackend - { sbLoadSession :: master - -> W.Request - -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session - } encodeClientSession :: CS.Key -> CS.IV @@ -58,19 +42,6 @@ decodeClientSession key date rhost encrypted = do guard $ rhost' == rhost return session' -data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)] - deriving (Show, Read) -instance Serialize SessionCookie where - put (SessionCookie a b c) = do - either putTime putByteString a - put b - put (map (first unpack) c) - get = do - a <- getTime - b <- get - c <- map (first pack) <$> get - return $ SessionCookie (Left a) b c - ---------------------------------------------------------------------- @@ -81,13 +52,6 @@ instance Serialize SessionCookie where -- The cached date is updated every 10s, we don't need second -- resolution for session expiration times. -data ClientSessionDateCache = - ClientSessionDateCache { - csdcNow :: !UTCTime - , csdcExpires :: !UTCTime - , csdcExpiresSerialized :: !ByteString - } deriving (Eq, Show) - clientSessionDateCacher :: NominalDiffTime -- ^ Inactive session valitity. -> IO (IO ClientSessionDateCache, IO ()) @@ -104,27 +68,3 @@ clientSessionDateCacher validity = do doUpdate ref = do threadDelay 10000000 -- 10s I.writeIORef ref =<< getUpdated - - ----------------------------------------------------------------------- - - -putTime :: Putter UTCTime -putTime (UTCTime d t) = - let d' = fromInteger $ toModifiedJulianDay d - t' = fromIntegral $ fromEnum (t / diffTimeScale) - in put (d' * posixDayLength_int64 + min posixDayLength_int64 t') - -getTime :: Get UTCTime -getTime = do - val <- get - let (d, t) = val `divMod` posixDayLength_int64 - d' = ModifiedJulianDay $! fromIntegral d - t' = fromIntegral t - d' `seq` t' `seq` return (UTCTime d' t') - -posixDayLength_int64 :: Int64 -posixDayLength_int64 = 86400 - -diffTimeScale :: DiffTime -diffTimeScale = 1e12 diff --git a/yesod-core/Yesod/Message.hs b/yesod-core/Yesod/Message.hs deleted file mode 100644 index 1b76820e..00000000 --- a/yesod-core/Yesod/Message.hs +++ /dev/null @@ -1,6 +0,0 @@ --- | This module has moved to "Text.Shakespeare.I18N" -module Yesod.Message - ( module Text.Shakespeare.I18N - ) where - -import Text.Shakespeare.I18N diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 6642bc60..c6fc55eb 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -52,13 +52,11 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Handler - ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod + ( YesodSubRoute(..), toMasterHandlerMaybe, getYesod , getMessageRender, getUrlRenderParams, MonadLift (..) ) -import Yesod.Message (RenderMessage) -import Yesod.Content (RepHtml (..), toContent) -import Control.Applicative (Applicative (..), (<$>)) -import Control.Monad.IO.Class (MonadIO (liftIO)) +import Text.Shakespeare.I18N (RenderMessage) +import Yesod.Content (toContent) import Yesod.Internal import Control.Monad (liftM) import Data.Text (Text) @@ -66,32 +64,16 @@ import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) -import Control.Monad.Trans.Control (MonadBaseControl (..)) -import Control.Exception (throwIO) import qualified Text.Hamlet as NP -import Data.Text.Lazy.Builder (fromLazyText, Builder) +import Data.Text.Lazy.Builder (fromLazyText) import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL -import Control.Monad.Base (MonadBase (liftBase)) -import Control.Arrow (first) -import Control.Monad.Trans.Resource -import Control.Monad.Logger +import Yesod.Core.Types preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup --- | A generic widget, allowing specification of both the subsite and master --- site datatypes. While this is simply a @WriterT@, we define a newtype for --- better error messages. -newtype GWidget sub master a = GWidget - { unGWidget :: GHandler sub master (a, GWData (Route master)) - } - -instance (a ~ ()) => Monoid (GWidget sub master a) where - mempty = return () - mappend x y = x >> y - addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a addSubWidget sub (GWidget w) = do master <- lift getYesod @@ -103,17 +85,6 @@ addSubWidget sub (GWidget w) = do class ToWidget sub master a where toWidget :: a -> GWidget sub master () -type RY master = Route master -> [(Text, Text)] -> Text - --- | Newtype wrapper allowing injection of arbitrary content into CSS. --- --- Usage: --- --- > toWidget $ CssBuilder "p { color: red }" --- --- Since: 1.1.3 -newtype CssBuilder = CssBuilder { unCssBuilder :: Builder } - instance render ~ RY master => ToWidget sub master (render -> Html) where toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty instance render ~ RY master => ToWidget sub master (render -> Css) where @@ -216,16 +187,6 @@ addScriptRemote = flip addScriptRemoteAttrs [] addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master () addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty --- | Content for a web page. By providing this datatype, we can easily create --- generic site templates, which would have the type signature: --- --- > PageContent url -> HtmlUrl url -data PageContent url = PageContent - { pageTitle :: Html - , pageHead :: HtmlUrl url - , pageBody :: HtmlUrl url - } - whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings @@ -264,58 +225,6 @@ ihamletToRepHtml ih = do tell :: GWData (Route master) -> GWidget sub master () tell w = GWidget $ return ((), w) -instance MonadLift (GHandler sub master) (GWidget sub master) where - lift = GWidget . fmap (\x -> (x, mempty)) - -- | Type-restricted version of @lift@ liftW :: GHandler sub master a -> GWidget sub master a liftW = lift - --- Instances for GWidget -instance Functor (GWidget sub master) where - fmap f (GWidget x) = GWidget (fmap (first f) x) -instance Applicative (GWidget sub master) where - pure a = GWidget $ pure (a, mempty) - GWidget f <*> GWidget v = - GWidget $ k <$> f <*> v - where - k (a, wa) (b, wb) = (a b, wa `mappend` wb) -instance Monad (GWidget sub master) where - return = pure - GWidget x >>= f = GWidget $ do - (a, wa) <- x - (b, wb) <- unGWidget (f a) - return (b, wa `mappend` wb) -instance MonadIO (GWidget sub master) where - liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO -instance MonadBase IO (GWidget sub master) where - liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase -instance MonadBaseControl IO (GWidget sub master) where - data StM (GWidget sub master) a = - StW (StM (GHandler sub master) (a, GWData (Route master))) - liftBaseWith f = GWidget $ liftBaseWith $ \runInBase -> - liftM (\x -> (x, mempty)) - (f $ liftM StW . runInBase . unGWidget) - restoreM (StW base) = GWidget $ restoreM base - -instance MonadUnsafeIO (GWidget sub master) where - unsafeLiftIO = liftIO -instance MonadThrow (GWidget sub master) where - monadThrow = liftIO . throwIO -instance MonadResource (GWidget sub master) where -#if MIN_VERSION_resourcet(0,4,0) - liftResourceT = lift . liftResourceT -#else - allocate a = lift . allocate a - register = lift . register - release = lift . release - resourceMask = lift . resourceMask -#endif - -instance MonadLogger (GWidget sub master) where -#if MIN_VERSION_monad_logger(0, 3, 0) - monadLoggerLog a b c = lift . monadLoggerLog a b c -#else - monadLoggerLog a b = lift . monadLoggerLog a b - monadLoggerLogSource a b c = lift . monadLoggerLogSource a b c -#endif diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index efdc4d89..424e3fea 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -80,9 +80,9 @@ library , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2 - , monad-logger >= 0.2.1 && < 0.4 + , monad-logger >= 0.3 && < 0.4 , conduit >= 0.5 - , resourcet >= 0.3 && < 0.5 + , resourcet >= 0.4 && < 0.5 , lifted-base >= 0.1 , attoparsec-conduit , blaze-html >= 0.5 @@ -95,13 +95,15 @@ library Yesod.Handler Yesod.Request Yesod.Widget - Yesod.Message Yesod.Internal.TestApi other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request + Yesod.Core.Types + Yesod.Core.Time + Yesod.Core.Trans.Class Paths_yesod_core ghc-options: -Wall From 4f1a6b461e61e870c0246a1ad602f4397beb72da Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 11:13:19 +0200 Subject: [PATCH 009/165] BackendSession => SessionMap --- yesod-core/Yesod/Core.hs | 1 - yesod-core/Yesod/Core/Types.hs | 15 +++++++------- yesod-core/Yesod/Internal/Core.hs | 11 +++++----- yesod-core/Yesod/Internal/Request.hs | 9 +++++---- yesod-core/Yesod/Internal/Session.hs | 6 ++---- .../test/YesodCoreTest/InternalRequest.hs | 20 ++++++++++--------- 6 files changed, 30 insertions(+), 32 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 4f3dfa2f..a5a51fb6 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -38,7 +38,6 @@ module Yesod.Core , clientSessionDateCacher , loadClientSession , Header(..) - , BackendSession -- * JS loaders , loadJsYepnope , ScriptLoadPosition (..) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 49c57f13..dbae7210 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -27,6 +27,7 @@ import Data.Conduit (Flush, MonadThrow (..), import Data.IntMap (IntMap) import Data.IORef (IORef) import Data.Map (Map, unionWith) +import qualified Data.Map as Map import Data.Monoid (Any, Endo (..), Last (..), Monoid (..)) import Data.Serialize (Serialize (..), @@ -53,30 +54,30 @@ import Yesod.Core.Trans.Class (MonadLift (..)) import Yesod.Routes.Class (RenderRoute (..)) -- Sessions -type BackendSession = [(Text, ByteString)] +type SessionMap = Map Text ByteString -type SaveSession = BackendSession -- ^ The session contents after running the handler +type SaveSession = SessionMap -- ^ The session contents after running the handler -> IO [Header] newtype SessionBackend master = SessionBackend { sbLoadSession :: master -> W.Request - -> IO (BackendSession, SaveSession) -- ^ Return the session data and a function to save the session + -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session } -data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString [(Text, ByteString)] +data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap deriving (Show, Read) instance Serialize SessionCookie where put (SessionCookie a b c) = do either putTime putByteString a put b - put (map (first T.unpack) c) + put (map (first T.unpack) $ Map.toList c) get = do a <- getTime b <- get c <- map (first T.pack) <$> get - return $ SessionCookie (Left a) b c + return $ SessionCookie (Left a) b (Map.fromList c) data ClientSessionDateCache = ClientSessionDateCache { @@ -174,8 +175,6 @@ data GHState = GHState , ghsHeaders :: Endo [Header] } -type SessionMap = Map Text ByteString - -- | 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. diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index f0b9764c..8fa83280 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -28,7 +28,6 @@ module Yesod.Internal.Core , clientSessionBackend , loadClientSession , clientSessionDateCacher - , BackendSession -- * jsLoader , ScriptLoadPosition (..) , BottomOfHeadAsync @@ -424,7 +423,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req | otherwise = do let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ do - maybe (return ([], dontSaveSession)) (\sb -> sbLoadSession sb master req) msb + maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb rr <- liftIO $ parseWaiRequest req session (isJust msb) maxLen let h = {-# SCC "h" #-} do case murl of @@ -443,14 +442,14 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req redirect url' Unauthorized s' -> permissionDenied s' handler - let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session + let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session let ra = resolveApproot master req let log' = messageLoggerSource master logger yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of (YARPlain _ _ ct _ newSess) -> do - let nsToken = Map.toList $ maybe + let nsToken = maybe newSess (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) (reqToken rr) @@ -745,13 +744,13 @@ loadClientSession :: Yesod master -> S8.ByteString -- ^ session name -> master -> W.Request - -> IO (BackendSession, SaveSession) + -> IO (SessionMap, SaveSession) loadClientSession key getCachedDate sessionName master req = load where load = do date <- getCachedDate return (sess date, save date) - sess date = fromMaybe [] $ do + sess date = fromMaybe Map.empty $ do raw <- lookup "Cookie" $ W.requestHeaders req val <- lookup sessionName $ parseCookies raw let host = "" -- fixme, properly lock sessions to client address diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 74539a48..96805318 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -44,9 +44,10 @@ import Data.Word (Word64) import Control.Monad.IO.Class (liftIO) import Control.Exception (throwIO) import Yesod.Core.Types +import qualified Data.Map as Map parseWaiRequest :: W.Request - -> [(Text, ByteString)] -- ^ session + -> SessionMap -> Bool -> Word64 -- ^ maximum allowed body size -> IO Request @@ -80,7 +81,7 @@ tooLargeResponse = W.responseLBS parseWaiRequest' :: RandomGen g => W.Request - -> [(Text, ByteString)] -- ^ session + -> SessionMap -> Bool -> Word64 -- ^ max body size -> g @@ -95,7 +96,7 @@ parseWaiRequest' env session' useToken maxBodySize gen = acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang - lookupText k = fmap (decodeUtf8With lenientDecode) . lookup k + lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k -- The language preferences are prioritized as follows: langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG @@ -116,7 +117,7 @@ parseWaiRequest' env session' useToken maxBodySize gen = else Just $ maybe (pack $ randomString 10 gen) (decodeUtf8With lenientDecode) - (lookup tokenKey session') + (Map.lookup tokenKey session') addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] = diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 0dc0de9e..5d1c3cb2 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -3,7 +3,6 @@ module Yesod.Internal.Session , decodeClientSession , clientSessionDateCacher , ClientSessionDateCache(..) - , BackendSession , SaveSession , SessionBackend(..) ) where @@ -14,7 +13,6 @@ import Data.Time import Data.ByteString (ByteString) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad (forever, guard) -import Data.Text (Text) import Yesod.Core.Types import Yesod.Core.Time import qualified Data.IORef as I @@ -23,7 +21,7 @@ encodeClientSession :: CS.Key -> CS.IV -> ClientSessionDateCache -- ^ expire time -> ByteString -- ^ remote host - -> [(Text, ByteString)] -- ^ session + -> SessionMap -- ^ session -> ByteString -- ^ cookie value encodeClientSession key iv date rhost session' = CS.encrypt key iv $ encode $ SessionCookie expires rhost session' @@ -33,7 +31,7 @@ decodeClientSession :: CS.Key -> ClientSessionDateCache -- ^ current time -> ByteString -- ^ remote host field -> ByteString -- ^ cookie value - -> Maybe [(Text, ByteString)] + -> Maybe SessionMap decodeClientSession key date rhost encrypted = do decrypted <- CS.decrypt key encrypted SessionCookie (Left expire) rhost' session' <- diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index 5344aa38..65827d39 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -9,6 +9,8 @@ import Network.Wai.Test import Yesod.Internal.TestApi (randomString, parseWaiRequest') import Yesod.Request (Request (..)) import Test.Hspec +import Data.Monoid (mempty) +import Data.Map (singleton) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -38,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest [] False 1000 g + r = parseWaiRequest' defaultRequest mempty False 1000 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] False 1000 g + r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where - r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 1000 g + r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g generateToken :: Bool generateToken = reqToken r /= Nothing where - r = parseWaiRequest' defaultRequest [("_TOKEN", "old")] True 1000 g + r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g langSpecs :: Spec @@ -64,21 +66,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest' defaultRequest - { requestHeaders = [("Accept-Language", "en-US, es")] } [] False 1000 g + { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where - r = parseWaiRequest' defaultRequest [("_LANG", "en")] False 1000 g + r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] - } [] False 1000 g + } mempty False 1000 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where - r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } [] False 1000 g + r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where @@ -87,7 +89,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] - } [("_LANG", "en-SESSION")] False 10000 g + } (singleton "_LANG" "en-SESSION") False 10000 g internalRequestTest :: Spec From 1bd193f64222f0855aed926e4295bbc91e4a66f3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 11:58:29 +0200 Subject: [PATCH 010/165] Initial YesodRequest/YesodRespnse change --- yesod-core/Yesod/Core/Types.hs | 53 +++++++++------ yesod-core/Yesod/Handler.hs | 66 +++++++++--------- yesod-core/Yesod/Internal/Core.hs | 24 ++++--- yesod-core/Yesod/Internal/Request.hs | 67 +++++++++++-------- yesod-core/Yesod/Internal/TestApi.hs | 4 +- yesod-core/Yesod/Request.hs | 3 +- yesod-core/test/YesodCoreTest/CleanPath.hs | 2 +- yesod-core/test/YesodCoreTest/Exceptions.hs | 2 +- .../test/YesodCoreTest/InternalRequest.hs | 30 +++++---- yesod-core/test/YesodCoreTest/JsLoader.hs | 2 +- yesod-core/test/YesodCoreTest/Links.hs | 2 +- yesod-core/test/YesodCoreTest/Media.hs | 2 +- .../test/YesodCoreTest/NoOverloadedStrings.hs | 2 +- .../test/YesodCoreTest/RequestBodySize.hs | 2 +- yesod-core/test/YesodCoreTest/Widget.hs | 2 +- yesod-core/test/YesodCoreTest/YesodTest.hs | 2 +- 16 files changed, 145 insertions(+), 120 deletions(-) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index dbae7210..4a7d077f 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -86,17 +86,37 @@ data ClientSessionDateCache = , csdcExpiresSerialized :: !ByteString } deriving (Eq, Show) --- | The parsed request information. -data Request = Request - { reqGetParams :: [(Text, Text)] - , reqCookies :: [(Text, Text)] - , reqWaiRequest :: W.Request - -- | Languages which the client supports. - , reqLangs :: [Text] - -- | A random, session-specific token used to prevent CSRF attacks. - , reqToken :: Maybe Text +-- | The parsed request information. This type augments the standard WAI +-- 'W.Request' with additional information. +data YesodRequest = YesodRequest + { reqGetParams :: ![(Text, Text)] + -- ^ Same as 'W.queryString', but decoded to @Text@. + , reqCookies :: ![(Text, Text)] + , reqWaiRequest :: !W.Request + , reqLangs :: ![Text] + -- ^ Languages which the client supports. This is an ordered list by preference. + , reqToken :: !(Maybe Text) + -- ^ A random, session-specific token used to prevent CSRF attacks. + , reqSession :: !SessionMap + -- ^ Initial session sent from the client. + -- + -- Since 1.2.0 + , reqAccept :: ![ContentType] + -- ^ An ordered list of the accepted content types. + -- + -- Since 1.2.0 + , reqOnError :: !(ErrorResponse -> YesodApp) + -- ^ How to respond when an error is thrown internally. + -- + -- Since 1.2.0 } +-- | An augmented WAI 'W.Response'. This can either be a standard @Response@, +-- or a higher-level data structure which Yesod will turn into a @Response@. +data YesodResponse + = YRWai W.Response + | YRPlain H.Status [Header] ContentType Content SessionMap + -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(Text, Text)] @@ -150,7 +170,7 @@ type Texts = [Text] newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } data HandlerData sub master = HandlerData - { handlerRequest :: Request + { handlerRequest :: YesodRequest , handlerSub :: sub , handlerMaster :: master , handlerRoute :: Maybe (Route sub) @@ -178,18 +198,7 @@ data GHState = GHState -- | 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) - -> Request - -> [ContentType] - -> SessionMap - -> ResourceT IO YesodAppResult - } - -data YesodAppResult - = YARWai W.Response - | YARPlain H.Status [Header] ContentType Content SessionMap +type YesodApp = YesodRequest -> ResourceT IO YesodResponse -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 90e7f759..c9ee243a 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -106,7 +106,7 @@ module Yesod.Handler , cacheDelete -- * Internal Yesod , runHandler - , YesodApp (..) + , YesodApp , runSubsiteGetter , toMasterHandler , toMasterHandlerDyn @@ -114,7 +114,6 @@ module Yesod.Handler , localNoCurrent , HandlerData , ErrorResponse (..) - , YesodAppResult (..) , handlerToYAR , yarToResponse , headerToPair @@ -146,10 +145,9 @@ import qualified Data.Text.Lazy as TL import qualified Data.Map as Map import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Network.Wai.Parse (parseHttpAccept) import Yesod.Content -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (mapMaybe) import Web.Cookie (SetCookie (..), renderSetCookie) import Control.Arrow ((***)) import qualified Network.Wai.Parse as NWP @@ -255,7 +253,7 @@ toMasterHandlerMaybe :: (Route sub -> Route master) -> GHandler sub' master a toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) -getRequest :: GHandler s m Request +getRequest :: GHandler s m YesodRequest getRequest = handlerRequest `liftM` ask hcError :: ErrorResponse -> GHandler sub master a @@ -415,8 +413,7 @@ runHandler :: HasReps c -> (W.RequestBodyLength -> FileUpload) -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' = - YesodApp $ \eh rr cts initSession -> do +runHandler handler mrender sroute tomr master sub upload log' req = do let toErrorHandler e = case fromException e of Just (HCError x) -> x @@ -429,7 +426,7 @@ runHandler handler mrender sroute tomr master sub upload log' = , ghsHeaders = mempty } let hd = HandlerData - { handlerRequest = rr + { handlerRequest = req , handlerSub = sub , handlerMaster = master , handlerRoute = sroute @@ -447,21 +444,24 @@ runHandler handler mrender sroute tomr master sub upload log' = let headers = ghsHeaders state let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do - yar <- unYesodApp (eh e) safeEh rr cts finalSession + yar <- eh e req + { reqOnError = safeEh + , reqSession = finalSession + } case yar of - YARPlain _ hs ct c sess -> + YRPlain _ hs ct c sess -> let hs' = appEndo headers hs - in return $ YARPlain (getStatus e) hs' ct c sess - YARWai _ -> return yar + in return $ YRPlain (getStatus e) hs' ct c sess + YRWai _ -> return yar let sendFile' ct fp p = - return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession + return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession case contents of HCContent status a -> do (ct, c) <- liftIO $ a cts ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e - Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession + Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession HCError e -> handleError e HCRedirect status loc -> do let disable_caching x = @@ -470,7 +470,7 @@ runHandler handler mrender sroute tomr master sub upload log' = : x hs = (if status /= H.movedPermanently301 then disable_caching else id) $ Header "Location" (encodeUtf8 loc) : appEndo headers [] - return $ YARPlain + return $ YRPlain status hs typePlain emptyContent finalSession HCSendFile ct fp p -> catch @@ -478,13 +478,17 @@ runHandler handler mrender sroute tomr master sub upload log' = (handleError . toErrorHandler) HCCreated loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] - return $ YARPlain + return $ YRPlain H.status201 hs typePlain emptyContent finalSession - HCWai r -> return $ YARWai r + HCWai r -> return $ YRWai r + where + eh = reqOnError req + cts = reqAccept req + initSession = reqSession req evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do @@ -496,14 +500,14 @@ evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do evaluateContent c = return (Right c) safeEh :: ErrorResponse -> YesodApp -safeEh er = YesodApp $ \_ _ _ session -> do +safeEh er req = do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ YARPlain + return $ YRPlain H.status500 [] typePlain (toContent ("Internal Server Error" :: S.ByteString)) - session + (reqSession req) -- | Redirect to the given route. -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0 @@ -806,6 +810,9 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va r <- getUrlRenderParams return $ r url params +instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where + toTextUrl (url, params) = toTextUrl (url, Map.toList params) + localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = local (\hd -> hd { handlerRoute = Nothing }) @@ -832,22 +839,21 @@ handlerToYAR :: (HasReps a, HasReps b) -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a) - -> Request + -> YesodRequest -> Maybe (Route sub) -> SessionMap -> GHandler sub master b - -> ResourceT IO YesodAppResult + -> ResourceT IO YesodResponse handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = - unYesodApp ya eh' rr types sessionMap + ya rr { reqOnError = eh', reqSession = sessionMap } where ya = runHandler h render murl toMasterRoute y s upload log' eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' - types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler -yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response -yarToResponse (YARWai a) _ = a -yarToResponse (YARPlain s hs _ c _) extraHeaders = +yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> W.Response +yarToResponse (YRWai a) _ = a +yarToResponse (YRPlain s hs _ c _) extraHeaders = go c where finalHeaders = extraHeaders ++ map headerToPair hs @@ -862,12 +868,6 @@ yarToResponse (YARPlain s hs _ c _) extraHeaders = go (ContentSource body) = W.ResponseSource s finalHeaders body go (ContentDontEvaluate c') = go c' -httpAccept :: W.Request -> [ContentType] -httpAccept = parseHttpAccept - . fromMaybe mempty - . lookup "Accept" - . W.requestHeaders - -- | Convert Header to a key/value pair. headerToPair :: Header -> (CI ByteString, ByteString) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 8fa83280..50fc4a21 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -44,6 +44,8 @@ module Yesod.Internal.Core import Yesod.Content import Yesod.Handler hiding (lift, getExpires) import Control.Monad.Logger (logErrorS) +import Control.Applicative ((<$>)) +import System.Random (newStdGen) import Yesod.Routes.Class @@ -422,9 +424,10 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req | W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ = return [] + let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" (session, saveSession) <- liftIO $ do maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb - rr <- liftIO $ parseWaiRequest req session (isJust msb) maxLen + rr <- liftIO $ parseWaiRequest req session onError (isJust msb) maxLen <$> newStdGen let h = {-# SCC "h" #-} do case murl of Nothing -> handler @@ -448,7 +451,7 @@ defaultYesodRunner logger handler' master sub murl toMasterRoute msb req yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of - (YARPlain _ _ ct _ newSess) -> do + (YRPlain _ _ ct _ newSess) -> do let nsToken = maybe newSess (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) @@ -800,7 +803,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () - let YesodApp yapp = + let yapp = runHandler handler' (yesodRender master $ resolveApproot master fakeWaiRequest) @@ -810,15 +813,14 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do master (fileUpload master) (messageLoggerSource master $ logger master) - errHandler err = - YesodApp $ \_ _ _ session -> do + errHandler err req = do liftIO $ I.writeIORef ret (Left err) - return $ YARPlain + return $ YRPlain H.status500 [] typePlain (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) - session + (reqSession req) fakeWaiRequest = W.Request { W.requestMethod = "POST" @@ -839,15 +841,17 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do #endif } fakeRequest = - Request + YesodRequest { reqGetParams = [] , reqCookies = [] , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) + , reqOnError = errHandler + , reqAccept = [] + , reqSession = fakeSessionMap } - fakeContentType = [] - _ <- runResourceT $ yapp errHandler fakeRequest fakeContentType fakeSessionMap + _ <- runResourceT $ yapp fakeRequest I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 96805318..c1b9a58d 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} module Yesod.Internal.Request ( parseWaiRequest - , Request (..) , RequestBodyContents , FileInfo , fileName @@ -16,21 +15,18 @@ module Yesod.Internal.Request , tooLargeResponse -- The below are exported for testing. , randomString - , parseWaiRequest' ) where -import Control.Applicative ((<$>)) import Control.Arrow (second) import qualified Network.Wai.Parse as NWP import Yesod.Internal import qualified Network.Wai as W -import System.Random (RandomGen, newStdGen, randomRs) +import System.Random (RandomGen, randomRs) import Web.Cookie (parseCookiesText) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Text (Text, pack) import Network.HTTP.Types (queryToQueryText, Status (Status)) -import Control.Monad (join) import Data.Maybe (fromMaybe, catMaybes) import qualified Data.ByteString.Lazy as L import qualified Data.Set as Set @@ -46,14 +42,6 @@ import Control.Exception (throwIO) import Yesod.Core.Types import qualified Data.Map as Map -parseWaiRequest :: W.Request - -> SessionMap - -> Bool - -> Word64 -- ^ maximum allowed body size - -> IO Request -parseWaiRequest env session' useToken maxBodySize = - parseWaiRequest' env session' useToken maxBodySize <$> newStdGen - -- | Impose a limit on the size of the request body. limitRequestBody :: Word64 -> W.Request -> W.Request limitRequestBody maxLen req = @@ -79,29 +67,40 @@ tooLargeResponse = W.responseLBS [("Content-Type", "text/plain")] "Request body too large to be processed." -parseWaiRequest' :: RandomGen g - => W.Request - -> SessionMap - -> Bool - -> Word64 -- ^ max body size - -> g - -> Request -parseWaiRequest' env session' useToken maxBodySize gen = - Request gets'' cookies' (limitRequestBody maxBodySize env) langs'' token +parseWaiRequest :: RandomGen g + => W.Request + -> SessionMap + -> (ErrorResponse -> YesodApp) + -> Bool + -> Word64 -- ^ max body size + -> g + -> YesodRequest +parseWaiRequest env session onError useToken maxBodySize gen = + YesodRequest + { reqGetParams = gets + , reqCookies = cookies + , reqWaiRequest = limitRequestBody maxBodySize env + , reqLangs = langs'' + , reqToken = token + , reqSession = session + , reqAccept = httpAccept env + , reqOnError = onError + } where - gets' = queryToQueryText $ W.queryString env - gets'' = map (second $ fromMaybe "") gets' + gets = map (second $ fromMaybe "") + $ queryToQueryText + $ W.queryString env reqCookie = lookup "Cookie" $ W.requestHeaders env - cookies' = maybe [] parseCookiesText reqCookie + cookies = maybe [] parseCookiesText reqCookie acceptLang = lookup "Accept-Language" $ W.requestHeaders env langs = map (pack . S8.unpack) $ maybe [] NWP.parseHttpAccept acceptLang lookupText k = fmap (decodeUtf8With lenientDecode) . Map.lookup k -- The language preferences are prioritized as follows: - langs' = catMaybes [ join $ lookup langKey gets' -- Query _LANG - , lookup langKey cookies' -- Cookie _LANG - , lookupText langKey session' -- Session _LANG + langs' = catMaybes [ lookup langKey gets -- Query _LANG + , lookup langKey cookies -- Cookie _LANG + , lookupText langKey session -- Session _LANG ] ++ langs -- Accept-Language(s) -- Github issue #195. We want to add an extra two-letter version of any @@ -117,7 +116,17 @@ parseWaiRequest' env session' useToken maxBodySize gen = else Just $ maybe (pack $ randomString 10 gen) (decodeUtf8With lenientDecode) - (Map.lookup tokenKey session') + (Map.lookup tokenKey session) + +-- | Get the list of accepted content types from the WAI Request\'s Accept +-- header. +-- +-- Since 1.2.0 +httpAccept :: W.Request -> [ContentType] +httpAccept = NWP.parseHttpAccept + . fromMaybe S8.empty + . lookup "Accept" + . W.requestHeaders addTwoLetters :: ([Text] -> [Text], Set.Set Text) -> [Text] -> [Text] addTwoLetters (toAdd, exist) [] = diff --git a/yesod-core/Yesod/Internal/TestApi.hs b/yesod-core/Yesod/Internal/TestApi.hs index ffb1387e..bbb352ef 100644 --- a/yesod-core/Yesod/Internal/TestApi.hs +++ b/yesod-core/Yesod/Internal/TestApi.hs @@ -5,7 +5,7 @@ -- imported by library users. -- module Yesod.Internal.TestApi - ( randomString, parseWaiRequest' + ( randomString, parseWaiRequest ) where -import Yesod.Internal.Request (randomString, parseWaiRequest') +import Yesod.Internal.Request (randomString, parseWaiRequest) diff --git a/yesod-core/Yesod/Request.hs b/yesod-core/Yesod/Request.hs index ee8c25e9..7aec55ca 100644 --- a/yesod-core/Yesod/Request.hs +++ b/yesod-core/Yesod/Request.hs @@ -15,7 +15,7 @@ module Yesod.Request ( -- * Request datatype RequestBodyContents - , Request (..) + , YesodRequest (..) , FileInfo , fileName , fileContentType @@ -41,6 +41,7 @@ import Control.Monad (liftM) import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r import Data.Maybe (listToMaybe) import Data.Text (Text) +import Yesod.Core.Types -- | Get the list of supported languages supplied by the user. -- diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index eb99ebd6..a88246c0 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -5,7 +5,7 @@ module YesodCoreTest.CleanPath (cleanPathTest, Widget) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai import Network.Wai.Test diff --git a/yesod-core/test/YesodCoreTest/Exceptions.hs b/yesod-core/test/YesodCoreTest/Exceptions.hs index f0942350..d8ba52d2 100644 --- a/yesod-core/test/YesodCoreTest/Exceptions.hs +++ b/yesod-core/test/YesodCoreTest/Exceptions.hs @@ -5,7 +5,7 @@ module YesodCoreTest.Exceptions (exceptionsTest, Widget) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai import Network.Wai.Test import Network.HTTP.Types (status301) diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index 65827d39..aea1f9a5 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -6,8 +6,8 @@ import System.Random (StdGen, mkStdGen) import Network.Wai as W import Network.Wai.Test -import Yesod.Internal.TestApi (randomString, parseWaiRequest') -import Yesod.Request (Request (..)) +import Yesod.Internal.TestApi (randomString, parseWaiRequest) +import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) @@ -40,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest mempty False 1000 g + r = parseWaiRequest defaultRequest mempty onError False 1000 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError False 1000 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where - r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g generateToken :: Bool generateToken = reqToken r /= Nothing where - r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g langSpecs :: Spec @@ -65,32 +65,34 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where - r = parseWaiRequest' defaultRequest - { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g + r = parseWaiRequest defaultRequest + { requestHeaders = [("Accept-Language", "en-US, es")] } mempty onError False 1000 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where - r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 g + r = parseWaiRequest defaultRequest (singleton "_LANG" "en") onError False 1000 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where - r = parseWaiRequest' defaultRequest + r = parseWaiRequest defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] - } mempty False 1000 g + } mempty onError False 1000 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where - r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g + r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty onError False 1000 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where - r = parseWaiRequest' defaultRequest + r = parseWaiRequest defaultRequest { requestHeaders = [ ("Accept-Language", "en, es") , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] - } (singleton "_LANG" "en-SESSION") False 10000 g + } (singleton "_LANG" "en-SESSION") onError False 10000 g +onError :: a +onError = error "Yesod.InternalRequest.onError" internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do diff --git a/yesod-core/test/YesodCoreTest/JsLoader.hs b/yesod-core/test/YesodCoreTest/JsLoader.hs index 1849d5b1..dba99a85 100644 --- a/yesod-core/test/YesodCoreTest/JsLoader.hs +++ b/yesod-core/test/YesodCoreTest/JsLoader.hs @@ -8,7 +8,7 @@ import YesodCoreTest.JsLoaderSites.Bottom (B(..)) import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai.Test data H = H diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs index 188cfe97..998c1e5d 100644 --- a/yesod-core/test/YesodCoreTest/Links.hs +++ b/yesod-core/test/YesodCoreTest/Links.hs @@ -5,7 +5,7 @@ module YesodCoreTest.Links (linksTest, Widget) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Text.Hamlet import Network.Wai import Network.Wai.Test diff --git a/yesod-core/test/YesodCoreTest/Media.hs b/yesod-core/test/YesodCoreTest/Media.hs index 09bd1d2f..8f6053ec 100644 --- a/yesod-core/test/YesodCoreTest/Media.hs +++ b/yesod-core/test/YesodCoreTest/Media.hs @@ -5,7 +5,7 @@ module YesodCoreTest.Media (mediaTest, Widget) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai import Network.Wai.Test import Text.Lucius diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index d68707cd..16f93bbc 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -4,7 +4,7 @@ module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai.Test import Data.Monoid (mempty) diff --git a/yesod-core/test/YesodCoreTest/RequestBodySize.hs b/yesod-core/test/YesodCoreTest/RequestBodySize.hs index 7d5fddbe..5b5fc933 100644 --- a/yesod-core/test/YesodCoreTest/RequestBodySize.hs +++ b/yesod-core/test/YesodCoreTest/RequestBodySize.hs @@ -5,7 +5,7 @@ module YesodCoreTest.RequestBodySize (specs, Widget) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai import Network.Wai.Test diff --git a/yesod-core/test/YesodCoreTest/Widget.hs b/yesod-core/test/YesodCoreTest/Widget.hs index 9b14ee35..d69515b1 100644 --- a/yesod-core/test/YesodCoreTest/Widget.hs +++ b/yesod-core/test/YesodCoreTest/Widget.hs @@ -5,7 +5,7 @@ module YesodCoreTest.Widget (widgetTest) where import Test.Hspec -import Yesod.Core hiding (Request) +import Yesod.Core import Text.Julius import Text.Lucius import Text.Hamlet diff --git a/yesod-core/test/YesodCoreTest/YesodTest.hs b/yesod-core/test/YesodCoreTest/YesodTest.hs index 4cea7409..85fc5142 100644 --- a/yesod-core/test/YesodCoreTest/YesodTest.hs +++ b/yesod-core/test/YesodCoreTest/YesodTest.hs @@ -9,7 +9,7 @@ module YesodCoreTest.YesodTest , module Test.Hspec ) where -import Yesod.Core hiding (Request) +import Yesod.Core import Network.Wai.Test import Network.Wai import Test.Hspec From e4683ed001950a126ef2bf709fe34a390b43def3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 12:56:32 +0200 Subject: [PATCH 011/165] .Class and .Run modules --- yesod-core/Yesod/Core/Class.hs | 567 ++++++++++++++++++++++ yesod-core/Yesod/Core/Run.hs | 431 +++++++++++++++++ yesod-core/Yesod/Handler.hs | 246 +--------- yesod-core/Yesod/Internal/Core.hs | 771 ++---------------------------- yesod-core/Yesod/Widget.hs | 4 +- yesod-core/yesod-core.cabal | 2 + 6 files changed, 1041 insertions(+), 980 deletions(-) create mode 100644 yesod-core/Yesod/Core/Class.hs create mode 100644 yesod-core/Yesod/Core/Run.hs diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs new file mode 100644 index 00000000..3a657772 --- /dev/null +++ b/yesod-core/Yesod/Core/Class.hs @@ -0,0 +1,567 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Core.Class where + +import Control.Monad.Logger (logErrorS) +import Yesod.Content +import Yesod.Handler hiding (getExpires, lift) + +import Yesod.Routes.Class + +import Blaze.ByteString.Builder (Builder) +import Blaze.ByteString.Builder.Char.Utf8 (fromText) +import Control.Arrow ((***)) +import Control.Monad (forM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), + LogSource) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.List (foldl') +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Word (Word64) +import Language.Haskell.TH.Syntax (Loc (..)) +import Network.HTTP.Types (encodePath) +import qualified Network.Wai as W +import Network.Wai.Middleware.Gzip (GzipSettings, def) +import Network.Wai.Parse (lbsBackEnd, + tempFileBackEnd) +import System.IO (stdout) +import System.Log.FastLogger (LogStr (..), Logger, + loggerDate, loggerPutStr, + mkLogger) +import System.Log.FastLogger.Date (ZonedDate) +import Text.Blaze (customAttribute, textTag, + toValue, (!)) +import Text.Blaze (preEscapedToMarkup) +import qualified Text.Blaze.Html5 as TBH +import Text.Hamlet +import Text.Julius +import qualified Web.ClientSession as CS +import Web.Cookie (parseCookies) +import Web.Cookie (SetCookie (..)) +import Yesod.Core.Types +import Yesod.Internal +import Yesod.Internal.Session +import Yesod.Widget + +-- | Define settings for a Yesod applications. All methods have intelligent +-- defaults, and therefore no implementation is required. +class RenderRoute a => Yesod a where + -- | An absolute URL to the root of the application. Do not include + -- trailing slash. + -- + -- Default value: 'ApprootRelative'. This is valid under the following + -- conditions: + -- + -- * Your application is served from the root of the domain. + -- + -- * You do not use any features that require absolute URLs, such as Atom + -- feeds and XML sitemaps. + -- + -- If this is not true, you should override with a different + -- implementation. + approot :: Approot a + approot = ApprootRelative + + -- | Output error response pages. + errorHandler :: ErrorResponse -> GHandler sub a ChooseRep + errorHandler = defaultErrorHandler + + -- | Applies some form of layout to the contents of a page. + defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml + defaultLayout w = do + p <- widgetToPageContent w + mmsg <- getMessage + hamletToRepHtml [hamlet| +$newline never +$doctype 5 + + + + #{pageTitle p} + ^{pageHead p} + <body> + $maybe msg <- mmsg + <p .message>#{msg} + ^{pageBody p} +|] + + -- | Override the rendering function for a particular URL. One use case for + -- this is to offload static hosting to a different domain name to avoid + -- sending cookies. + urlRenderOverride :: a -> Route a -> Maybe Builder + urlRenderOverride _ _ = Nothing + + -- | Determine if a request is authorized or not. + -- + -- Return 'Authorized' if the request is authorized, + -- 'Unauthorized' a message if unauthorized. + -- If authentication is required, return 'AuthenticationRequired'. + isAuthorized :: Route a + -> Bool -- ^ is this a write request? + -> GHandler s a AuthResult + isAuthorized _ _ = return Authorized + + -- | Determines whether the current request is a write request. By default, + -- this assumes you are following RESTful principles, and determines this + -- from request method. In particular, all except the following request + -- methods are considered write: GET HEAD OPTIONS TRACE. + -- + -- This function is used to determine if a request is authorized; see + -- 'isAuthorized'. + isWriteRequest :: Route a -> GHandler s a Bool + isWriteRequest _ = do + wai <- waiRequest + return $ W.requestMethod wai `notElem` + ["GET", "HEAD", "OPTIONS", "TRACE"] + + -- | The default route for authentication. + -- + -- Used in particular by 'isAuthorized', but library users can do whatever + -- they want with it. + authRoute :: a -> Maybe (Route a) + authRoute _ = Nothing + + -- | A function used to clean up path segments. It returns 'Right' with a + -- clean path or 'Left' with a new set of pieces the user should be + -- redirected to. The default implementation enforces: + -- + -- * No double slashes + -- + -- * There is no trailing slash. + -- + -- Note that versions of Yesod prior to 0.7 used a different set of rules + -- involing trailing slashes. + cleanPath :: a -> [Text] -> Either [Text] [Text] + cleanPath _ s = + if corrected == s + then Right $ map dropDash s + else Left corrected + where + corrected = filter (not . T.null) s + dropDash t + | T.all (== '-') t = T.drop 1 t + | otherwise = t + + -- | Builds an absolute URL by concatenating the application root with the + -- pieces of a path and a query string, if any. + -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. + joinPath :: a + -> T.Text -- ^ application root + -> [T.Text] -- ^ path pieces + -> [(T.Text, T.Text)] -- ^ query string + -> Builder + joinPath _ ar pieces' qs' = + fromText ar `mappend` encodePath pieces qs + where + pieces = if null pieces' then [""] else map addDash pieces' + qs = map (TE.encodeUtf8 *** go) qs' + go "" = Nothing + go x = Just $ TE.encodeUtf8 x + addDash t + | T.all (== '-') t = T.cons '-' t + | otherwise = t + + -- | This function is used to store some static content to be served as an + -- external file. The most common case of this is stashing CSS and + -- JavaScript content in an external file; the "Yesod.Widget" module uses + -- this feature. + -- + -- The return value is 'Nothing' if no storing was performed; this is the + -- default implementation. A 'Just' 'Left' gives the absolute URL of the + -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is + -- necessary when you are serving the content outside the context of a + -- Yesod application, such as via memcached. + addStaticContent :: Text -- ^ filename extension + -> Text -- ^ mime-type + -> L.ByteString -- ^ content + -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) + addStaticContent _ _ _ = return Nothing + + {- Temporarily disabled until we have a better interface. + -- | Whether or not to tie a session to a specific IP address. Defaults to + -- 'False'. + -- + -- Note: This setting has two known problems: it does not work correctly + -- when behind a reverse proxy (including load balancers), and it may not + -- function correctly if the user is behind a proxy. + sessionIpAddress :: a -> Bool + sessionIpAddress _ = False + -} + + -- | The path value to set for cookies. By default, uses \"\/\", meaning + -- cookies will be sent to every page on the current domain. + cookiePath :: a -> S8.ByteString + cookiePath _ = "/" + + -- | The domain value to set for cookies. By default, the + -- domain is not set, meaning cookies will be sent only to + -- the current domain. + cookieDomain :: a -> Maybe S8.ByteString + cookieDomain _ = Nothing + + -- | Maximum allowed length of the request body, in bytes. + -- + -- Default: 2 megabytes. + maximumContentLength :: a -> Maybe (Route a) -> Word64 + maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes + + -- | Returns a @Logger@ to use for log messages. + -- + -- Default: Sends to stdout and automatically flushes on each write. + getLogger :: a -> IO Logger + getLogger _ = mkLogger True stdout + + -- | Send a message to the @Logger@ provided by @getLogger@. + -- + -- Note: This method is no longer used. Instead, you should override + -- 'messageLoggerSource'. + messageLogger :: a + -> Logger + -> Loc -- ^ position in source code + -> LogLevel + -> LogStr -- ^ message + -> IO () + messageLogger a logger loc = messageLoggerSource a logger loc "" + + -- | Send a message to the @Logger@ provided by @getLogger@. + messageLoggerSource :: a + -> Logger + -> Loc -- ^ position in source code + -> LogSource + -> LogLevel + -> LogStr -- ^ message + -> IO () + messageLoggerSource a logger loc source level msg = + if shouldLog a source level + then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger + else return () + + -- | The logging level in place for this application. Any messages below + -- this level will simply be ignored. + logLevel :: a -> LogLevel + logLevel _ = LevelInfo + + -- | GZIP settings. + gzipSettings :: a -> GzipSettings + gzipSettings _ = def + + -- | Where to Load sripts from. We recommend the default value, + -- 'BottomOfBody'. Alternatively use the built in async yepnope loader: + -- + -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js + -- + -- Or write your own async js loader: see 'loadJsYepnope' + jsLoader :: a -> ScriptLoadPosition a + jsLoader _ = BottomOfBody + + -- | Create a session backend. Returning `Nothing' disables sessions. + -- + -- Default: Uses clientsession with a 2 hour timeout. + makeSessionBackend :: a -> IO (Maybe (SessionBackend a)) + makeSessionBackend _ = fmap Just defaultClientSessionBackend + + -- | How to store uploaded files. + -- + -- Default: When the request body is greater than 50kb, store in a temp + -- file. For chunked request bodies, store in a temp file. Otherwise, store + -- in memory. + fileUpload :: a -> W.RequestBodyLength -> FileUpload + fileUpload _ (W.KnownLength size) + | size <= 50000 = FileUploadMemory lbsBackEnd + fileUpload _ _ = FileUploadDisk tempFileBackEnd + + -- | Should we log the given log source/level combination. + -- + -- Default: Logs everything at or above 'logLevel' + shouldLog :: a -> LogSource -> LogLevel -> Bool + shouldLog a _ level = level >= logLevel a + + -- | A Yesod middleware, which will wrap every handler function. This + -- allows you to run code before and after a normal handler. + -- + -- Default: Adds the response header \"Vary: Accept, Accept-Language\". + -- + -- Since: 1.1.6 + yesodMiddleware :: GHandler sub a res -> GHandler sub a res + yesodMiddleware handler = do + setHeader "Vary" "Accept, Accept-Language" + handler + +-- | Convert a widget to a 'PageContent'. +widgetToPageContent :: (Eq (Route master), Yesod master) + => GWidget sub master () + -> GHandler sub master (PageContent (Route master)) +widgetToPageContent w = do + master <- getYesod + ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w + let title = maybe mempty unTitle mTitle + scripts = runUniqueList scripts' + stylesheets = runUniqueList stylesheets' + + render <- getUrlRenderParams + let renderLoc x = + case x of + Nothing -> Nothing + Just (Left s) -> Just s + Just (Right (u, p)) -> Just $ render u p + css <- forM (Map.toList style) $ \(mmedia, content) -> do + let rendered = toLazyText $ content render + x <- addStaticContent "css" "text/css; charset=utf-8" + $ encodeUtf8 rendered + return (mmedia, + case x of + Nothing -> Left $ preEscapedToMarkup rendered + Just y -> Right $ either id (uncurry render) y) + jsLoc <- + case jscript of + Nothing -> return Nothing + Just s -> do + x <- addStaticContent "js" "text/javascript; charset=utf-8" + $ encodeUtf8 $ renderJavascriptUrl render s + return $ renderLoc x + + -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing + -- the asynchronous loader means your page doesn't have to wait for all the js to load + let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc + regularScriptLoad = [hamlet| +$newline never +$forall s <- scripts + ^{mkScriptTag s} +$maybe j <- jscript + $maybe s <- jsLoc + <script src="#{s}"> + $nothing + <script>^{jelper j} +|] + + headAll = [hamlet| +$newline never +\^{head'} +$forall s <- stylesheets + ^{mkLinkTag s} +$forall s <- css + $maybe t <- right $ snd s + $maybe media <- fst s + <link rel=stylesheet media=#{media} href=#{t}> + $nothing + <link rel=stylesheet href=#{t}> + $maybe content <- left $ snd s + $maybe media <- fst s + <style media=#{media}>#{content} + $nothing + <style>#{content} +$case jsLoader master + $of BottomOfBody + $of BottomOfHeadAsync asyncJsLoader + ^{asyncJsLoader asyncScripts mcomplete} + $of BottomOfHeadBlocking + ^{regularScriptLoad} +|] + let bodyScript = [hamlet| +$newline never +^{body} +^{regularScriptLoad} +|] + + return $ PageContent title headAll (case jsLoader master of + BottomOfBody -> bodyScript + _ -> body) + where + renderLoc' render' (Local url) = render' url [] + renderLoc' _ (Remote s) = s + + addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) + mkScriptTag (Script loc attrs) render' = + foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () + mkLinkTag (Stylesheet loc attrs) render' = + foldl' addAttr TBH.link + ( ("rel", "stylesheet") + : ("href", renderLoc' render' loc) + : attrs + ) + +-- | Helper function for 'defaultErrorHandler'. +applyLayout' :: Yesod master + => Html -- ^ title + -> HtmlUrl (Route master) -- ^ body + -> GHandler sub master ChooseRep +applyLayout' title body = fmap chooseRep $ defaultLayout $ do + setTitle title + toWidget body + +-- | The default error handler for 'errorHandler'. +defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep +defaultErrorHandler NotFound = do + r <- waiRequest + let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r + applyLayout' "Not Found" + [hamlet| +$newline never +<h1>Not Found +<p>#{path'} +|] +defaultErrorHandler (PermissionDenied msg) = + applyLayout' "Permission Denied" + [hamlet| +$newline never +<h1>Permission denied +<p>#{msg} +|] +defaultErrorHandler (InvalidArgs ia) = + applyLayout' "Invalid Arguments" + [hamlet| +$newline never +<h1>Invalid Arguments +<ul> + $forall msg <- ia + <li>#{msg} +|] +defaultErrorHandler (InternalError e) = do + $logErrorS "yesod-core" e + applyLayout' "Internal Server Error" + [hamlet| +$newline never +<h1>Internal Server Error +<pre>#{e} +|] +defaultErrorHandler (BadMethod m) = + applyLayout' "Bad Method" + [hamlet| +$newline never +<h1>Method Not Supported +<p>Method <code>#{S8.unpack m}</code> not supported +|] + +asyncHelper :: (url -> [x] -> Text) + -> [Script (url)] + -> Maybe (JavascriptUrl (url)) + -> Maybe Text + -> (Maybe (HtmlUrl url), [Text]) +asyncHelper render scripts jscript jsLoc = + (mcomplete, scripts'') + where + scripts' = map goScript scripts + scripts'' = + case jsLoc of + Just s -> scripts' ++ [s] + Nothing -> scripts' + goScript (Script (Local url) _) = render url [] + goScript (Script (Remote s) _) = s + mcomplete = + case jsLoc of + Just{} -> Nothing + Nothing -> + case jscript of + Nothing -> Nothing + Just j -> Just $ jelper j + +formatLogMessage :: IO ZonedDate + -> Loc + -> LogSource + -> LogLevel + -> LogStr -- ^ message + -> IO [LogStr] +formatLogMessage getdate loc src level msg = do + now <- getdate + return + [ LB now + , LB " [" + , LS $ + case level of + LevelOther t -> T.unpack t + _ -> drop 5 $ show level + , LS $ + if T.null src + then "" + else "#" ++ T.unpack src + , LB "] " + , msg + , LB " @(" + , LS $ fileLocationToString loc + , LB ")\n" + ] + +defaultClientSessionBackend :: Yesod master => IO (SessionBackend master) +defaultClientSessionBackend = do + key <- CS.getKey CS.defaultKeyFile + let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes + (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout + return $ clientSessionBackend key getCachedDate + +jsToHtml :: Javascript -> Html +jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b + +jelper :: JavascriptUrl url -> HtmlUrl url +jelper = fmap jsToHtml + +left :: Either a b -> Maybe a +left (Left x) = Just x +left _ = Nothing + +right :: Either a b -> Maybe b +right (Right x) = Just x +right _ = Nothing + +clientSessionBackend :: Yesod master + => CS.Key -- ^ The encryption key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> SessionBackend master +clientSessionBackend key getCachedDate = + SessionBackend { + sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req + } + +loadClientSession :: Yesod master + => CS.Key + -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' + -> S8.ByteString -- ^ session name + -> master + -> W.Request + -> IO (SessionMap, SaveSession) +loadClientSession key getCachedDate sessionName master req = load + where + load = do + date <- getCachedDate + return (sess date, save date) + sess date = fromMaybe Map.empty $ do + raw <- lookup "Cookie" $ W.requestHeaders req + val <- lookup sessionName $ parseCookies raw + let host = "" -- fixme, properly lock sessions to client address + decodeClientSession key date host val + save date sess' = do + -- We should never cache the IV! Be careful! + iv <- liftIO CS.randomIV + return [AddCookie def + { setCookieName = sessionName + , setCookieValue = encodeClientSession key iv date host sess' + , setCookiePath = Just (cookiePath master) + , setCookieExpires = Just (csdcExpires date) + , setCookieDomain = cookieDomain master + , setCookieHttpOnly = True + }] + where + host = "" -- fixme, properly lock sessions to client address + +-- taken from file-location package +-- turn the TH Loc loaction information into a human readable string +-- leaving out the loc_end parameter +fileLocationToString :: Loc -> String +fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ + ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) + where + line = show . fst . loc_start + char = show . snd . loc_start + +{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-} diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs new file mode 100644 index 00000000..6ba18081 --- /dev/null +++ b/yesod-core/Yesod/Core/Run.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Yesod.Core.Run where + +import Blaze.ByteString.Builder (fromLazyByteString, toByteString, + toLazyByteString) +import Control.Applicative ((<$>)) +import Control.Exception (SomeException, fromException, + handle) +import Control.Exception.Lifted (catch) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (LogLevel, LogSource) +import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.Resource (ResourceT) +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import qualified Data.IORef as I +import qualified Data.Map as Map +import Data.Maybe (isJust) +import Data.Maybe (fromMaybe) +import Data.Monoid (appEndo, mempty) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Language.Haskell.TH.Syntax (Loc) +import qualified Network.HTTP.Types as H +import Network.Wai +import Prelude hiding (catch) +import System.IO (hPutStrLn, stderr) +import System.Log.FastLogger (LogStr) +import System.Log.FastLogger (Logger) +import System.Random (newStdGen) +import Web.Cookie (renderSetCookie) +import Yesod.Content +import Yesod.Core.Class +import Yesod.Core.Types +import Yesod.Handler +import Yesod.Internal (tokenKey) +import Yesod.Internal.Request (parseWaiRequest, + tooLargeResponse) +import Yesod.Routes.Class (Route, renderRoute) + +handlerToYAR :: (HasReps a, HasReps b) + => master -- ^ master site foundation + -> sub -- ^ sub site foundation + -> (RequestBodyLength -> FileUpload) + -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> (Route sub -> Route master) + -> (Route master -> [(Text, Text)] -> Text) -- route renderer + -> (ErrorResponse -> GHandler sub master a) + -> YesodRequest + -> Maybe (Route sub) + -> SessionMap + -> GHandler sub master b + -> ResourceT IO YesodResponse +handlerToYAR y s upload log' toMasterRoute render errorHandler0 rr murl sessionMap h = + ya rr { reqOnError = eh', reqSession = sessionMap } + where + ya = runHandler h render murl toMasterRoute y s upload log' + eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' + errorHandler' = localNoCurrent . errorHandler0 + +yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response +yarToResponse (YRWai a) _ = a +yarToResponse (YRPlain s hs _ c _) extraHeaders = + go c + where + finalHeaders = extraHeaders ++ map headerToPair hs + finalHeaders' len = ("Content-Length", S8.pack $ show len) + : finalHeaders + + go (ContentBuilder b mlen) = + ResponseBuilder s hs' b + where + hs' = maybe finalHeaders finalHeaders' mlen + go (ContentFile fp p) = ResponseFile s finalHeaders fp p + go (ContentSource body) = ResponseSource s finalHeaders body + go (ContentDontEvaluate c') = go c' + +-- | Convert Header to a key/value pair. +headerToPair :: Header + -> (CI ByteString, ByteString) +headerToPair (AddCookie sc) = + ("Set-Cookie", toByteString $ renderSetCookie $ sc) +headerToPair (DeleteCookie key path) = + ( "Set-Cookie" + , S.concat + [ key + , "=; path=" + , path + , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" + ] + ) +headerToPair (Header key value) = (CI.mk key, value) + +localNoCurrent :: GHandler s m a -> GHandler s m a +localNoCurrent = + local (\hd -> hd { handlerRoute = Nothing }) + +local :: (HandlerData sub' master' -> HandlerData sub master) + -> GHandler sub master a + -> GHandler sub' master' a +local f (GHandler x) = GHandler $ \r -> x $ f r + +-- | Function used internally by Yesod in the process of converting a +-- 'GHandler' into an 'Application'. Should not be needed by users. +runHandler :: HasReps c + => GHandler sub master c + -> (Route master -> [(Text, Text)] -> Text) + -> Maybe (Route sub) + -> (Route sub -> Route master) + -> master + -> sub + -> (RequestBodyLength -> FileUpload) + -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> YesodApp +runHandler handler mrender sroute tomr master sub upload log' req = do + let toErrorHandler e = + case fromException e of + Just (HCError x) -> x + _ -> InternalError $ T.pack $ show e + istate <- liftIO $ I.newIORef GHState + { ghsSession = initSession + , ghsRBC = Nothing + , ghsIdent = 1 + , ghsCache = mempty + , ghsHeaders = mempty + } + let hd = HandlerData + { handlerRequest = req + , handlerSub = sub + , handlerMaster = master + , handlerRoute = sroute + , handlerRender = mrender + , handlerToMaster = tomr + , handlerState = istate + , handlerUpload = upload + , handlerLog = log' + } + contents' <- catch (fmap Right $ unGHandler handler hd) + (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id + $ fromException e) + state <- liftIO $ I.readIORef istate + let finalSession = ghsSession state + let headers = ghsHeaders state + let contents = either id (HCContent H.status200 . chooseRep) contents' + let handleError e = do + yar <- eh e req + { reqOnError = safeEh + , reqSession = finalSession + } + case yar of + YRPlain _ hs ct c sess -> + let hs' = appEndo headers hs + in return $ YRPlain (getStatus e) hs' ct c sess + YRWai _ -> return yar + let sendFile' ct fp p = + return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession + case contents of + HCContent status a -> do + (ct, c) <- liftIO $ a cts + ec' <- liftIO $ evaluateContent c + case ec' of + Left e -> handleError e + Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession + HCError e -> handleError e + HCRedirect status loc -> do + let disable_caching x = + Header "Cache-Control" "no-cache, must-revalidate" + : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" + : x + hs = (if status /= H.movedPermanently301 then disable_caching else id) + $ Header "Location" (encodeUtf8 loc) : appEndo headers [] + return $ YRPlain + status hs typePlain emptyContent + finalSession + HCSendFile ct fp p -> catch + (sendFile' ct fp p) + (handleError . toErrorHandler) + HCCreated loc -> do + let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] + return $ YRPlain + H.status201 + hs + typePlain + emptyContent + finalSession + HCWai r -> return $ YRWai r + where + eh = reqOnError req + cts = reqAccept req + initSession = reqSession req + +safeEh :: ErrorResponse -> YesodApp +safeEh er req = do + liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er + return $ YRPlain + H.status500 + [] + typePlain + (toContent ("Internal Server Error" :: S.ByteString)) + (reqSession req) + +evaluateContent :: Content -> IO (Either ErrorResponse Content) +evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do + let lbs = toLazyByteString b + L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) + where + f :: SomeException -> IO (Either ErrorResponse Content) + f = return . Left . InternalError . T.pack . show +evaluateContent c = return (Right c) + +getStatus :: ErrorResponse -> H.Status +getStatus NotFound = H.status404 +getStatus (InternalError _) = H.status500 +getStatus (InvalidArgs _) = H.status400 +getStatus (PermissionDenied _) = H.status403 +getStatus (BadMethod _) = H.status405 + +-- | Run a 'GHandler' completely outside of Yesod. This +-- function comes with many caveats and you shouldn't use it +-- unless you fully understand what it's doing and how it works. +-- +-- As of now, there's only one reason to use this function at +-- all: in order to run unit tests of functions inside 'GHandler' +-- but that aren't easily testable with a full HTTP request. +-- Even so, it's better to use @wai-test@ or @yesod-test@ instead +-- of using this function. +-- +-- This function will create a fake HTTP request (both @wai@'s +-- 'Request' and @yesod@'s 'Request') and feed it to the +-- @GHandler@. The only useful information the @GHandler@ may +-- get from the request is the session map, which you must supply +-- as argument to @runFakeHandler@. All other fields contain +-- fake information, which means that they can be accessed but +-- won't have any useful information. The response of the +-- @GHandler@ is completely ignored, including changes to the +-- session, cookies or headers. We only return you the +-- @GHandler@'s return value. +runFakeHandler :: (Yesod master, MonadIO m) => + SessionMap + -> (master -> Logger) + -> master + -> GHandler master master a + -> m (Either ErrorResponse a) +runFakeHandler fakeSessionMap logger master handler = liftIO $ do + ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") + let handler' = do liftIO . I.writeIORef ret . Right =<< handler + return () + let yapp = + runHandler + handler' + (yesodRender master $ resolveApproot master fakeWaiRequest) + Nothing + id + master + master + (fileUpload master) + (messageLoggerSource master $ logger master) + errHandler err req = do + liftIO $ I.writeIORef ret (Left err) + return $ YRPlain + H.status500 + [] + typePlain + (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) + (reqSession req) + fakeWaiRequest = + Request + { requestMethod = "POST" + , httpVersion = H.http11 + , rawPathInfo = "/runFakeHandler/pathInfo" + , rawQueryString = "" + , serverName = "runFakeHandler-serverName" + , serverPort = 80 + , requestHeaders = [] + , isSecure = False + , remoteHost = error "runFakeHandler-remoteHost" + , pathInfo = ["runFakeHandler", "pathInfo"] + , queryString = [] + , requestBody = mempty + , vault = mempty + , requestBodyLength = KnownLength 0 + } + fakeRequest = + YesodRequest + { reqGetParams = [] + , reqCookies = [] + , reqWaiRequest = fakeWaiRequest + , reqLangs = [] + , reqToken = Just "NaN" -- not a nonce =) + , reqOnError = errHandler + , reqAccept = [] + , reqSession = fakeSessionMap + } + _ <- runResourceT $ yapp fakeRequest + I.readIORef ret +{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} + +data YesodRunnerEnv sub master = YesodRunnerEnv + { yreLogger :: !Logger + , yreMaster :: !master + , yreSub :: !sub + , yreRoute :: !(Maybe (Route sub)) + , yreToMaster :: !(Route sub -> Route master) + , yreSessionBackend :: !(Maybe (SessionBackend master)) + } + +defaultYesodRunner :: Yesod master + => YesodRunnerEnv sub master + -> GHandler sub master ChooseRep + -> Application +defaultYesodRunner YesodRunnerEnv {..} handler' req + | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse + | otherwise = do + let dontSaveSession _ = return [] + let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" + (session, saveSession) <- liftIO $ do + maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend + rr <- liftIO $ parseWaiRequest req session onError (isJust yreSessionBackend) maxLen <$> newStdGen + let h = {-# SCC "h" #-} do + case yreRoute of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest $ yreToMaster url + ar <- isAuthorized (yreToMaster url) isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> + case authRoute yreMaster of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDestCurrent + redirect url' + Unauthorized s' -> permissionDenied s' + handler + let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session + let ra = resolveApproot yreMaster req + let log' = messageLoggerSource yreMaster yreLogger + yar <- handlerToYAR yreMaster yreSub (fileUpload yreMaster) log' yreToMaster + (yesodRender yreMaster ra) errorHandler rr yreRoute sessionMap h + extraHeaders <- case yar of + (YRPlain _ _ ct _ newSess) -> do + let nsToken = maybe + newSess + (\n -> Map.insert tokenKey (encodeUtf8 n) newSess) + (reqToken rr) + sessionHeaders <- liftIO (saveSession nsToken) + return $ ("Content-Type", ct) : map headerToPair sessionHeaders + _ -> return [] + return $ yarToResponse yar extraHeaders + where + maxLen = maximumContentLength yreMaster $ fmap yreToMaster yreRoute + handler = yesodMiddleware handler' + +yesodRender :: Yesod y + => y + -> ResolvedApproot + -> Route y + -> [(Text, Text)] -- ^ url query string + -> Text +yesodRender y ar url params = + decodeUtf8With lenientDecode $ toByteString $ + fromMaybe + (joinPath y ar ps + $ params ++ params') + (urlRenderOverride y url) + where + (ps, params') = renderRoute url + +toMasterHandlerMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) + +-- | FIXME do we need this? +toMasterHandlerDyn :: (Route sub -> Route master) + -> GHandler sub' master sub + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandlerDyn tm getSub route h = do + sub <- getSub + local (handlerSubData tm (const sub) route) h + +-- | Used internally for promoting subsite handler functions to master site +-- handler functions. Should not be needed by users. +toMasterHandler :: (Route sub -> Route master) + -> (master -> sub) + -> Route sub + -> GHandler sub master a + -> GHandler sub' master a +toMasterHandler tm ts route = local (handlerSubData tm ts route) + +handlerSubData :: (Route sub -> Route master) + -> (master -> sub) + -> Route sub + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubData tm ts = handlerSubDataMaybe tm ts . Just + +handlerSubDataMaybe :: (Route sub -> Route master) + -> (master -> sub) + -> Maybe (Route sub) + -> HandlerData oldSub master + -> HandlerData sub master +handlerSubDataMaybe tm ts route hd = hd + { handlerSub = ts $ handlerMaster hd + , handlerToMaster = tm + , handlerRoute = route + } + +resolveApproot :: Yesod master => master -> Request -> ResolvedApproot +resolveApproot master req = + case approot of + ApprootRelative -> "" + ApprootStatic t -> t + ApprootMaster f -> f master + ApprootRequest f -> f master req diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index c9ee243a..5f260034 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -105,18 +105,10 @@ module Yesod.Handler , cacheInsert , cacheDelete -- * Internal Yesod - , runHandler , YesodApp , runSubsiteGetter - , toMasterHandler - , toMasterHandlerDyn - , toMasterHandlerMaybe - , localNoCurrent , HandlerData , ErrorResponse (..) - , handlerToYAR - , yarToResponse - , headerToPair ) where import Prelude hiding (catch) @@ -131,7 +123,6 @@ import Control.Monad (liftM) import Control.Monad.IO.Class -import System.IO import qualified Network.Wai as W import qualified Network.HTTP.Types as H @@ -144,59 +135,31 @@ import qualified Data.Text.Lazy as TL import qualified Data.Map as Map import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import Yesod.Content import Data.Maybe (mapMaybe) -import Web.Cookie (SetCookie (..), renderSetCookie) +import Web.Cookie (SetCookie (..)) import Control.Arrow ((***)) import qualified Network.Wai.Parse as NWP import Data.Monoid (mappend, mempty, Endo (..)) import qualified Data.ByteString.Char8 as S8 -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString) import Data.Text (Text) import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup -import System.Log.FastLogger -import Control.Monad.Logger - import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey) import qualified Data.IORef as I -import Control.Exception.Lifted (catch) -import Control.Monad.Trans.Resource -import Yesod.Routes.Class -import Language.Haskell.TH.Syntax (Loc) +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Yesod.Routes.Class (Route) import Yesod.Core.Types import Yesod.Core.Trans.Class class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y -handlerSubData :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubData tm ts = handlerSubDataMaybe tm ts . Just - -handlerSubDataMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> HandlerData oldSub master - -> HandlerData sub master -handlerSubDataMaybe tm ts route hd = hd - { handlerSub = ts $ handlerMaster hd - , handlerToMaster = tm - , handlerRoute = route - } - get :: GHandler sub master GHState get = do hd <- ask @@ -215,25 +178,6 @@ modify f = do tell :: Endo [Header] -> GHandler sub master () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } --- | Used internally for promoting subsite handler functions to master site --- handler functions. Should not be needed by users. -toMasterHandler :: (Route sub -> Route master) - -> (master -> sub) - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandler tm ts route = local (handlerSubData tm ts route) - --- | FIXME do we need this? -toMasterHandlerDyn :: (Route sub -> Route master) - -> GHandler sub' master sub - -> Route sub - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerDyn tm getSub route h = do - sub <- getSub - local (handlerSubData tm (const sub) route) h - class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s @@ -246,13 +190,6 @@ instance (anySub ~ anySub' ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where runSubsiteGetter = id -toMasterHandlerMaybe :: (Route sub -> Route master) - -> (master -> sub) - -> Maybe (Route sub) - -> GHandler sub master a - -> GHandler sub' master a -toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route) - getRequest :: GHandler s m YesodRequest getRequest = handlerRequest `liftM` ask @@ -401,114 +338,6 @@ handlerToIO = , handlerState = newStateIORef } --- | 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 - -> (Route master -> [(Text, Text)] -> Text) - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> master - -> sub - -> (W.RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' req = do - let toErrorHandler e = - case fromException e of - Just (HCError x) -> x - _ -> InternalError $ T.pack $ show e - istate <- liftIO $ I.newIORef GHState - { ghsSession = initSession - , ghsRBC = Nothing - , ghsIdent = 1 - , ghsCache = mempty - , ghsHeaders = mempty - } - let hd = HandlerData - { handlerRequest = req - , handlerSub = sub - , handlerMaster = master - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr - , handlerState = istate - , handlerUpload = upload - , handlerLog = log' - } - contents' <- catch (fmap Right $ unGHandler handler hd) - (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id - $ fromException e) - state <- liftIO $ I.readIORef istate - let finalSession = ghsSession state - let headers = ghsHeaders state - let contents = either id (HCContent H.status200 . chooseRep) contents' - let handleError e = do - yar <- eh e req - { reqOnError = safeEh - , reqSession = finalSession - } - case yar of - YRPlain _ hs ct c sess -> - let hs' = appEndo headers hs - in return $ YRPlain (getStatus e) hs' ct c sess - YRWai _ -> return yar - let sendFile' ct fp p = - return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession - case contents of - HCContent status a -> do - (ct, c) <- liftIO $ a cts - ec' <- liftIO $ evaluateContent c - case ec' of - Left e -> handleError e - Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession - HCError e -> handleError e - HCRedirect status loc -> do - let disable_caching x = - Header "Cache-Control" "no-cache, must-revalidate" - : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" - : x - hs = (if status /= H.movedPermanently301 then disable_caching else id) - $ Header "Location" (encodeUtf8 loc) : appEndo headers [] - return $ YRPlain - status hs typePlain emptyContent - finalSession - HCSendFile ct fp p -> catch - (sendFile' ct fp p) - (handleError . toErrorHandler) - HCCreated loc -> do - let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] - return $ YRPlain - H.status201 - hs - typePlain - emptyContent - finalSession - HCWai r -> return $ YRWai r - where - eh = reqOnError req - cts = reqAccept req - initSession = reqSession req - -evaluateContent :: Content -> IO (Either ErrorResponse Content) -evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do - let lbs = toLazyByteString b - L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen) - where - f :: SomeException -> IO (Either ErrorResponse Content) - f = return . Left . InternalError . T.pack . show -evaluateContent c = return (Right c) - -safeEh :: ErrorResponse -> YesodApp -safeEh er req = do - liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ YRPlain - H.status500 - [] - typePlain - (toContent ("Internal Server Error" :: S.ByteString)) - (reqSession req) - -- | Redirect to the given route. -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0 -- This is the appropriate choice for a get-following-post @@ -782,13 +611,6 @@ modSession f x = x { ghsSession = f $ ghsSession x } addHeader :: Header -> GHandler sub master () addHeader = tell . Endo . (:) -getStatus :: ErrorResponse -> H.Status -getStatus NotFound = H.status404 -getStatus (InternalError _) = H.status500 -getStatus (InvalidArgs _) = H.status400 -getStatus (PermissionDenied _) = H.status403 -getStatus (BadMethod _) = H.status405 - -- | Some value which can be turned into a URL for redirects. class RedirectUrl master a where -- | Converts the value to the URL and a list of query-string parameters. @@ -813,10 +635,6 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where toTextUrl (url, params) = toTextUrl (url, Map.toList params) -localNoCurrent :: GHandler s m a -> GHandler s m a -localNoCurrent = - local (\hd -> hd { handlerRoute = Nothing }) - -- | Lookup for session data. lookupSession :: Text -> GHandler s m (Maybe Text) lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS @@ -831,59 +649,6 @@ lookupSessionBS n = do getSession :: GHandler sub master SessionMap getSession = liftM ghsSession get -handlerToYAR :: (HasReps a, HasReps b) - => master -- ^ master site foundation - -> sub -- ^ sub site foundation - -> (W.RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -> (Route sub -> Route master) - -> (Route master -> [(Text, Text)] -> Text) -- route renderer - -> (ErrorResponse -> GHandler sub master a) - -> YesodRequest - -> Maybe (Route sub) - -> SessionMap - -> GHandler sub master b - -> ResourceT IO YesodResponse -handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = - ya rr { reqOnError = eh', reqSession = sessionMap } - where - ya = runHandler h render murl toMasterRoute y s upload log' - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' - errorHandler' = localNoCurrent . errorHandler - -yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> W.Response -yarToResponse (YRWai a) _ = a -yarToResponse (YRPlain s hs _ c _) extraHeaders = - go c - where - finalHeaders = extraHeaders ++ map headerToPair hs - finalHeaders' len = ("Content-Length", S8.pack $ show len) - : finalHeaders - - go (ContentBuilder b mlen) = - W.ResponseBuilder s hs' b - where - hs' = maybe finalHeaders finalHeaders' mlen - go (ContentFile fp p) = W.ResponseFile s finalHeaders fp p - go (ContentSource body) = W.ResponseSource s finalHeaders body - go (ContentDontEvaluate c') = go c' - --- | Convert Header to a key/value pair. -headerToPair :: Header - -> (CI ByteString, ByteString) -headerToPair (AddCookie sc) = - ("Set-Cookie", toByteString $ renderSetCookie $ sc) -headerToPair (DeleteCookie key path) = - ( "Set-Cookie" - , S.concat - [ key - , "=; path=" - , path - , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" - ] - ) -headerToPair (Header key value) = (CI.mk key, value) - -- | Get a unique identifier. newIdent :: GHandler sub master Text newIdent = do @@ -951,8 +716,3 @@ cacheDelete k = modify $ \gs -> ask :: GHandler sub master (HandlerData sub master) ask = GHandler return - -local :: (HandlerData sub' master' -> HandlerData sub master) - -> GHandler sub master a - -> GHandler sub' master' a -local f (GHandler x) = GHandler $ \r -> x $ f r diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 50fc4a21..3c9f73d0 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -43,427 +43,28 @@ module Yesod.Internal.Core import Yesod.Content import Yesod.Handler hiding (lift, getExpires) -import Control.Monad.Logger (logErrorS) -import Control.Applicative ((<$>)) -import System.Random (newStdGen) import Yesod.Routes.Class -import Data.Word (Word64) -import Control.Arrow ((***)) -import Control.Monad (forM) -import Yesod.Widget -import Yesod.Request import qualified Network.Wai as W -import Yesod.Internal import Yesod.Internal.Session import Yesod.Internal.Request -import qualified Web.ClientSession as CS -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import qualified Data.IORef as I -import Data.Monoid import Text.Hamlet -import Text.Julius -import Text.Blaze ((!), customAttribute, textTag, toValue, unsafeLazyByteString) -import qualified Text.Blaze.Html5 as TBH -import Data.Text.Lazy.Builder (toLazyText) -import Data.Text.Lazy.Encoding (encodeUtf8) -import Data.Maybe (fromMaybe, isJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans.Resource (runResourceT) -import Web.Cookie (parseCookies) -import qualified Data.Map as Map -import Network.HTTP.Types (encodePath) -import qualified Data.Text as T +import Text.Blaze (unsafeLazyByteString) import Data.Text (Text) -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TEE -import Blaze.ByteString.Builder (Builder, toByteString) -import Blaze.ByteString.Builder.Char.Utf8 (fromText) -import Data.List (foldl') -import qualified Network.HTTP.Types as H -import Web.Cookie (SetCookie (..)) -import Language.Haskell.TH.Syntax (Loc (..)) -import Text.Blaze (preEscapedToMarkup) import Data.Aeson (Value (Array, String)) import Data.Aeson.Encode (encode) import qualified Data.Vector as Vector -import Network.Wai.Middleware.Gzip (GzipSettings, def) -import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd) import qualified Paths_yesod_core import Data.Version (showVersion) -import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr) -import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther), LogSource) -import System.Log.FastLogger.Date (ZonedDate) -import System.IO (stdout) +import System.Log.FastLogger (Logger) import Yesod.Core.Types +import Yesod.Core.Class +import Yesod.Core.Run yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version --- | This class is automatically instantiated when you use the template haskell --- mkYesod function. You should never need to deal with it directly. -class YesodDispatch sub master where - yesodDispatch - :: Yesod master - => Logger - -> master - -> sub - -> (Route sub -> Route master) - -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler - -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler - -> Text -- ^ request method - -> [Text] -- ^ pieces - -> Maybe (SessionBackend master) - -> W.Application - - yesodRunner :: Yesod master - => Logger - -> GHandler sub master ChooseRep - -> master - -> sub - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> Maybe (SessionBackend master) - -> W.Application - yesodRunner = defaultYesodRunner - --- | Define settings for a Yesod applications. All methods have intelligent --- defaults, and therefore no implementation is required. -class RenderRoute a => Yesod a where - -- | An absolute URL to the root of the application. Do not include - -- trailing slash. - -- - -- Default value: 'ApprootRelative'. This is valid under the following - -- conditions: - -- - -- * Your application is served from the root of the domain. - -- - -- * You do not use any features that require absolute URLs, such as Atom - -- feeds and XML sitemaps. - -- - -- If this is not true, you should override with a different - -- implementation. - approot :: Approot a - approot = ApprootRelative - - -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler sub a ChooseRep - errorHandler = defaultErrorHandler - - -- | Applies some form of layout to the contents of a page. - defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml - defaultLayout w = do - p <- widgetToPageContent w - mmsg <- getMessage - hamletToRepHtml [hamlet| -$newline never -$doctype 5 - -<html> - <head> - <title>#{pageTitle p} - ^{pageHead p} - <body> - $maybe msg <- mmsg - <p .message>#{msg} - ^{pageBody p} -|] - - -- | Override the rendering function for a particular URL. One use case for - -- this is to offload static hosting to a different domain name to avoid - -- sending cookies. - urlRenderOverride :: a -> Route a -> Maybe Builder - urlRenderOverride _ _ = Nothing - - -- | Determine if a request is authorized or not. - -- - -- Return 'Authorized' if the request is authorized, - -- 'Unauthorized' a message if unauthorized. - -- If authentication is required, return 'AuthenticationRequired'. - isAuthorized :: Route a - -> Bool -- ^ is this a write request? - -> GHandler s a AuthResult - isAuthorized _ _ = return Authorized - - -- | Determines whether the current request is a write request. By default, - -- this assumes you are following RESTful principles, and determines this - -- from request method. In particular, all except the following request - -- methods are considered write: GET HEAD OPTIONS TRACE. - -- - -- This function is used to determine if a request is authorized; see - -- 'isAuthorized'. - isWriteRequest :: Route a -> GHandler s a Bool - isWriteRequest _ = do - wai <- waiRequest - return $ W.requestMethod wai `notElem` - ["GET", "HEAD", "OPTIONS", "TRACE"] - - -- | The default route for authentication. - -- - -- Used in particular by 'isAuthorized', but library users can do whatever - -- they want with it. - authRoute :: a -> Maybe (Route a) - authRoute _ = Nothing - - -- | A function used to clean up path segments. It returns 'Right' with a - -- clean path or 'Left' with a new set of pieces the user should be - -- redirected to. The default implementation enforces: - -- - -- * No double slashes - -- - -- * There is no trailing slash. - -- - -- Note that versions of Yesod prior to 0.7 used a different set of rules - -- involing trailing slashes. - cleanPath :: a -> [Text] -> Either [Text] [Text] - cleanPath _ s = - if corrected == s - then Right $ map dropDash s - else Left corrected - where - corrected = filter (not . T.null) s - dropDash t - | T.all (== '-') t = T.drop 1 t - | otherwise = t - - -- | Builds an absolute URL by concatenating the application root with the - -- pieces of a path and a query string, if any. - -- Note that the pieces of the path have been previously cleaned up by 'cleanPath'. - joinPath :: a - -> T.Text -- ^ application root - -> [T.Text] -- ^ path pieces - -> [(T.Text, T.Text)] -- ^ query string - -> Builder - joinPath _ ar pieces' qs' = - fromText ar `mappend` encodePath pieces qs - where - pieces = if null pieces' then [""] else map addDash pieces' - qs = map (TE.encodeUtf8 *** go) qs' - go "" = Nothing - go x = Just $ TE.encodeUtf8 x - addDash t - | T.all (== '-') t = T.cons '-' t - | otherwise = t - - -- | This function is used to store some static content to be served as an - -- external file. The most common case of this is stashing CSS and - -- JavaScript content in an external file; the "Yesod.Widget" module uses - -- this feature. - -- - -- The return value is 'Nothing' if no storing was performed; this is the - -- default implementation. A 'Just' 'Left' gives the absolute URL of the - -- file, whereas a 'Just' 'Right' gives the type-safe URL. The former is - -- necessary when you are serving the content outside the context of a - -- Yesod application, such as via memcached. - addStaticContent :: Text -- ^ filename extension - -> Text -- ^ mime-type - -> L.ByteString -- ^ content - -> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)]))) - addStaticContent _ _ _ = return Nothing - - {- Temporarily disabled until we have a better interface. - -- | Whether or not to tie a session to a specific IP address. Defaults to - -- 'False'. - -- - -- Note: This setting has two known problems: it does not work correctly - -- when behind a reverse proxy (including load balancers), and it may not - -- function correctly if the user is behind a proxy. - sessionIpAddress :: a -> Bool - sessionIpAddress _ = False - -} - - -- | The path value to set for cookies. By default, uses \"\/\", meaning - -- cookies will be sent to every page on the current domain. - cookiePath :: a -> S8.ByteString - cookiePath _ = "/" - - -- | The domain value to set for cookies. By default, the - -- domain is not set, meaning cookies will be sent only to - -- the current domain. - cookieDomain :: a -> Maybe S8.ByteString - cookieDomain _ = Nothing - - -- | Maximum allowed length of the request body, in bytes. - -- - -- Default: 2 megabytes. - maximumContentLength :: a -> Maybe (Route a) -> Word64 - maximumContentLength _ _ = 2 * 1024 * 1024 -- 2 megabytes - - -- | Returns a @Logger@ to use for log messages. - -- - -- Default: Sends to stdout and automatically flushes on each write. - getLogger :: a -> IO Logger - getLogger _ = mkLogger True stdout - - -- | Send a message to the @Logger@ provided by @getLogger@. - -- - -- Note: This method is no longer used. Instead, you should override - -- 'messageLoggerSource'. - messageLogger :: a - -> Logger - -> Loc -- ^ position in source code - -> LogLevel - -> LogStr -- ^ message - -> IO () - messageLogger a logger loc = messageLoggerSource a logger loc "" - - -- | Send a message to the @Logger@ provided by @getLogger@. - messageLoggerSource :: a - -> Logger - -> Loc -- ^ position in source code - -> LogSource - -> LogLevel - -> LogStr -- ^ message - -> IO () - messageLoggerSource a logger loc source level msg = - if shouldLog a source level - then formatLogMessage (loggerDate logger) loc source level msg >>= loggerPutStr logger - else return () - - -- | The logging level in place for this application. Any messages below - -- this level will simply be ignored. - logLevel :: a -> LogLevel - logLevel _ = LevelInfo - - -- | GZIP settings. - gzipSettings :: a -> GzipSettings - gzipSettings _ = def - - -- | Where to Load sripts from. We recommend the default value, - -- 'BottomOfBody'. Alternatively use the built in async yepnope loader: - -- - -- > BottomOfHeadAsync $ loadJsYepnope $ Right $ StaticR js_modernizr_js - -- - -- Or write your own async js loader: see 'loadJsYepnope' - jsLoader :: a -> ScriptLoadPosition a - jsLoader _ = BottomOfBody - - -- | Create a session backend. Returning `Nothing' disables sessions. - -- - -- Default: Uses clientsession with a 2 hour timeout. - makeSessionBackend :: a -> IO (Maybe (SessionBackend a)) - makeSessionBackend _ = fmap Just defaultClientSessionBackend - - -- | How to store uploaded files. - -- - -- Default: When the request body is greater than 50kb, store in a temp - -- file. For chunked request bodies, store in a temp file. Otherwise, store - -- in memory. - fileUpload :: a -> W.RequestBodyLength -> FileUpload - fileUpload _ (W.KnownLength size) - | size <= 50000 = FileUploadMemory lbsBackEnd - fileUpload _ _ = FileUploadDisk tempFileBackEnd - - -- | Should we log the given log source/level combination. - -- - -- Default: Logs everything at or above 'logLevel' - shouldLog :: a -> LogSource -> LogLevel -> Bool - shouldLog a _ level = level >= logLevel a - - -- | A Yesod middleware, which will wrap every handler function. This - -- allows you to run code before and after a normal handler. - -- - -- Default: Adds the response header \"Vary: Accept, Accept-Language\". - -- - -- Since: 1.1.6 - yesodMiddleware :: GHandler sub a res -> GHandler sub a res - yesodMiddleware handler = do - setHeader "Vary" "Accept, Accept-Language" - handler - -{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-} - -formatLogMessage :: IO ZonedDate - -> Loc - -> LogSource - -> LogLevel - -> LogStr -- ^ message - -> IO [LogStr] -formatLogMessage getdate loc src level msg = do - now <- getdate - return - [ LB now - , LB " [" - , LS $ - case level of - LevelOther t -> T.unpack t - _ -> drop 5 $ show level - , LS $ - if T.null src - then "" - else "#" ++ T.unpack src - , LB "] " - , msg - , LB " @(" - , LS $ fileLocationToString loc - , LB ")\n" - ] - --- taken from file-location package --- turn the TH Loc loaction information into a human readable string --- leaving out the loc_end parameter -fileLocationToString :: Loc -> String -fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ - ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc) - where - line = show . fst . loc_start - char = show . snd . loc_start - -defaultYesodRunner :: Yesod master - => Logger - -> GHandler sub master ChooseRep - -> master - -> sub - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> Maybe (SessionBackend master) - -> W.Application -defaultYesodRunner logger handler' master sub murl toMasterRoute msb req - | W.KnownLength len <- W.requestBodyLength req, maxLen < len = return tooLargeResponse - | otherwise = do - let dontSaveSession _ = return [] - let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" - (session, saveSession) <- liftIO $ do - maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb master req) msb - rr <- liftIO $ parseWaiRequest req session onError (isJust msb) maxLen <$> newStdGen - let h = {-# SCC "h" #-} do - case murl of - Nothing -> handler - Just url -> do - isWrite <- isWriteRequest $ toMasterRoute url - ar <- isAuthorized (toMasterRoute url) isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute master of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDestCurrent - redirect url' - Unauthorized s' -> permissionDenied s' - handler - let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session - let ra = resolveApproot master req - let log' = messageLoggerSource master logger - yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute - (yesodRender master ra) errorHandler rr murl sessionMap h - extraHeaders <- case yar of - (YRPlain _ _ ct _ newSess) -> do - let nsToken = maybe - newSess - (\n -> Map.insert tokenKey (TE.encodeUtf8 n) newSess) - (reqToken rr) - sessionHeaders <- liftIO (saveSession nsToken) - return $ ("Content-Type", ct) : map headerToPair sessionHeaders - _ -> return [] - return $ yarToResponse yar extraHeaders - where - maxLen = maximumContentLength master $ fmap toMasterRoute murl - handler = yesodMiddleware handler' - -- | A type-safe, concise method of creating breadcrumbs for pages. For each -- resource, you declare the title of the page and the parent resource (if -- present). @@ -491,57 +92,6 @@ breadcrumbs = do (title, next) <- breadcrumb this go ((this, title) : back) next -applyLayout' :: Yesod master - => Html -- ^ title - -> HtmlUrl (Route master) -- ^ body - -> GHandler sub master ChooseRep -applyLayout' title body = fmap chooseRep $ defaultLayout $ do - setTitle title - toWidget body - --- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r - applyLayout' "Not Found" - [hamlet| -$newline never -<h1>Not Found -<p>#{path'} -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" - [hamlet| -$newline never -<h1>Permission denied -<p>#{msg} -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" - [hamlet| -$newline never -<h1>Invalid Arguments -<ul> - $forall msg <- ia - <li>#{msg} -|] -defaultErrorHandler (InternalError e) = do - $logErrorS "yesod-core" e - applyLayout' "Internal Server Error" - [hamlet| -$newline never -<h1>Internal Server Error -<pre>#{e} -|] -defaultErrorHandler (BadMethod m) = - applyLayout' "Bad Method" - [hamlet| -$newline never -<h1>Method Not Supported -<p>Method <code>#{S8.unpack m}</code> not supported -|] - -- | Return the same URL if the user is authorized to see it. -- -- Built on top of 'isAuthorized'. This is useful for building page that only @@ -554,113 +104,6 @@ maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing -jsToHtml :: Javascript -> Html -jsToHtml (Javascript b) = preEscapedToMarkup $ toLazyText b - -jelper :: JavascriptUrl url -> HtmlUrl url -jelper = fmap jsToHtml - --- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route master), Yesod master) - => GWidget sub master () - -> GHandler sub master (PageContent (Route master)) -widgetToPageContent w = do - master <- getYesod - ((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w - let title = maybe mempty unTitle mTitle - scripts = runUniqueList scripts' - stylesheets = runUniqueList stylesheets' - - render <- getUrlRenderParams - let renderLoc x = - case x of - Nothing -> Nothing - Just (Left s) -> Just s - Just (Right (u, p)) -> Just $ render u p - css <- forM (Map.toList style) $ \(mmedia, content) -> do - let rendered = toLazyText $ content render - x <- addStaticContent "css" "text/css; charset=utf-8" - $ encodeUtf8 rendered - return (mmedia, - case x of - Nothing -> Left $ preEscapedToMarkup rendered - Just y -> Right $ either id (uncurry render) y) - jsLoc <- - case jscript of - Nothing -> return Nothing - Just s -> do - x <- addStaticContent "js" "text/javascript; charset=utf-8" - $ encodeUtf8 $ renderJavascriptUrl render s - return $ renderLoc x - - -- modernizr should be at the end of the <head> http://www.modernizr.com/docs/#installing - -- the asynchronous loader means your page doesn't have to wait for all the js to load - let (mcomplete, asyncScripts) = asyncHelper render scripts jscript jsLoc - regularScriptLoad = [hamlet| -$newline never -$forall s <- scripts - ^{mkScriptTag s} -$maybe j <- jscript - $maybe s <- jsLoc - <script src="#{s}"> - $nothing - <script>^{jelper j} -|] - - headAll = [hamlet| -$newline never -\^{head'} -$forall s <- stylesheets - ^{mkLinkTag s} -$forall s <- css - $maybe t <- right $ snd s - $maybe media <- fst s - <link rel=stylesheet media=#{media} href=#{t}> - $nothing - <link rel=stylesheet href=#{t}> - $maybe content <- left $ snd s - $maybe media <- fst s - <style media=#{media}>#{content} - $nothing - <style>#{content} -$case jsLoader master - $of BottomOfBody - $of BottomOfHeadAsync asyncJsLoader - ^{asyncJsLoader asyncScripts mcomplete} - $of BottomOfHeadBlocking - ^{regularScriptLoad} -|] - let bodyScript = [hamlet| -$newline never -^{body} -^{regularScriptLoad} -|] - - return $ PageContent title headAll (case jsLoader master of - BottomOfBody -> bodyScript - _ -> body) - where - renderLoc' render' (Local url) = render' url [] - renderLoc' _ (Remote s) = s - - addAttr x (y, z) = x ! customAttribute (textTag y) (toValue z) - mkScriptTag (Script loc attrs) render' = - foldl' addAttr TBH.script (("src", renderLoc' render' loc) : attrs) $ return () - mkLinkTag (Stylesheet loc attrs) render' = - foldl' addAttr TBH.link - ( ("rel", "stylesheet") - : ("href", renderLoc' render' loc) - : attrs - ) - -left :: Either a b -> Maybe a -left (Left x) = Just x -left _ = Nothing - -right :: Either a b -> Maybe b -right (Right x) = Just x -right _ = Nothing - jsonArray :: [Text] -> Html jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String @@ -679,181 +122,39 @@ $newline never <script>yepnope({load:#{jsonArray scripts}}); |] -asyncHelper :: (url -> [x] -> Text) - -> [Script (url)] - -> Maybe (JavascriptUrl (url)) - -> Maybe Text - -> (Maybe (HtmlUrl url), [Text]) -asyncHelper render scripts jscript jsLoc = - (mcomplete, scripts'') - where - scripts' = map goScript scripts - scripts'' = - case jsLoc of - Just s -> scripts' ++ [s] - Nothing -> scripts' - goScript (Script (Local url) _) = render url [] - goScript (Script (Remote s) _) = s - mcomplete = - case jsLoc of - Just{} -> Nothing - Nothing -> - case jscript of - Nothing -> Nothing - Just j -> Just $ jelper j +-- | This class is automatically instantiated when you use the template haskell +-- mkYesod function. You should never need to deal with it directly. +class YesodDispatch sub master where + yesodDispatch + :: Yesod master + => Logger + -> master + -> sub + -> (Route sub -> Route master) + -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler + -> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler + -> Text -- ^ request method + -> [Text] -- ^ pieces + -> Maybe (SessionBackend master) + -> W.Application -yesodRender :: Yesod y - => y - -> ResolvedApproot - -> Route y - -> [(Text, Text)] -- ^ url query string - -> Text -yesodRender y ar url params = - TE.decodeUtf8 $ toByteString $ - fromMaybe - (joinPath y ar ps - $ params ++ params') - (urlRenderOverride y url) - where - (ps, params') = renderRoute url - -resolveApproot :: Yesod master => master -> W.Request -> ResolvedApproot -resolveApproot master req = - case approot of - ApprootRelative -> "" - ApprootStatic t -> t - ApprootMaster f -> f master - ApprootRequest f -> f master req - -defaultClientSessionBackend :: Yesod master => IO (SessionBackend master) -defaultClientSessionBackend = do - key <- CS.getKey CS.defaultKeyFile - let timeout = fromIntegral (120 * 60 :: Int) -- 120 minutes - (getCachedDate, _closeDateCacher) <- clientSessionDateCacher timeout - return $ clientSessionBackend key getCachedDate - -clientSessionBackend :: Yesod master - => CS.Key -- ^ The encryption key - -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' - -> SessionBackend master -clientSessionBackend key getCachedDate = - SessionBackend { - sbLoadSession = \master req -> loadClientSession key getCachedDate "_SESSION" master req - } - -loadClientSession :: Yesod master - => CS.Key - -> IO ClientSessionDateCache -- ^ See 'clientSessionDateCacher' - -> S8.ByteString -- ^ session name - -> master - -> W.Request - -> IO (SessionMap, SaveSession) -loadClientSession key getCachedDate sessionName master req = load - where - load = do - date <- getCachedDate - return (sess date, save date) - sess date = fromMaybe Map.empty $ do - raw <- lookup "Cookie" $ W.requestHeaders req - val <- lookup sessionName $ parseCookies raw - let host = "" -- fixme, properly lock sessions to client address - decodeClientSession key date host val - save date sess' = do - -- We should never cache the IV! Be careful! - iv <- liftIO CS.randomIV - return [AddCookie def - { setCookieName = sessionName - , setCookieValue = encodeClientSession key iv date host sess' - , setCookiePath = Just (cookiePath master) - , setCookieExpires = Just (csdcExpires date) - , setCookieDomain = cookieDomain master - , setCookieHttpOnly = True - }] - where - host = "" -- fixme, properly lock sessions to client address - - --- | Run a 'GHandler' completely outside of Yesod. This --- function comes with many caveats and you shouldn't use it --- unless you fully understand what it's doing and how it works. --- --- As of now, there's only one reason to use this function at --- all: in order to run unit tests of functions inside 'GHandler' --- but that aren't easily testable with a full HTTP request. --- Even so, it's better to use @wai-test@ or @yesod-test@ instead --- of using this function. --- --- This function will create a fake HTTP request (both @wai@'s --- 'W.Request' and @yesod@'s 'Request') and feed it to the --- @GHandler@. The only useful information the @GHandler@ may --- get from the request is the session map, which you must supply --- as argument to @runFakeHandler@. All other fields contain --- fake information, which means that they can be accessed but --- won't have any useful information. The response of the --- @GHandler@ is completely ignored, including changes to the --- session, cookies or headers. We only return you the --- @GHandler@'s return value. -runFakeHandler :: (Yesod master, MonadIO m) => - SessionMap - -> (master -> Logger) - -> master - -> GHandler master master a - -> m (Either ErrorResponse a) -runFakeHandler fakeSessionMap logger master handler = liftIO $ do - ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") - let handler' = do liftIO . I.writeIORef ret . Right =<< handler - return () - let yapp = - runHandler - handler' - (yesodRender master $ resolveApproot master fakeWaiRequest) - Nothing - id - master - master - (fileUpload master) - (messageLoggerSource master $ logger master) - errHandler err req = do - liftIO $ I.writeIORef ret (Left err) - return $ YRPlain - H.status500 - [] - typePlain - (toContent ("runFakeHandler: errHandler" :: S8.ByteString)) - (reqSession req) - fakeWaiRequest = - W.Request - { W.requestMethod = "POST" - , W.httpVersion = H.http11 - , W.rawPathInfo = "/runFakeHandler/pathInfo" - , W.rawQueryString = "" - , W.serverName = "runFakeHandler-serverName" - , W.serverPort = 80 - , W.requestHeaders = [] - , W.isSecure = False - , W.remoteHost = error "runFakeHandler-remoteHost" - , W.pathInfo = ["runFakeHandler", "pathInfo"] - , W.queryString = [] - , W.requestBody = mempty - , W.vault = mempty -#if MIN_VERSION_wai(1, 4, 0) - , W.requestBodyLength = W.KnownLength 0 -#endif - } - fakeRequest = - YesodRequest - { reqGetParams = [] - , reqCookies = [] - , reqWaiRequest = fakeWaiRequest - , reqLangs = [] - , reqToken = Just "NaN" -- not a nonce =) - , reqOnError = errHandler - , reqAccept = [] - , reqSession = fakeSessionMap - } - _ <- runResourceT $ yapp fakeRequest - I.readIORef ret -{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} + yesodRunner :: Yesod master + => Logger + -> GHandler sub master ChooseRep + -> master + -> sub + -> Maybe (Route sub) + -> (Route sub -> Route master) + -> Maybe (SessionBackend master) + -> W.Application + yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv + { yreLogger = logger + , yreMaster = master + , yreSub = sub + , yreRoute = murl + , yreToMaster = tomaster + , yreSessionBackend = msb + } handler instance YesodDispatch WaiSubsite master where yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index c6fc55eb..353f4915 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -52,7 +52,7 @@ import Text.Cassius import Text.Julius import Yesod.Routes.Class import Yesod.Handler - ( YesodSubRoute(..), toMasterHandlerMaybe, getYesod + ( YesodSubRoute(..), getYesod , getMessageRender, getUrlRenderParams, MonadLift (..) ) import Text.Shakespeare.I18N (RenderMessage) @@ -78,7 +78,7 @@ addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWi addSubWidget sub (GWidget w) = do master <- lift getYesod let sr = fromSubRoute sub master - (a, w') <- lift $ toMasterHandlerMaybe sr (const sub) Nothing w + (a, w') <- lift $ error "FIXME Yesod.Widget.toMasterHandlerMaybe" sr (const sub) Nothing w tell w' return a diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 424e3fea..40cddf9e 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -104,6 +104,8 @@ library Yesod.Core.Types Yesod.Core.Time Yesod.Core.Trans.Class + Yesod.Core.Run + Yesod.Core.Class Paths_yesod_core ghc-options: -Wall From 4ece5fafd94963984da24d3d5ba1a08b16367393 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 13:24:23 +0200 Subject: [PATCH 012/165] Removed handlerToYAR --- yesod-core/Yesod/Core/Run.hs | 103 ++++++++---------- yesod-core/Yesod/Internal/Request.hs | 4 +- .../test/YesodCoreTest/InternalRequest.hs | 5 +- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 55 insertions(+), 59 deletions(-) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index 6ba18081..60308d43 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -14,7 +14,6 @@ import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger (LogLevel, LogSource) import Control.Monad.Trans.Resource (runResourceT) -import Control.Monad.Trans.Resource (ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 @@ -49,26 +48,6 @@ import Yesod.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) -handlerToYAR :: (HasReps a, HasReps b) - => master -- ^ master site foundation - -> sub -- ^ sub site foundation - -> (RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - -> (Route sub -> Route master) - -> (Route master -> [(Text, Text)] -> Text) -- route renderer - -> (ErrorResponse -> GHandler sub master a) - -> YesodRequest - -> Maybe (Route sub) - -> SessionMap - -> GHandler sub master b - -> ResourceT IO YesodResponse -handlerToYAR y s upload log' toMasterRoute render errorHandler0 rr murl sessionMap h = - ya rr { reqOnError = eh', reqSession = sessionMap } - where - ya = runHandler h render murl toMasterRoute y s upload log' - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' - errorHandler' = localNoCurrent . errorHandler0 - yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response yarToResponse (YRWai a) _ = a yarToResponse (YRPlain s hs _ c _) extraHeaders = @@ -111,19 +90,23 @@ local :: (HandlerData sub' master' -> HandlerData sub master) -> GHandler sub' master' a local f (GHandler x) = GHandler $ \r -> x $ f r +data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData + { rheRender :: !(Route master -> [(Text, Text)] -> Text) + , rheRoute :: !(Maybe (Route sub)) + , rheToMaster :: !(Route sub -> Route master) + , rheMaster :: !master + , rheSub :: !sub + , rheUpload :: !(RequestBodyLength -> FileUpload) + , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + } + -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'Application'. Should not be needed by users. runHandler :: HasReps c - => GHandler sub master c - -> (Route master -> [(Text, Text)] -> Text) - -> Maybe (Route sub) - -> (Route sub -> Route master) - -> master - -> sub - -> (RequestBodyLength -> FileUpload) - -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + => RunHandlerEnv sub master + -> GHandler sub master c -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' req = do +runHandler RunHandlerEnv {..} handler yreq = do let toErrorHandler e = case fromException e of Just (HCError x) -> x @@ -136,15 +119,15 @@ runHandler handler mrender sroute tomr master sub upload log' req = do , ghsHeaders = mempty } let hd = HandlerData - { handlerRequest = req - , handlerSub = sub - , handlerMaster = master - , handlerRoute = sroute - , handlerRender = mrender - , handlerToMaster = tomr + { handlerRequest = yreq + , handlerSub = rheSub + , handlerMaster = rheMaster + , handlerRoute = rheRoute + , handlerRender = rheRender + , handlerToMaster = rheToMaster , handlerState = istate - , handlerUpload = upload - , handlerLog = log' + , handlerUpload = rheUpload + , handlerLog = rheLog } contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id @@ -154,7 +137,7 @@ runHandler handler mrender sroute tomr master sub upload log' req = do let headers = ghsHeaders state let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do - yar <- eh e req + yar <- eh e yreq { reqOnError = safeEh , reqSession = finalSession } @@ -196,9 +179,9 @@ runHandler handler mrender sroute tomr master sub upload log' req = do finalSession HCWai r -> return $ YRWai r where - eh = reqOnError req - cts = reqAccept req - initSession = reqSession req + eh = reqOnError yreq + cts = reqAccept yreq + initSession = reqSession yreq safeEh :: ErrorResponse -> YesodApp safeEh er req = do @@ -256,16 +239,17 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") let handler' = do liftIO . I.writeIORef ret . Right =<< handler return () - let yapp = - runHandler - handler' - (yesodRender master $ resolveApproot master fakeWaiRequest) - Nothing - id - master - master - (fileUpload master) - (messageLoggerSource master $ logger master) + let yapp = runHandler + RunHandlerEnv + { rheRender = yesodRender master $ resolveApproot master fakeWaiRequest + , rheRoute = Nothing + , rheToMaster = id + , rheMaster = master + , rheSub = master + , rheUpload = fileUpload master + , rheLog = messageLoggerSource master $ logger master + } + handler' errHandler err req = do liftIO $ I.writeIORef ret (Left err) return $ YRPlain @@ -344,11 +328,20 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req redirect url' Unauthorized s' -> permissionDenied s' handler - let sessionMap = Map.filterWithKey (\k _v -> k /= tokenKey) $ session let ra = resolveApproot yreMaster req let log' = messageLoggerSource yreMaster yreLogger - yar <- handlerToYAR yreMaster yreSub (fileUpload yreMaster) log' yreToMaster - (yesodRender yreMaster ra) errorHandler rr yreRoute sessionMap h + rhe = RunHandlerEnv + { rheRender = yesodRender yreMaster ra + , rheRoute = yreRoute + , rheToMaster = yreToMaster + , rheMaster = yreMaster + , rheSub = yreSub + , rheUpload = fileUpload yreMaster + , rheLog = log' + } + yar <- runHandler rhe h rr + { reqOnError = runHandler rhe . localNoCurrent . errorHandler + } extraHeaders <- case yar of (YRPlain _ _ ct _ newSess) -> do let nsToken = maybe diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index c1b9a58d..21dc06da 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -82,7 +82,9 @@ parseWaiRequest env session onError useToken maxBodySize gen = , reqWaiRequest = limitRequestBody maxBodySize env , reqLangs = langs'' , reqToken = token - , reqSession = session + , reqSession = if useToken + then Map.delete tokenKey session + else session , reqAccept = httpAccept env , reqOnError = onError } diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index aea1f9a5..d9437da6 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -11,6 +11,7 @@ import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) +import Yesod.Core.Types (YesodApp, ErrorResponse) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -91,8 +92,8 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e , queryString = [("_LANG", Just "en-QUERY")] } (singleton "_LANG" "en-SESSION") onError False 10000 g -onError :: a -onError = error "Yesod.InternalRequest.onError" +onError :: ErrorResponse -> YesodApp +onError _ = error "Yesod.InternalRequest.onError" internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 40cddf9e..b9b8b03b 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -96,12 +96,12 @@ library Yesod.Request Yesod.Widget Yesod.Internal.TestApi + Yesod.Core.Types other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request - Yesod.Core.Types Yesod.Core.Time Yesod.Core.Trans.Class Yesod.Core.Run From 7e2338aaa1e39647f2dc5158802e7d30e705aa6f Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 13:33:52 +0200 Subject: [PATCH 013/165] Unified some datatypes --- yesod-core/Yesod/Core/Run.hs | 44 ++++++------------------- yesod-core/Yesod/Core/Types.hs | 59 +++++++++++++++++++++------------- yesod-core/Yesod/Handler.hs | 14 ++++---- 3 files changed, 52 insertions(+), 65 deletions(-) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index 60308d43..a95588f6 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -12,7 +12,6 @@ import Control.Exception (SomeException, fromException, import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger (LogLevel, LogSource) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -30,12 +29,10 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) -import Language.Haskell.TH.Syntax (Loc) import qualified Network.HTTP.Types as H import Network.Wai import Prelude hiding (catch) import System.IO (hPutStrLn, stderr) -import System.Log.FastLogger (LogStr) import System.Log.FastLogger (Logger) import System.Random (newStdGen) import Web.Cookie (renderSetCookie) @@ -83,30 +80,20 @@ headerToPair (Header key value) = (CI.mk key, value) localNoCurrent :: GHandler s m a -> GHandler s m a localNoCurrent = - local (\hd -> hd { handlerRoute = Nothing }) + local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheRoute = Nothing }}) local :: (HandlerData sub' master' -> HandlerData sub master) -> GHandler sub master a -> GHandler sub' master' a local f (GHandler x) = GHandler $ \r -> x $ f r -data RunHandlerEnv sub master = RunHandlerEnv -- FIXME merge with YesodRunnerEnv? Or HandlerData - { rheRender :: !(Route master -> [(Text, Text)] -> Text) - , rheRoute :: !(Maybe (Route sub)) - , rheToMaster :: !(Route sub -> Route master) - , rheMaster :: !master - , rheSub :: !sub - , rheUpload :: !(RequestBodyLength -> FileUpload) - , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) - } - -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'Application'. Should not be needed by users. runHandler :: HasReps c => RunHandlerEnv sub master -> GHandler sub master c -> YesodApp -runHandler RunHandlerEnv {..} handler yreq = do +runHandler rhe@RunHandlerEnv {..} handler yreq = do let toErrorHandler e = case fromException e of Just (HCError x) -> x @@ -120,14 +107,8 @@ runHandler RunHandlerEnv {..} handler yreq = do } let hd = HandlerData { handlerRequest = yreq - , handlerSub = rheSub - , handlerMaster = rheMaster - , handlerRoute = rheRoute - , handlerRender = rheRender - , handlerToMaster = rheToMaster - , handlerState = istate - , handlerUpload = rheUpload - , handlerLog = rheLog + , handlerEnv = rhe + , handlerState = istate } contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id @@ -290,15 +271,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do I.readIORef ret {-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-} -data YesodRunnerEnv sub master = YesodRunnerEnv - { yreLogger :: !Logger - , yreMaster :: !master - , yreSub :: !sub - , yreRoute :: !(Maybe (Route sub)) - , yreToMaster :: !(Route sub -> Route master) - , yreSessionBackend :: !(Maybe (SessionBackend master)) - } - defaultYesodRunner :: Yesod master => YesodRunnerEnv sub master -> GHandler sub master ChooseRep @@ -410,9 +382,11 @@ handlerSubDataMaybe :: (Route sub -> Route master) -> HandlerData oldSub master -> HandlerData sub master handlerSubDataMaybe tm ts route hd = hd - { handlerSub = ts $ handlerMaster hd - , handlerToMaster = tm - , handlerRoute = route + { handlerEnv = (handlerEnv hd) + { rheSub = ts $ rheMaster $ handlerEnv hd + , rheToMaster = tm + , rheRoute = route + } } resolveApproot :: Yesod master => master -> Request -> ResolvedApproot diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 4a7d077f..0ba8f6cb 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -44,7 +44,7 @@ import Network.Wai (FilePart, RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP -import System.Log.FastLogger (LogStr, toLogStr) +import System.Log.FastLogger (LogStr, toLogStr, Logger) import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) @@ -114,8 +114,8 @@ data YesodRequest = YesodRequest -- | An augmented WAI 'W.Response'. This can either be a standard @Response@, -- or a higher-level data structure which Yesod will turn into a @Response@. data YesodResponse - = YRWai W.Response - | YRPlain H.Status [Header] ContentType Content SessionMap + = YRWai !W.Response + | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap -- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = @@ -124,15 +124,15 @@ type RequestBodyContents = ) data FileInfo = FileInfo - { fileName :: Text - , fileContentType :: Text - , fileSource :: Source (ResourceT IO) ByteString - , fileMove :: FilePath -> IO () + { fileName :: !Text + , fileContentType :: !Text + , fileSource :: !(Source (ResourceT IO) ByteString) + , fileMove :: !(FilePath -> IO ()) } -data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) - | FileUploadDisk (NWP.BackEnd FilePath) - | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) +data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString) + | FileUploadDisk !(NWP.BackEnd FilePath) + | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString)) -- | How to determine the root of the application for constructing URLs. -- @@ -140,9 +140,9 @@ data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) -- the major version number. As a result, you should /not/ pattern match on -- @Approot@ values. data Approot master = ApprootRelative -- ^ No application root. - | ApprootStatic Text - | ApprootMaster (master -> Text) - | ApprootRequest (master -> W.Request -> Text) + | ApprootStatic !Text + | ApprootMaster !(master -> Text) + | ApprootRequest !(master -> W.Request -> Text) type ResolvedApproot = Text @@ -169,16 +169,29 @@ type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } +data RunHandlerEnv sub master = RunHandlerEnv + { rheRender :: !(Route master -> [(Text, Text)] -> Text) + , rheRoute :: !(Maybe (Route sub)) + , rheToMaster :: !(Route sub -> Route master) + , rheMaster :: !master + , rheSub :: !sub + , rheUpload :: !(RequestBodyLength -> FileUpload) + , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + } + data HandlerData sub master = HandlerData - { handlerRequest :: YesodRequest - , handlerSub :: sub - , handlerMaster :: master - , handlerRoute :: Maybe (Route sub) - , handlerRender :: Route master -> [(Text, Text)] -> Text - , handlerToMaster :: Route sub -> Route master - , handlerState :: IORef GHState - , handlerUpload :: RequestBodyLength -> FileUpload - , handlerLog :: Loc -> LogSource -> LogLevel -> LogStr -> IO () + { handlerRequest :: !YesodRequest + , handlerEnv :: !(RunHandlerEnv sub master) + , handlerState :: !(IORef GHState) + } + +data YesodRunnerEnv sub master = YesodRunnerEnv + { yreLogger :: !Logger + , yreMaster :: !master + , yreSub :: !sub + , yreRoute :: !(Maybe (Route sub)) + , yreToMaster :: !(Route sub -> Route master) + , yreSessionBackend :: !(Maybe (SessionBackend master)) } -- | A generic handler monad, which can have a different subsite and master @@ -407,7 +420,7 @@ instance MonadResource (GHandler sub master) where instance MonadLogger (GHandler sub master) where monadLoggerLog a b c d = GHandler $ \hd -> - liftIO $ handlerLog hd a b c (toLogStr d) + liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) instance Exception e => Failure e (GHandler sub master) where failure = liftIO . throwIO diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 5f260034..a2f1bcc3 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -199,7 +199,7 @@ hcError = liftIO . throwIO . HCError runRequestBody :: GHandler s m RequestBodyContents runRequestBody = do hd <- ask - let getUpload = handlerUpload hd + let getUpload = rheUpload $ handlerEnv hd len = W.requestBodyLength $ reqWaiRequest $ handlerRequest hd @@ -241,32 +241,32 @@ rbHelper' backend mkFI req = -- | Get the sub application argument. getYesodSub :: GHandler sub master sub -getYesodSub = handlerSub `liftM` ask +getYesodSub = (rheSub . handlerEnv) `liftM` ask -- | Get the master site appliation argument. getYesod :: GHandler sub master master -getYesod = handlerMaster `liftM` ask +getYesod = (rheMaster . handlerEnv) `liftM` ask -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Route master -> Text) getUrlRender = do - x <- handlerRender `liftM` ask + x <- (rheRender . handlerEnv) `liftM` ask return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams :: GHandler sub master (Route master -> [(Text, Text)] -> Text) -getUrlRenderParams = handlerRender `liftM` ask +getUrlRenderParams = (rheRender . handlerEnv) `liftM` ask -- | 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'. getCurrentRoute :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = handlerRoute `liftM` ask +getCurrentRoute = (rheRoute . handlerEnv) `liftM` ask -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = handlerToMaster `liftM` ask +getRouteToMaster = (rheToMaster . handlerEnv) `liftM` ask -- | Returns a function that runs 'GHandler' actions inside @IO@. From dc79ddecd9864d1785188a95462227baec6f4b94 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 13:48:26 +0200 Subject: [PATCH 014/165] Auth tests --- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/Auth.hs | 56 +++++++++++++++++++++++++++ yesod-core/yesod-core.cabal | 1 + 3 files changed, 59 insertions(+) create mode 100644 yesod-core/test/YesodCoreTest/Auth.hs diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 37b5810e..58bf0325 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -14,6 +14,7 @@ import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json +import qualified YesodCoreTest.Auth as Auth import Test.Hspec @@ -33,3 +34,4 @@ specs = do JsLoader.specs RequestBodySize.specs Json.specs + Auth.specs diff --git a/yesod-core/test/YesodCoreTest/Auth.hs b/yesod-core/test/YesodCoreTest/Auth.hs new file mode 100644 index 00000000..17dfc880 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Auth.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +module YesodCoreTest.Auth (specs, Widget) where + +import Yesod.Core +import Test.Hspec +import Network.Wai.Test +import Network.Wai +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Text as T + +data App = App + +mkYesod "App" [parseRoutes| +/no-auth NoAuthR +/needs-login NeedsLoginR +/read-only ReadOnlyR +/forbidden ForbiddenR +|] + +instance Yesod App where + isAuthorized NoAuthR _ = return Authorized + isAuthorized NeedsLoginR _ = return AuthenticationRequired + isAuthorized ReadOnlyR False = return Authorized + isAuthorized ReadOnlyR True = return $ Unauthorized "Read only" + isAuthorized ForbiddenR _ = return $ Unauthorized "Forbidden" + authRoute _ = Just NoAuthR + +handleNoAuthR, handleNeedsLoginR, handleReadOnlyR, handleForbiddenR :: Handler () +handleNoAuthR = return () +handleNeedsLoginR = return () +handleReadOnlyR = return () +handleForbiddenR = return () + +test :: String -- ^ method + -> String -- ^ path + -> (SResponse -> Session ()) + -> Spec +test method path f = it (method ++ " " ++ path) $ do + app <- toWaiApp App + flip runSession app $ do + sres <- request defaultRequest + { requestMethod = S8.pack method + , pathInfo = [T.pack path] + } + f sres + +specs :: Spec +specs = describe "Auth" $ do + test "GET" "no-auth" $ \sres -> assertStatus 200 sres + test "POST" "no-auth" $ \sres -> assertStatus 200 sres + test "GET" "needs-login" $ \sres -> assertStatus 303 sres + test "POST" "needs-login" $ \sres -> assertStatus 303 sres + test "GET" "read-only" $ \sres -> assertStatus 200 sres + test "POST" "read-only" $ \sres -> assertStatus 403 sres + test "GET" "forbidden" $ \sres -> assertStatus 403 sres + test "POST" "forbidden" $ \sres -> assertStatus 403 sres diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index b9b8b03b..e24337fe 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -35,6 +35,7 @@ extra-source-files: test/YesodCoreTest/WaiSubsite.hs test/YesodCoreTest/Widget.hs test/YesodCoreTest/YesodTest.hs + test/YesodCoreTest/Auth.hs test/en.msg test/test.hs From ee01aaf268bf906014323be0fe0738bdaaaca8f8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 14:03:10 +0200 Subject: [PATCH 015/165] Better error handling and auth checking --- yesod-core/Yesod/Core/Class.hs | 23 +++++++++- yesod-core/Yesod/Core/Run.hs | 45 +++++++------------ yesod-core/Yesod/Core/Types.hs | 8 ++-- yesod-core/Yesod/Internal/Request.hs | 4 +- .../test/YesodCoreTest/InternalRequest.hs | 22 ++++----- yesod-core/yesod-core.cabal | 2 +- 6 files changed, 51 insertions(+), 53 deletions(-) diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 3a657772..67ea88be 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -291,13 +291,32 @@ $doctype 5 -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. -- - -- Default: Adds the response header \"Vary: Accept, Accept-Language\". + -- Default: Adds the response header \"Vary: Accept, Accept-Language\" and + -- performs authorization checks. -- -- Since: 1.1.6 yesodMiddleware :: GHandler sub a res -> GHandler sub a res yesodMiddleware handler = do setHeader "Vary" "Accept, Accept-Language" - handler + route <- getCurrentRoute + toMaster <- getRouteToMaster + case fmap toMaster route of + Nothing -> handler + Just url -> do + isWrite <- isWriteRequest url + ar <- isAuthorized url isWrite + case ar of + Authorized -> return () + AuthenticationRequired -> do + master <- getYesod + case authRoute master of + Nothing -> + permissionDenied "Authentication required" + Just url' -> do + setUltDestCurrent + redirect url' + Unauthorized s' -> permissionDenied s' + handler -- | Convert a widget to a 'PageContent'. widgetToPageContent :: (Eq (Route master), Yesod master) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index a95588f6..c85de213 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -39,7 +39,6 @@ import Web.Cookie (renderSetCookie) import Yesod.Content import Yesod.Core.Class import Yesod.Core.Types -import Yesod.Handler import Yesod.Internal (tokenKey) import Yesod.Internal.Request (parseWaiRequest, tooLargeResponse) @@ -118,9 +117,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do let headers = ghsHeaders state let contents = either id (HCContent H.status200 . chooseRep) contents' let handleError e = do - yar <- eh e yreq - { reqOnError = safeEh - , reqSession = finalSession + yar <- rheOnError e yreq + { reqSession = finalSession } case yar of YRPlain _ hs ct c sess -> @@ -160,7 +158,6 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do finalSession HCWai r -> return $ YRWai r where - eh = reqOnError yreq cts = reqAccept yreq initSession = reqSession yreq @@ -229,6 +226,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do , rheSub = master , rheUpload = fileUpload master , rheLog = messageLoggerSource master $ logger master + , rheOnError = errHandler } handler' errHandler err req = do @@ -263,7 +261,6 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do , reqWaiRequest = fakeWaiRequest , reqLangs = [] , reqToken = Just "NaN" -- not a nonce =) - , reqOnError = errHandler , reqAccept = [] , reqSession = fakeSessionMap } @@ -279,30 +276,16 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse | otherwise = do let dontSaveSession _ = return [] - let onError _ = error "FIXME: Yesod.Internal.Core.defaultYesodRunner.onError" (session, saveSession) <- liftIO $ do maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend - rr <- liftIO $ parseWaiRequest req session onError (isJust yreSessionBackend) maxLen <$> newStdGen - let h = {-# SCC "h" #-} do - case yreRoute of - Nothing -> handler - Just url -> do - isWrite <- isWriteRequest $ yreToMaster url - ar <- isAuthorized (yreToMaster url) isWrite - case ar of - Authorized -> return () - AuthenticationRequired -> - case authRoute yreMaster of - Nothing -> - permissionDenied "Authentication required" - Just url' -> do - setUltDestCurrent - redirect url' - Unauthorized s' -> permissionDenied s' - handler + yreq <- liftIO $ parseWaiRequest req session (isJust yreSessionBackend) maxLen <$> newStdGen let ra = resolveApproot yreMaster req let log' = messageLoggerSource yreMaster yreLogger - rhe = RunHandlerEnv + -- We set up two environments: the first one has a "safe" error handler + -- which will never throw an exception. The second one uses the + -- user-provided errorHandler function. If that errorHandler function + -- errors out, it will use the safeEh below to recover. + rheSafe = RunHandlerEnv { rheRender = yesodRender yreMaster ra , rheRoute = yreRoute , rheToMaster = yreToMaster @@ -310,16 +293,18 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req , rheSub = yreSub , rheUpload = fileUpload yreMaster , rheLog = log' + , rheOnError = safeEh } - yar <- runHandler rhe h rr - { reqOnError = runHandler rhe . localNoCurrent . errorHandler - } + rhe = rheSafe + { rheOnError = runHandler rheSafe . localNoCurrent . errorHandler + } + yar <- runHandler rhe handler yreq extraHeaders <- case yar of (YRPlain _ _ ct _ newSess) -> do let nsToken = maybe newSess (\n -> Map.insert tokenKey (encodeUtf8 n) newSess) - (reqToken rr) + (reqToken yreq) sessionHeaders <- liftIO (saveSession nsToken) return $ ("Content-Type", ct) : map headerToPair sessionHeaders _ -> return [] diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 0ba8f6cb..e731a1e7 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -105,10 +105,6 @@ data YesodRequest = YesodRequest -- ^ An ordered list of the accepted content types. -- -- Since 1.2.0 - , reqOnError :: !(ErrorResponse -> YesodApp) - -- ^ How to respond when an error is thrown internally. - -- - -- Since 1.2.0 } -- | An augmented WAI 'W.Response'. This can either be a standard @Response@, @@ -177,6 +173,10 @@ data RunHandlerEnv sub master = RunHandlerEnv , rheSub :: !sub , rheUpload :: !(RequestBodyLength -> FileUpload) , rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + , rheOnError :: !(ErrorResponse -> YesodApp) + -- ^ How to respond when an error is thrown internally. + -- + -- Since 1.2.0 } data HandlerData sub master = HandlerData diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index 21dc06da..e687b098 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -70,12 +70,11 @@ tooLargeResponse = W.responseLBS parseWaiRequest :: RandomGen g => W.Request -> SessionMap - -> (ErrorResponse -> YesodApp) -> Bool -> Word64 -- ^ max body size -> g -> YesodRequest -parseWaiRequest env session onError useToken maxBodySize gen = +parseWaiRequest env session useToken maxBodySize gen = YesodRequest { reqGetParams = gets , reqCookies = cookies @@ -86,7 +85,6 @@ parseWaiRequest env session onError useToken maxBodySize gen = then Map.delete tokenKey session else session , reqAccept = httpAccept env - , reqOnError = onError } where gets = map (second $ fromMaybe "") diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index d9437da6..e31162c0 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -11,7 +11,6 @@ import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) -import Yesod.Core.Types (YesodApp, ErrorResponse) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -41,19 +40,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest defaultRequest mempty onError False 1000 g + r = parseWaiRequest defaultRequest mempty False 1000 g ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError False 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") False 1000 g useOldToken :: Bool useOldToken = reqToken r == Just "old" where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g generateToken :: Bool generateToken = reqToken r /= Nothing where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") onError True 1000 g + r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g langSpecs :: Spec @@ -67,21 +66,21 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where r = parseWaiRequest defaultRequest - { requestHeaders = [("Accept-Language", "en-US, es")] } mempty onError False 1000 g + { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where - r = parseWaiRequest defaultRequest (singleton "_LANG" "en") onError False 1000 g + r = parseWaiRequest defaultRequest (singleton "_LANG" "en") False 1000 g respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where r = parseWaiRequest defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] - } mempty onError False 1000 g + } mempty False 1000 g respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where - r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty onError False 1000 g + r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where @@ -90,10 +89,7 @@ prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "e , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] - } (singleton "_LANG" "en-SESSION") onError False 10000 g - -onError :: ErrorResponse -> YesodApp -onError _ = error "Yesod.InternalRequest.onError" + } (singleton "_LANG" "en-SESSION") False 10000 g internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index e24337fe..1dca3862 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -97,7 +97,6 @@ library Yesod.Request Yesod.Widget Yesod.Internal.TestApi - Yesod.Core.Types other-modules: Yesod.Internal Yesod.Internal.Cache Yesod.Internal.Core @@ -107,6 +106,7 @@ library Yesod.Core.Trans.Class Yesod.Core.Run Yesod.Core.Class + Yesod.Core.Types Paths_yesod_core ghc-options: -Wall From 1b8a1b9d426ff68a17301ade63cb8275e6f4f5c3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 14:04:45 +0200 Subject: [PATCH 016/165] Removed unneeded conditional --- yesod-core/Yesod/Core/Json.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 42f26777..d4e3eaa8 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Core.Json ( -- * Convert from a JSON value @@ -90,11 +89,6 @@ parseJsonBody_ = do J.Error s -> invalidArgs [pack s] J.Success a -> return a -#if !MIN_VERSION_shakespeare_js(1, 0, 2) -instance ToJavascript J.Value where - toJavascript = fromLazyText . decodeUtf8 . JE.encode -#endif - -- | Convert a list of pairs to an 'J.Object'. object :: J.ToJSON a => [(Text, a)] -> J.Value object = J.object . map (second J.toJSON) From 0c4643422c11d7a69ea7704eccf4166becaada92 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 14:14:44 +0200 Subject: [PATCH 017/165] safeEh logs properly --- yesod-core/Yesod/Core/Run.hs | 16 +++++++++++----- yesod-core/Yesod/Widget.hs | 3 ++- yesod-core/yesod-core.cabal | 2 +- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index c85de213..5c4a12e1 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Yesod.Core.Run where import Blaze.ByteString.Builder (fromLazyByteString, toByteString, @@ -32,7 +33,6 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Network.HTTP.Types as H import Network.Wai import Prelude hiding (catch) -import System.IO (hPutStrLn, stderr) import System.Log.FastLogger (Logger) import System.Random (newStdGen) import Web.Cookie (renderSetCookie) @@ -43,6 +43,9 @@ import Yesod.Internal (tokenKey) import Yesod.Internal.Request (parseWaiRequest, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) +import Language.Haskell.TH.Syntax (Loc, qLocation) +import Control.Monad.Logger (LogSource, LogLevel (LevelError), liftLoc) +import System.Log.FastLogger (LogStr, toLogStr) yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response yarToResponse (YRWai a) _ = a @@ -161,9 +164,12 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do cts = reqAccept yreq initSession = reqSession yreq -safeEh :: ErrorResponse -> YesodApp -safeEh er req = do - liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er +safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> ErrorResponse + -> YesodApp +safeEh log' er req = do + liftIO $ log' $(qLocation >>= liftLoc) "yesod-core" LevelError + $ toLogStr $ "Error handler errored out: " ++ show er return $ YRPlain H.status500 [] @@ -293,7 +299,7 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req , rheSub = yreSub , rheUpload = fileUpload yreMaster , rheLog = log' - , rheOnError = safeEh + , rheOnError = safeEh log' } rhe = rheSafe { rheOnError = runHandler rheSafe . localNoCurrent . errorHandler diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 353f4915..13bd571d 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -225,6 +225,7 @@ ihamletToRepHtml ih = do tell :: GWData (Route master) -> GWidget sub master () tell w = GWidget $ return ((), w) --- | Type-restricted version of @lift@ +-- | Type-restricted version of @lift@. Used internally to create better error +-- messages. liftW :: GHandler sub master a -> GWidget sub master a liftW = lift diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 1dca3862..610e9bdc 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -81,7 +81,7 @@ library , vector >= 0.9 && < 0.11 , aeson >= 0.5 , fast-logger >= 0.2 - , monad-logger >= 0.3 && < 0.4 + , monad-logger >= 0.3.1 && < 0.4 , conduit >= 0.5 , resourcet >= 0.4 && < 0.5 , lifted-base >= 0.1 From 0e2fee8da31c286410d45b10b6866bef534cc2ff Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 14:17:53 +0200 Subject: [PATCH 018/165] Removed messageLogger --- yesod-core/Yesod/Core/Class.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 67ea88be..d5d433c9 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -223,18 +223,6 @@ $doctype 5 getLogger :: a -> IO Logger getLogger _ = mkLogger True stdout - -- | Send a message to the @Logger@ provided by @getLogger@. - -- - -- Note: This method is no longer used. Instead, you should override - -- 'messageLoggerSource'. - messageLogger :: a - -> Logger - -> Loc -- ^ position in source code - -> LogLevel - -> LogStr -- ^ message - -> IO () - messageLogger a logger loc = messageLoggerSource a logger loc "" - -- | Send a message to the @Logger@ provided by @getLogger@. messageLoggerSource :: a -> Logger @@ -582,5 +570,3 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ where line = show . fst . loc_start char = show . snd . loc_start - -{-# DEPRECATED messageLogger "Please use messageLoggerSource (since yesod-core 1.1.2)" #-} From 5b5203a27559f9a6be77f29a1b718328142d4502 Mon Sep 17 00:00:00 2001 From: Michael Snoyman <michael@snoyman.com> Date: Sun, 10 Mar 2013 14:20:39 +0200 Subject: [PATCH 019/165] Removed yepnope --- yesod-core/Yesod/Core.hs | 1 - yesod-core/Yesod/Internal/Core.hs | 24 ------------------- yesod-core/test/YesodCoreTest/JsLoader.hs | 5 ---- .../YesodCoreTest/JsLoaderSites/HeadAsync.hs | 16 ------------- yesod-core/yesod-core.cabal | 1 - 5 files changed, 47 deletions(-) delete mode 100644 yesod-core/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index a5a51fb6..984fa321 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -39,7 +39,6 @@ module Yesod.Core , loadClientSession , Header(..) -- * JS loaders - , loadJsYepnope , ScriptLoadPosition (..) , BottomOfHeadAsync -- * Misc diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 3c9f73d0..7aaab853 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -31,7 +31,6 @@ module Yesod.Internal.Core -- * jsLoader , ScriptLoadPosition (..) , BottomOfHeadAsync - , loadJsYepnope -- * Misc , yesodVersion , yesodRender @@ -49,12 +48,7 @@ import Yesod.Routes.Class import qualified Network.Wai as W import Yesod.Internal.Session import Yesod.Internal.Request -import Text.Hamlet -import Text.Blaze (unsafeLazyByteString) import Data.Text (Text) -import Data.Aeson (Value (Array, String)) -import Data.Aeson.Encode (encode) -import qualified Data.Vector as Vector import qualified Paths_yesod_core import Data.Version (showVersion) import System.Log.FastLogger (Logger) @@ -104,24 +98,6 @@ maybeAuthorized r isWrite = do x <- isAuthorized r isWrite return $ if x == Authorized then Just r else Nothing -jsonArray :: [Text] -> Html -jsonArray = unsafeLazyByteString . encode . Array . Vector.fromList . map String - --- | For use with setting 'jsLoader' to 'BottomOfHeadAsync' -loadJsYepnope :: Yesod master => Either Text (Route master) -> [Text] -> Maybe (HtmlUrl (Route master)) -> (HtmlUrl (Route master)) -loadJsYepnope eyn scripts mcomplete = - [hamlet| -$newline never - $maybe yn <- left eyn - <script src=#{yn}> - $maybe yn <- right eyn - <script src=@{yn}> - $maybe complete <- mcomplete - <script>yepnope({load:#{jsonArray scripts},complete:function(){^{complete}}}); - $nothing - <script>yepnope({load:#{jsonArray scripts}}); -|] - -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. class YesodDispatch sub master where diff --git a/yesod-core/test/YesodCoreTest/JsLoader.hs b/yesod-core/test/YesodCoreTest/JsLoader.hs index dba99a85..670bc004 100644 --- a/yesod-core/test/YesodCoreTest/JsLoader.hs +++ b/yesod-core/test/YesodCoreTest/JsLoader.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} module YesodCoreTest.JsLoader (specs, Widget) where -import YesodCoreTest.JsLoaderSites.HeadAsync (HA(..)) import YesodCoreTest.JsLoaderSites.Bottom (B(..)) import Test.Hspec @@ -27,10 +26,6 @@ specs = describe "Test.JsLoader" $ do res <- request defaultRequest assertBody "<!DOCTYPE html>\n<html><head><title>" res - it "link from head async" $ runner HA $ do - res <- request defaultRequest - assertBody "\n" res - it "link from bottom" $ runner B $ do res <- request defaultRequest assertBody "\n" res diff --git a/yesod-core/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs b/yesod-core/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs deleted file mode 100644 index a7b4dceb..00000000 --- a/yesod-core/test/YesodCoreTest/JsLoaderSites/HeadAsync.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -module YesodCoreTest.JsLoaderSites.HeadAsync (HA(..), Widget) where - -import Yesod.Core - -data HA = HA -mkYesod "HA" [parseRoutes| -/ HeadAsyncR GET -|] -instance Yesod HA where - jsLoader _ = BottomOfHeadAsync $ loadJsYepnope $ Left "yepnope.js" - -getHeadAsyncR :: Handler RepHtml -getHeadAsyncR = defaultLayout $ addScriptRemote "load.js" diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 610e9bdc..247daad3 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -25,7 +25,6 @@ extra-source-files: test/YesodCoreTest/Json.hs test/YesodCoreTest/JsLoader.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs - test/YesodCoreTest/JsLoaderSites/HeadAsync.hs test/YesodCoreTest/Links.hs test/YesodCoreTest/Media.hs test/YesodCoreTest/MediaData.hs From 070e0aa8b3b13ddf04062765c06cc226b164c561 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 14:34:00 +0200 Subject: [PATCH 020/165] Make RandomGen parameter optional --- yesod-core/Yesod/Core/Run.hs | 6 +++- yesod-core/Yesod/Internal/Request.hs | 32 ++++++++++------- .../test/YesodCoreTest/InternalRequest.hs | 35 ++++++++++++------- 3 files changed, 48 insertions(+), 25 deletions(-) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index 5c4a12e1..71fddb39 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -284,7 +284,11 @@ defaultYesodRunner YesodRunnerEnv {..} handler' req let dontSaveSession _ = return [] (session, saveSession) <- liftIO $ do maybe (return (Map.empty, dontSaveSession)) (\sb -> sbLoadSession sb yreMaster req) yreSessionBackend - yreq <- liftIO $ parseWaiRequest req session (isJust yreSessionBackend) maxLen <$> newStdGen + let mkYesodReq = parseWaiRequest req session (isJust yreSessionBackend) maxLen + yreq <- + case mkYesodReq of + Left yreq -> return yreq + Right needGen -> liftIO $ needGen <$> newStdGen let ra = resolveApproot yreMaster req let log' = messageLoggerSource yreMaster yreLogger -- We set up two environments: the first one has a "safe" error handler diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index e687b098..c332fd36 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -72,21 +72,27 @@ parseWaiRequest :: RandomGen g -> SessionMap -> Bool -> Word64 -- ^ max body size - -> g - -> YesodRequest -parseWaiRequest env session useToken maxBodySize gen = - YesodRequest + -> (Either YesodRequest (g -> YesodRequest)) +parseWaiRequest env session useToken maxBodySize = + -- In most cases, we won't need to generate any random values. Therefore, + -- we split our results: if we need a random generator, return a Right + -- value, otherwise return a Left and avoid the relatively costly generator + -- acquisition. + case etoken of + Left token -> Left $ mkRequest token + Right mkToken -> Right $ mkRequest . mkToken + where + mkRequest token' = YesodRequest { reqGetParams = gets , reqCookies = cookies , reqWaiRequest = limitRequestBody maxBodySize env , reqLangs = langs'' - , reqToken = token + , reqToken = token' , reqSession = if useToken then Map.delete tokenKey session else session , reqAccept = httpAccept env } - where gets = map (second $ fromMaybe "") $ queryToQueryText $ W.queryString env @@ -111,12 +117,14 @@ parseWaiRequest env session useToken maxBodySize gen = -- tokenKey present in the session is ignored). If sessions -- are enabled and a session has no tokenKey a new one is -- generated. - token = if not useToken - then Nothing - else Just $ maybe - (pack $ randomString 10 gen) - (decodeUtf8With lenientDecode) - (Map.lookup tokenKey session) + etoken + | useToken = + case Map.lookup tokenKey session of + -- Already have a token, use it. + Just bs -> Left $ Just $ decodeUtf8With lenientDecode bs + -- Don't have a token, get a random generator and make a new one. + Nothing -> Right $ Just . pack . randomString 10 + | otherwise = Left Nothing -- | Get the list of accepted content types from the WAI Request\'s Accept -- header. diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index e31162c0..d32e4d46 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -11,6 +11,8 @@ import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) +import Yesod.Core (SessionMap) +import Data.Word (Word64) randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -30,6 +32,15 @@ noRepeat len n = length (nub $ map (randomString len . mkStdGen) [1..n]) == n g :: StdGen g = error "test/YesodCoreTest/InternalRequest.g" +parseWaiRequest' :: Request + -> SessionMap + -> Bool + -> Word64 + -> YesodRequest +parseWaiRequest' a b c d = + case parseWaiRequest a b c d of + Left yreq -> yreq + Right needGen -> needGen g tokenSpecs :: Spec tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do @@ -40,19 +51,19 @@ tokenSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqToken)" $ do noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest defaultRequest mempty False 1000 g + r = parseWaiRequest' defaultRequest mempty False 1000 ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") False 1000 g + r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") False 1000 useOldToken :: Bool useOldToken = reqToken r == Just "old" where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g + r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 generateToken :: Bool generateToken = reqToken r /= Nothing where - r = parseWaiRequest defaultRequest (singleton "_TOKEN" "old") True 1000 g + r = parseWaiRequest' defaultRequest (singleton "_TOKEN" "old") True 1000 langSpecs :: Spec @@ -65,31 +76,31 @@ langSpecs = describe "Yesod.Internal.Request.parseWaiRequest (reqLangs)" $ do respectAcceptLangs :: Bool respectAcceptLangs = reqLangs r == ["en-US", "es", "en"] where - r = parseWaiRequest defaultRequest - { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 g + r = parseWaiRequest' defaultRequest + { requestHeaders = [("Accept-Language", "en-US, es")] } mempty False 1000 respectSessionLang :: Bool respectSessionLang = reqLangs r == ["en"] where - r = parseWaiRequest defaultRequest (singleton "_LANG" "en") False 1000 g + r = parseWaiRequest' defaultRequest (singleton "_LANG" "en") False 1000 respectCookieLang :: Bool respectCookieLang = reqLangs r == ["en"] where - r = parseWaiRequest defaultRequest + r = parseWaiRequest' defaultRequest { requestHeaders = [("Cookie", "_LANG=en")] - } mempty False 1000 g + } mempty False 1000 respectQueryLang :: Bool respectQueryLang = reqLangs r == ["en-US", "en"] where - r = parseWaiRequest defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 g + r = parseWaiRequest' defaultRequest { queryString = [("_LANG", Just "en-US")] } mempty False 1000 prioritizeLangs :: Bool prioritizeLangs = reqLangs r == ["en-QUERY", "en-COOKIE", "en-SESSION", "en", "es"] where - r = parseWaiRequest defaultRequest + r = parseWaiRequest' defaultRequest { requestHeaders = [ ("Accept-Language", "en, es") , ("Cookie", "_LANG=en-COOKIE") ] , queryString = [("_LANG", Just "en-QUERY")] - } (singleton "_LANG" "en-SESSION") False 10000 g + } (singleton "_LANG" "en-SESSION") False 10000 internalRequestTest :: Spec internalRequestTest = describe "Test.InternalRequestTest" $ do From 1a5793e2b92663d0f5294b265f8969268bc79f2f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 14:38:52 +0200 Subject: [PATCH 021/165] Removed Yesod.Request --- yesod-core/Yesod/Core.hs | 2 - yesod-core/Yesod/Handler.hs | 87 ++++++++++++++ yesod-core/Yesod/Request.hs | 109 ------------------ .../test/YesodCoreTest/InternalRequest.hs | 3 +- yesod-core/yesod-core.cabal | 1 - 5 files changed, 88 insertions(+), 114 deletions(-) delete mode 100644 yesod-core/Yesod/Request.hs diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 984fa321..affac9f6 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -49,7 +49,6 @@ module Yesod.Core , module Yesod.Content , module Yesod.Dispatch , module Yesod.Handler - , module Yesod.Request , module Yesod.Widget , module Yesod.Core.Json , module Text.Shakespeare.I18N @@ -60,7 +59,6 @@ import Yesod.Internal (Header(..)) import Yesod.Content import Yesod.Dispatch import Yesod.Handler -import Yesod.Request import Yesod.Widget import Yesod.Core.Json import Text.Shakespeare.I18N diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index a2f1bcc3..d45e95e9 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -37,6 +37,27 @@ module Yesod.Handler , getRequest , waiRequest , runRequestBody + -- ** Request information + -- *** Request datatype + , RequestBodyContents + , YesodRequest (..) + , FileInfo + , fileName + , fileContentType + , fileSource + , fileMove + -- *** Convenience functions + , languages + -- *** Lookup parameters + , lookupGetParam + , lookupPostParam + , lookupCookie + , lookupFile + -- **** Multi-lookup + , lookupGetParams + , lookupPostParams + , lookupCookies + , lookupFiles -- * Special responses -- ** Redirecting , RedirectUrl (..) @@ -156,6 +177,7 @@ import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Yesod.Routes.Class (Route) import Yesod.Core.Types import Yesod.Core.Trans.Class +import Data.Maybe (listToMaybe) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y @@ -716,3 +738,68 @@ cacheDelete k = modify $ \gs -> ask :: GHandler sub master (HandlerData sub master) ask = GHandler return + +-- | Get the list of supported languages supplied by the user. +-- +-- Languages are determined based on the following three (in descending order +-- of preference): +-- +-- * The _LANG get parameter. +-- +-- * The _LANG cookie. +-- +-- * The _LANG user session variable. +-- +-- * Accept-Language HTTP header. +-- +-- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates. +-- If a matching language is not found the default language will be used. +-- +-- This is handled by parseWaiRequest (not exposed). +languages :: GHandler s m [Text] +languages = reqLangs `liftM` getRequest + +lookup' :: Eq a => a -> [(a, b)] -> [b] +lookup' a = map snd . filter (\x -> a == fst x) + +-- | Lookup for GET parameters. +lookupGetParams :: Text -> GHandler s m [Text] +lookupGetParams pn = do + rr <- getRequest + return $ lookup' pn $ reqGetParams rr + +-- | Lookup for GET parameters. +lookupGetParam :: Text -> GHandler s m (Maybe Text) +lookupGetParam = liftM listToMaybe . lookupGetParams + +-- | Lookup for POST parameters. +lookupPostParams :: Text -> GHandler s m [Text] +lookupPostParams pn = do + (pp, _) <- runRequestBody + return $ lookup' pn pp + +lookupPostParam :: Text + -> GHandler s m (Maybe Text) +lookupPostParam = liftM listToMaybe . lookupPostParams + +-- | Lookup for POSTed files. +lookupFile :: Text + -> GHandler s m (Maybe FileInfo) +lookupFile = liftM listToMaybe . lookupFiles + +-- | Lookup for POSTed files. +lookupFiles :: Text + -> GHandler s m [FileInfo] +lookupFiles pn = do + (_, files) <- runRequestBody + return $ lookup' pn files + +-- | Lookup for cookie data. +lookupCookie :: Text -> GHandler s m (Maybe Text) +lookupCookie = liftM listToMaybe . lookupCookies + +-- | Lookup for cookie data. +lookupCookies :: Text -> GHandler s m [Text] +lookupCookies pn = do + rr <- getRequest + return $ lookup' pn $ reqCookies rr diff --git a/yesod-core/Yesod/Request.hs b/yesod-core/Yesod/Request.hs deleted file mode 100644 index 7aec55ca..00000000 --- a/yesod-core/Yesod/Request.hs +++ /dev/null @@ -1,109 +0,0 @@ ---------------------------------------------------------- --- --- Module : Yesod.Request --- Copyright : Michael Snoyman --- License : BSD3 --- --- Maintainer : Michael Snoyman --- Stability : Stable --- Portability : portable --- --- | Provides a parsed version of the raw 'W.Request' data. --- ---------------------------------------------------------- -module Yesod.Request - ( - -- * Request datatype - RequestBodyContents - , YesodRequest (..) - , FileInfo - , fileName - , fileContentType - , fileSource - , fileMove - -- * Convenience functions - , languages - -- * Lookup parameters - , lookupGetParam - , lookupPostParam - , lookupCookie - , lookupFile - -- ** Multi-lookup - , lookupGetParams - , lookupPostParams - , lookupCookies - , lookupFiles - ) where - -import Yesod.Internal.Request -import Yesod.Handler -import Control.Monad (liftM) -import Control.Monad.Instances () -- I'm missing the instance Monad ((->) r -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import Yesod.Core.Types - --- | Get the list of supported languages supplied by the user. --- --- Languages are determined based on the following three (in descending order --- of preference): --- --- * The _LANG get parameter. --- --- * The _LANG cookie. --- --- * The _LANG user session variable. --- --- * Accept-Language HTTP header. --- --- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates. --- If a matching language is not found the default language will be used. --- --- This is handled by parseWaiRequest (not exposed). -languages :: GHandler s m [Text] -languages = reqLangs `liftM` getRequest - -lookup' :: Eq a => a -> [(a, b)] -> [b] -lookup' a = map snd . filter (\x -> a == fst x) - --- | Lookup for GET parameters. -lookupGetParams :: Text -> GHandler s m [Text] -lookupGetParams pn = do - rr <- getRequest - return $ lookup' pn $ reqGetParams rr - --- | Lookup for GET parameters. -lookupGetParam :: Text -> GHandler s m (Maybe Text) -lookupGetParam = liftM listToMaybe . lookupGetParams - --- | Lookup for POST parameters. -lookupPostParams :: Text -> GHandler s m [Text] -lookupPostParams pn = do - (pp, _) <- runRequestBody - return $ lookup' pn pp - -lookupPostParam :: Text - -> GHandler s m (Maybe Text) -lookupPostParam = liftM listToMaybe . lookupPostParams - --- | Lookup for POSTed files. -lookupFile :: Text - -> GHandler s m (Maybe FileInfo) -lookupFile = liftM listToMaybe . lookupFiles - --- | Lookup for POSTed files. -lookupFiles :: Text - -> GHandler s m [FileInfo] -lookupFiles pn = do - (_, files) <- runRequestBody - return $ lookup' pn files - --- | Lookup for cookie data. -lookupCookie :: Text -> GHandler s m (Maybe Text) -lookupCookie = liftM listToMaybe . lookupCookies - --- | Lookup for cookie data. -lookupCookies :: Text -> GHandler s m [Text] -lookupCookies pn = do - rr <- getRequest - return $ lookup' pn $ reqCookies rr diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index d32e4d46..0c3df884 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -7,11 +7,10 @@ import System.Random (StdGen, mkStdGen) import Network.Wai as W import Network.Wai.Test import Yesod.Internal.TestApi (randomString, parseWaiRequest) -import Yesod.Request (YesodRequest (..)) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) -import Yesod.Core (SessionMap) +import Yesod.Core import Data.Word (Word64) randomStringSpecs :: Spec diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 247daad3..efd781fd 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -93,7 +93,6 @@ library Yesod.Core.Json Yesod.Dispatch Yesod.Handler - Yesod.Request Yesod.Widget Yesod.Internal.TestApi other-modules: Yesod.Internal From 9559c2a3454f4f69e0ad22471bc1b497aefe8ace Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 15:05:40 +0200 Subject: [PATCH 022/165] Typeable-based cache implementation (#268) --- yesod-core/Yesod/Core/Types.hs | 17 +++++----- yesod-core/Yesod/Handler.hs | 46 ++++++++++++++++---------- yesod-core/Yesod/Internal/Cache.hs | 32 ------------------ yesod-core/test/YesodCoreTest/Cache.hs | 35 +++++++++++--------- yesod-core/yesod-core.cabal | 2 +- 5 files changed, 57 insertions(+), 75 deletions(-) delete mode 100644 yesod-core/Yesod/Internal/Cache.hs diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index e731a1e7..b8c3e1d9 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -24,11 +24,11 @@ import qualified Data.ByteString.Lazy as L import Data.Conduit (Flush, MonadThrow (..), MonadUnsafeIO (..), ResourceT, Source) -import Data.IntMap (IntMap) +import Data.Dynamic (Dynamic) import Data.IORef (IORef) import Data.Map (Map, unionWith) import qualified Data.Map as Map -import Data.Monoid (Any, Endo (..), Last (..), +import Data.Monoid (Endo (..), Last (..), Monoid (..)) import Data.Serialize (Serialize (..), putByteString) @@ -38,13 +38,14 @@ import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as TBuilder import Data.Time (UTCTime) import Data.Typeable (Typeable) +import Data.Typeable (TypeRep) import Language.Haskell.TH.Syntax (Loc) import qualified Network.HTTP.Types as H import Network.Wai (FilePart, RequestBodyLength) import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP -import System.Log.FastLogger (LogStr, toLogStr, Logger) +import System.Log.FastLogger (LogStr, Logger, toLogStr) import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) @@ -155,11 +156,9 @@ type BottomOfHeadAsync master -> Maybe (HtmlUrl (Route master)) -- ^ widget of js to run on async completion -> (HtmlUrl (Route master)) -- ^ widget to insert at the bottom of -newtype Cache = Cache (IntMap Any) +newtype Cache = Cache (Map TypeRep Dynamic) deriving Monoid -newtype CacheKey a = CacheKey Int - type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. @@ -180,9 +179,9 @@ data RunHandlerEnv sub master = RunHandlerEnv } data HandlerData sub master = HandlerData - { handlerRequest :: !YesodRequest - , handlerEnv :: !(RunHandlerEnv sub master) - , handlerState :: !(IORef GHState) + { handlerRequest :: !YesodRequest + , handlerEnv :: !(RunHandlerEnv sub master) + , handlerState :: !(IORef GHState) } data YesodRunnerEnv sub master = YesodRunnerEnv diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index d45e95e9..34080529 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -120,11 +120,7 @@ module Yesod.Handler -- * i18n , getMessageRender -- * Per-request caching - , CacheKey - , mkCacheKey - , cacheLookup - , cacheInsert - , cacheDelete + , cached -- * Internal Yesod , YesodApp , runSubsiteGetter @@ -170,14 +166,14 @@ import Text.Shakespeare.I18N (RenderMessage (..)) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup -import qualified Yesod.Internal.Cache as Cache -import Yesod.Internal.Cache (mkCacheKey) import qualified Data.IORef as I import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Yesod.Routes.Class (Route) import Yesod.Core.Types import Yesod.Core.Trans.Class import Data.Maybe (listToMaybe) +import Data.Typeable (Typeable, typeOf) +import Data.Dynamic (fromDynamic, toDyn) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y @@ -723,18 +719,34 @@ getMessageRender = do l <- reqLangs `liftM` getRequest return $ renderMessage m l -cacheLookup :: CacheKey a -> GHandler sub master (Maybe a) -cacheLookup k = do +-- | Use a per-request cache to avoid performing the same action multiple +-- times. Note that values are stored by their type. Therefore, you should use +-- newtype wrappers to distinguish logically different types. +-- +-- Since 1.2.0 +cached :: Typeable a + => GHandler sub master a + -> GHandler sub master a +cached f = do gs <- get - return $ Cache.lookup k $ ghsCache gs + let cache = ghsCache gs + case clookup cache of + Just val -> return val + Nothing -> do + val <- f + put $ gs { ghsCache = cinsert val cache } + return val + where + clookup :: Typeable a => Cache -> Maybe a + clookup (Cache m) = + res + where + res = Map.lookup (typeOf $ fromJust res) m >>= fromDynamic + fromJust :: Maybe a -> a + fromJust = error "Yesod.Handler.cached.fromJust: Argument to typeOf was evaluated" -cacheInsert :: CacheKey a -> a -> GHandler sub master () -cacheInsert k v = modify $ \gs -> - gs { ghsCache = Cache.insert k v $ ghsCache gs } - -cacheDelete :: CacheKey a -> GHandler sub master () -cacheDelete k = modify $ \gs -> - gs { ghsCache = Cache.delete k $ ghsCache gs } + cinsert :: Typeable a => a -> Cache -> Cache + cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m) ask :: GHandler sub master (HandlerData sub master) ask = GHandler return diff --git a/yesod-core/Yesod/Internal/Cache.hs b/yesod-core/Yesod/Internal/Cache.hs deleted file mode 100644 index 0fc2d2a1..00000000 --- a/yesod-core/Yesod/Internal/Cache.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -module Yesod.Internal.Cache - ( Cache - , CacheKey - , mkCacheKey - , lookup - , insert - , delete - ) where - -import Prelude hiding (lookup) -import qualified Data.IntMap as Map -import Language.Haskell.TH.Syntax (Q, Exp, runIO, Exp (LitE), Lit (IntegerL)) -import Language.Haskell.TH (appE) -import Data.Unique (hashUnique, newUnique) -import Unsafe.Coerce (unsafeCoerce) -import Control.Applicative ((<$>)) -import Yesod.Core.Types - --- | Generate a new 'CacheKey'. Be sure to give a full type signature. -mkCacheKey :: Q Exp -mkCacheKey = [|CacheKey|] `appE` (LitE . IntegerL . fromIntegral . hashUnique <$> runIO newUnique) - -lookup :: CacheKey a -> Cache -> Maybe a -lookup (CacheKey i) (Cache m) = unsafeCoerce <$> Map.lookup i m - -insert :: CacheKey a -> a -> Cache -> Cache -insert (CacheKey k) v (Cache m) = Cache (Map.insert k (unsafeCoerce v) m) - -delete :: CacheKey a -> Cache -> Cache -delete (CacheKey k) (Cache m) = Cache (Map.delete k m) diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index d12d0cc1..45df7615 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/yesod-core/test/YesodCoreTest/Cache.hs @@ -1,38 +1,40 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} module YesodCoreTest.Cache (cacheTest, Widget) where import Test.Hspec -import Network.Wai import Network.Wai.Test import Yesod.Core +import Data.IORef.Lifted +import Data.Typeable (Typeable) +import qualified Data.ByteString.Lazy.Char8 as L8 data C = C -key :: CacheKey Int -key = $(mkCacheKey) +newtype V1 = V1 Int + deriving Typeable -key2 :: CacheKey Int -key2 = $(mkCacheKey) +newtype V2 = V2 Int + deriving Typeable mkYesod "C" [parseRoutes|/ RootR GET|] instance Yesod C -getRootR :: Handler () +getRootR :: Handler RepPlain getRootR = do - Nothing <- cacheLookup key - cacheInsert key 5 - Just 5 <- cacheLookup key - cacheInsert key 7 - Just 7 <- cacheLookup key - Nothing <- cacheLookup key2 - cacheDelete key - Nothing <- cacheLookup key - return () + ref <- newIORef 0 + V1 v1a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + V1 v1b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V1 $ i + 1) + + V2 v2a <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + V2 v2b <- cached $ atomicModifyIORef ref $ \i -> (i + 1, V2 $ i + 1) + + return $ RepPlain $ toContent $ show [v1a, v1b, v2a, v2b] cacheTest :: Spec cacheTest = @@ -44,5 +46,6 @@ runner f = toWaiApp C >>= runSession f works :: IO () works = runner $ do - res <- request defaultRequest { pathInfo = [] } + res <- request defaultRequest assertStatus 200 res + assertBody (L8.pack $ show [1, 1, 2, 2 :: Int]) res diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index efd781fd..1a3a066a 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -96,7 +96,6 @@ library Yesod.Widget Yesod.Internal.TestApi other-modules: Yesod.Internal - Yesod.Internal.Cache Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request @@ -132,6 +131,7 @@ test-suite tests ,transformers , conduit , containers + , lifted-base ghc-options: -Wall source-repository head From 5c4ddfad6c3a20004d814fe809bcf4af93bd2ec6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 15:18:58 +0200 Subject: [PATCH 023/165] Removed Yesod.Internal --- yesod-core/Yesod/Core.hs | 2 +- yesod-core/Yesod/Core/Class.hs | 5 ++- yesod-core/Yesod/Core/Run.hs | 12 +++---- yesod-core/Yesod/Handler.hs | 1 - yesod-core/Yesod/Internal.hs | 53 ---------------------------- yesod-core/Yesod/Internal/Request.hs | 10 +++++- yesod-core/Yesod/Widget.hs | 4 ++- yesod-core/yesod-core.cabal | 3 +- 8 files changed, 24 insertions(+), 66 deletions(-) delete mode 100644 yesod-core/Yesod/Internal.hs diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index affac9f6..ddbc2b68 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -55,12 +55,12 @@ module Yesod.Core ) where import Yesod.Internal.Core -import Yesod.Internal (Header(..)) import Yesod.Content import Yesod.Dispatch import Yesod.Handler import Yesod.Widget import Yesod.Core.Json +import Yesod.Core.Types import Text.Shakespeare.I18N import Control.Monad.Logger diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index d5d433c9..5765ec3f 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -20,6 +20,7 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.List (foldl') +import Data.List (nub) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Monoid @@ -51,7 +52,6 @@ import qualified Web.ClientSession as CS import Web.Cookie (parseCookies) import Web.Cookie (SetCookie (..)) import Yesod.Core.Types -import Yesod.Internal import Yesod.Internal.Session import Yesod.Widget @@ -399,6 +399,9 @@ $newline never : attrs ) + runUniqueList :: Eq x => UniqueList x -> [x] + runUniqueList (UniqueList x) = nub $ x [] + -- | Helper function for 'defaultErrorHandler'. applyLayout' :: Yesod master => Html -- ^ title diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index 71fddb39..b2af0d4b 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -2,7 +2,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Yesod.Core.Run where import Blaze.ByteString.Builder (fromLazyByteString, toByteString, @@ -13,6 +13,8 @@ import Control.Exception (SomeException, fromException, import Control.Exception.Lifted (catch) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (LogLevel (LevelError), LogSource, + liftLoc) import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -30,22 +32,20 @@ import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) +import Language.Haskell.TH.Syntax (Loc, qLocation) import qualified Network.HTTP.Types as H import Network.Wai import Prelude hiding (catch) import System.Log.FastLogger (Logger) +import System.Log.FastLogger (LogStr, toLogStr) import System.Random (newStdGen) import Web.Cookie (renderSetCookie) import Yesod.Content import Yesod.Core.Class import Yesod.Core.Types -import Yesod.Internal (tokenKey) -import Yesod.Internal.Request (parseWaiRequest, +import Yesod.Internal.Request (parseWaiRequest, tokenKey, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) -import Language.Haskell.TH.Syntax (Loc, qLocation) -import Control.Monad.Logger (LogSource, LogLevel (LevelError), liftLoc) -import System.Log.FastLogger (LogStr, toLogStr) yarToResponse :: YesodResponse -> [(CI ByteString, ByteString)] -> Response yarToResponse (YRWai a) _ = a diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 34080529..fa898fb6 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -130,7 +130,6 @@ module Yesod.Handler import Prelude hiding (catch) import Yesod.Internal.Request -import Yesod.Internal import Data.Time (UTCTime, getCurrentTime, addUTCTime) import Control.Exception hiding (Handler, catch, finally) diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs deleted file mode 100644 index 1ea65523..00000000 --- a/yesod-core/Yesod/Internal.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | Normal users should never need access to these. --- --- Note that no guarantees of API stability are provided on this module. Use at your own risk. -module Yesod.Internal - ( -- * Error responses - ErrorResponse (..) - , HandlerContents (..) - -- * Header - , Header (..) - -- * Cookie names - , langKey - -- * Widgets - , GWData (..) - , Location (..) - , UniqueList (..) - , Script (..) - , Stylesheet (..) - , Title (..) - , Head (..) - , Body (..) - , locationToHtmlUrl - , runUniqueList - , toUnique - -- * Names - , tokenKey - ) where - -import Text.Hamlet (HtmlUrl) -import Text.Blaze.Html (toHtml) -import Data.List (nub) - -import Data.String (IsString) -import Yesod.Core.Types - -langKey :: IsString a => a -langKey = "_LANG" - -locationToHtmlUrl :: Location url -> HtmlUrl url -locationToHtmlUrl (Local url) render = toHtml $ render url [] -locationToHtmlUrl (Remote s) _ = toHtml s - -runUniqueList :: Eq x => UniqueList x -> [x] -runUniqueList (UniqueList x) = nub $ x [] -toUnique :: x -> UniqueList x -toUnique = UniqueList . (:) - -tokenKey :: IsString a => a -tokenKey = "_TOKEN" diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index c332fd36..5dbc242a 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -13,13 +13,15 @@ module Yesod.Internal.Request , mkFileInfoSource , FileUpload (..) , tooLargeResponse + , tokenKey + , langKey -- The below are exported for testing. , randomString ) where +import Data.String (IsString) import Control.Arrow (second) import qualified Network.Wai.Parse as NWP -import Yesod.Internal import qualified Network.Wai as W import System.Random (RandomGen, randomRs) import Web.Cookie (parseCookiesText) @@ -165,3 +167,9 @@ mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourc mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) + +tokenKey :: IsString a => a +tokenKey = "_TOKEN" + +langKey :: IsString a => a +langKey = "_LANG" diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 13bd571d..9dbb4acb 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -57,7 +57,6 @@ import Yesod.Handler ) import Text.Shakespeare.I18N (RenderMessage) import Yesod.Content (toContent) -import Yesod.Internal import Control.Monad (liftM) import Data.Text (Text) import qualified Data.Map as Map @@ -229,3 +228,6 @@ tell w = GWidget $ return ((), w) -- messages. liftW :: GHandler sub master a -> GWidget sub master a liftW = lift + +toUnique :: x -> UniqueList x +toUnique = UniqueList . (:) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 1a3a066a..370530b2 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -95,8 +95,7 @@ library Yesod.Handler Yesod.Widget Yesod.Internal.TestApi - other-modules: Yesod.Internal - Yesod.Internal.Core + other-modules: Yesod.Internal.Core Yesod.Internal.Session Yesod.Internal.Request Yesod.Core.Time From 8d5f207c8d3dc1995574aaa927b75efc52148cb7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 10 Mar 2013 15:21:54 +0200 Subject: [PATCH 024/165] Removed Yesod.Internal.TestApi --- yesod-core/Yesod/{ => Core}/Internal/Request.hs | 2 +- yesod-core/Yesod/Core/Run.hs | 2 +- yesod-core/Yesod/Handler.hs | 2 +- yesod-core/Yesod/Internal/Core.hs | 2 +- yesod-core/Yesod/Internal/TestApi.hs | 11 ----------- yesod-core/test/YesodCoreTest/InternalRequest.hs | 2 +- yesod-core/yesod-core.cabal | 3 +-- 7 files changed, 6 insertions(+), 18 deletions(-) rename yesod-core/Yesod/{ => Core}/Internal/Request.hs (99%) delete mode 100644 yesod-core/Yesod/Internal/TestApi.hs diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Core/Internal/Request.hs similarity index 99% rename from yesod-core/Yesod/Internal/Request.hs rename to yesod-core/Yesod/Core/Internal/Request.hs index 5dbc242a..f52d07fc 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Core/Internal/Request.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -module Yesod.Internal.Request +module Yesod.Core.Internal.Request ( parseWaiRequest , RequestBodyContents , FileInfo diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index b2af0d4b..e13356af 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -43,7 +43,7 @@ import Web.Cookie (renderSetCookie) import Yesod.Content import Yesod.Core.Class import Yesod.Core.Types -import Yesod.Internal.Request (parseWaiRequest, tokenKey, +import Yesod.Core.Internal.Request (parseWaiRequest, tokenKey, tooLargeResponse) import Yesod.Routes.Class (Route, renderRoute) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index fa898fb6..15e21751 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -129,7 +129,7 @@ module Yesod.Handler ) where import Prelude hiding (catch) -import Yesod.Internal.Request +import Yesod.Core.Internal.Request import Data.Time (UTCTime, getCurrentTime, addUTCTime) import Control.Exception hiding (Handler, catch, finally) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 7aaab853..4a8a3a4e 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -47,7 +47,7 @@ import Yesod.Routes.Class import qualified Network.Wai as W import Yesod.Internal.Session -import Yesod.Internal.Request +import Yesod.Core.Internal.Request import Data.Text (Text) import qualified Paths_yesod_core import Data.Version (showVersion) diff --git a/yesod-core/Yesod/Internal/TestApi.hs b/yesod-core/Yesod/Internal/TestApi.hs deleted file mode 100644 index bbb352ef..00000000 --- a/yesod-core/Yesod/Internal/TestApi.hs +++ /dev/null @@ -1,11 +0,0 @@ --- --- | WARNING: This module exposes internal interfaces solely for the --- purpose of facilitating cabal-driven testing of said interfaces. --- This module is NOT part of the public Yesod API and should NOT be --- imported by library users. --- -module Yesod.Internal.TestApi - ( randomString, parseWaiRequest - ) where - -import Yesod.Internal.Request (randomString, parseWaiRequest) diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index 0c3df884..90834485 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -6,7 +6,7 @@ import System.Random (StdGen, mkStdGen) import Network.Wai as W import Network.Wai.Test -import Yesod.Internal.TestApi (randomString, parseWaiRequest) +import Yesod.Core.Internal.Request (randomString, parseWaiRequest) import Test.Hspec import Data.Monoid (mempty) import Data.Map (singleton) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 370530b2..0285a672 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -94,10 +94,9 @@ library Yesod.Dispatch Yesod.Handler Yesod.Widget - Yesod.Internal.TestApi + Yesod.Core.Internal.Request other-modules: Yesod.Internal.Core Yesod.Internal.Session - Yesod.Internal.Request Yesod.Core.Time Yesod.Core.Trans.Class Yesod.Core.Run From 8f8e98683986890f8bb7565dcba817de2076abc3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 06:00:50 +0200 Subject: [PATCH 025/165] Started on the Handler typeclasses --- yesod-core/Yesod/Core/Handler/Class.hs | 84 ++++++++++++++++++++++++++ yesod-core/Yesod/Handler.hs | 72 ++++++++++------------ yesod-core/yesod-core.cabal | 1 + 3 files changed, 118 insertions(+), 39 deletions(-) create mode 100644 yesod-core/Yesod/Core/Handler/Class.hs diff --git a/yesod-core/Yesod/Core/Handler/Class.hs b/yesod-core/Yesod/Core/Handler/Class.hs new file mode 100644 index 00000000..46cb8176 --- /dev/null +++ b/yesod-core/Yesod/Core/Handler/Class.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Yesod.Core.Handler.Class where + +import Yesod.Core.Types +import Yesod.Core.Trans.Class (lift) +import Control.Monad.Trans.Class (MonadTrans) +import Data.IORef.Lifted (atomicModifyIORef) +import Control.Exception.Lifted (throwIO) + +class Monad m => HandlerReader m where + type HandlerReaderSub m + type HandlerReaderMaster m + + askYesodRequest :: m YesodRequest + askHandlerEnv :: m (RunHandlerEnv (HandlerReaderSub m) (HandlerReaderMaster m)) + +instance HandlerReader (GHandler sub master) where + type HandlerReaderSub (GHandler sub master) = sub + type HandlerReaderMaster (GHandler sub master) = master + + askYesodRequest = GHandler $ return . handlerRequest + askHandlerEnv = GHandler $ return . handlerEnv + +instance HandlerReader (GWidget sub master) where + type HandlerReaderSub (GWidget sub master) = sub + type HandlerReaderMaster (GWidget sub master) = master + + askYesodRequest = lift askYesodRequest + askHandlerEnv = lift askHandlerEnv + +instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where + type HandlerReaderSub (t m) = HandlerReaderSub m + type HandlerReaderMaster (t m) = HandlerReaderMaster m + + askYesodRequest = lift askYesodRequest + askHandlerEnv = lift askHandlerEnv + +class HandlerReader m => HandlerState m where + type HandlerStateSub m + type HandlerStateMaster m + + stateGHState :: (GHState -> (a, GHState)) -> m a + + getGHState :: m GHState + getGHState = stateGHState $ \s -> (s, s) + + putGHState :: GHState -> m () + putGHState s = stateGHState $ const ((), s) + +instance HandlerState (GHandler sub master) where + type HandlerStateSub (GHandler sub master) = sub + type HandlerStateMaster (GHandler sub master) = master + + stateGHState f = + GHandler $ flip atomicModifyIORef f' . handlerState + where + f' z = let (x, y) = f z in (y, x) + +instance HandlerState (GWidget sub master) where + type HandlerStateSub (GWidget sub master) = sub + type HandlerStateMaster (GWidget sub master) = master + + stateGHState = lift . stateGHState + +instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where + type HandlerStateSub (t m) = HandlerStateSub m + type HandlerStateMaster (t m) = HandlerStateMaster m + + stateGHState = lift . stateGHState + +class Monad m => HandlerError m where + handlerError :: ErrorResponse -> m a + +instance HandlerError (GHandler sub master) where + handlerError = throwIO . HCError + +instance HandlerError (GWidget sub master) where + handlerError = lift . handlerError + +instance (HandlerError m, MonadTrans t, Monad (t m)) => HandlerError (t m) where + handlerError = lift . handlerError diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 15e21751..3f5ba9a0 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -1,4 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -138,6 +140,7 @@ import Control.Applicative import Control.Monad (liftM) import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (MonadResource, liftResourceT) import qualified Network.Wai as W import qualified Network.HTTP.Types as H @@ -173,28 +176,26 @@ import Yesod.Core.Trans.Class import Data.Maybe (listToMaybe) import Data.Typeable (Typeable, typeOf) import Data.Dynamic (fromDynamic, toDyn) +import Yesod.Core.Handler.Class class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y -get :: GHandler sub master GHState -get = do - hd <- ask - liftIO $ I.readIORef $ handlerState hd +get :: HandlerState m => m GHState +get = getGHState -put :: GHState -> GHandler sub master () -put g = do - hd <- ask - liftIO $ I.writeIORef (handlerState hd) g +put :: HandlerState m => GHState -> m () +put = putGHState -modify :: (GHState -> GHState) -> GHandler sub master () -modify f = do - hd <- ask - liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ()) +modify :: HandlerState m => (GHState -> GHState) -> m () +modify = stateGHState . (((), ) .) -tell :: Endo [Header] -> GHandler sub master () +tell :: HandlerState m => Endo [Header] -> m () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } +hcError :: HandlerError m => ErrorResponse -> m a +hcError = handlerError + class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s @@ -207,26 +208,22 @@ instance (anySub ~ anySub' ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where runSubsiteGetter = id -getRequest :: GHandler s m YesodRequest -getRequest = handlerRequest `liftM` ask +getRequest :: HandlerReader m => m YesodRequest +getRequest = askYesodRequest -hcError :: ErrorResponse -> GHandler sub master a -hcError = liftIO . throwIO . HCError - -runRequestBody :: GHandler s m RequestBodyContents +runRequestBody :: (MonadResource m, HandlerReader m, HandlerState m) + => m RequestBodyContents runRequestBody = do - hd <- ask - let getUpload = rheUpload $ handlerEnv hd - len = W.requestBodyLength - $ reqWaiRequest - $ handlerRequest hd - upload = getUpload len + RunHandlerEnv {..} <- askHandlerEnv + req <- askYesodRequest + let len = W.requestBodyLength $ reqWaiRequest req + upload = rheUpload len x <- get case ghsRBC x of Just rbc -> return rbc Nothing -> do rr <- waiRequest - rbc <- lift $ rbHelper upload rr + rbc <- liftResourceT $ rbHelper upload rr put x { ghsRBC = Just rbc } return rbc @@ -257,33 +254,33 @@ rbHelper' backend mkFI req = go = decodeUtf8With lenientDecode -- | Get the sub application argument. -getYesodSub :: GHandler sub master sub -getYesodSub = (rheSub . handlerEnv) `liftM` ask +getYesodSub :: HandlerReader m => m (HandlerReaderSub m) +getYesodSub = rheSub `liftM` askHandlerEnv -- | Get the master site appliation argument. -getYesod :: GHandler sub master master -getYesod = (rheMaster . handlerEnv) `liftM` ask +getYesod :: HandlerReader m => m (HandlerReaderMaster m) +getYesod = rheMaster `liftM` askHandlerEnv -- | Get the URL rendering function. getUrlRender :: GHandler sub master (Route master -> Text) getUrlRender = do - x <- (rheRender . handlerEnv) `liftM` ask + x <- rheRender `liftM` askHandlerEnv return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams :: GHandler sub master (Route master -> [(Text, Text)] -> Text) -getUrlRenderParams = (rheRender . handlerEnv) `liftM` ask +getUrlRenderParams = rheRender `liftM` askHandlerEnv -- | 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'. getCurrentRoute :: GHandler sub master (Maybe (Route sub)) -getCurrentRoute = (rheRoute . handlerEnv) `liftM` ask +getCurrentRoute = rheRoute `liftM` askHandlerEnv -- | Get the function to promote a route for a subsite to a route for the -- master site. getRouteToMaster :: GHandler sub master (Route sub -> Route master) -getRouteToMaster = (rheToMaster . handlerEnv) `liftM` ask +getRouteToMaster = rheToMaster `liftM` askHandlerEnv -- | Returns a function that runs 'GHandler' actions inside @IO@. @@ -400,7 +397,7 @@ setUltDestCurrent = do Nothing -> return () Just r -> do tm <- getRouteToMaster - gets' <- reqGetParams `liftM` handlerRequest `liftM` ask + gets' <- reqGetParams `liftM` askYesodRequest setUltDest (tm r, gets') -- | Sets the ultimate destination to the referer request header, if present. @@ -709,7 +706,7 @@ hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml hamletToRepHtml = liftM RepHtml . hamletToContent -- | Get the request\'s 'W.Request' value. -waiRequest :: GHandler sub master W.Request +waiRequest :: HandlerReader m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest getMessageRender :: RenderMessage master message => GHandler s master (message -> Text) @@ -747,9 +744,6 @@ cached f = do cinsert :: Typeable a => a -> Cache -> Cache cinsert v (Cache m) = Cache (Map.insert (typeOf v) (toDyn v) m) -ask :: GHandler sub master (HandlerData sub master) -ask = GHandler return - -- | Get the list of supported languages supplied by the user. -- -- Languages are determined based on the following three (in descending order diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 0285a672..f6501cc7 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -91,6 +91,7 @@ library exposed-modules: Yesod.Content Yesod.Core Yesod.Core.Json + Yesod.Core.Handler.Class Yesod.Dispatch Yesod.Handler Yesod.Widget From 2c2ee10dd7151516f8c7c025c418153ec75880d5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 07:08:03 +0200 Subject: [PATCH 026/165] Converted Yesod.Handler to typeclasses --- yesod-core/Yesod/Core.hs | 2 + yesod-core/Yesod/Core/Class.hs | 2 +- yesod-core/Yesod/Core/Handler/Class.hs | 36 ++-- yesod-core/Yesod/Core/Json.hs | 3 +- yesod-core/Yesod/Dispatch.hs | 2 +- yesod-core/Yesod/Handler.hs | 286 +++++++++++++------------ yesod-core/Yesod/Internal/Core.hs | 2 +- yesod-core/Yesod/Widget.hs | 3 +- 8 files changed, 172 insertions(+), 164 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index ddbc2b68..0cd10eee 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -51,6 +51,7 @@ module Yesod.Core , module Yesod.Handler , module Yesod.Widget , module Yesod.Core.Json + , module Yesod.Core.Trans.Class , module Text.Shakespeare.I18N ) where @@ -61,6 +62,7 @@ import Yesod.Handler import Yesod.Widget import Yesod.Core.Json import Yesod.Core.Types +import Yesod.Core.Trans.Class import Text.Shakespeare.I18N import Control.Monad.Logger diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 5765ec3f..920028c2 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -6,7 +6,7 @@ module Yesod.Core.Class where import Control.Monad.Logger (logErrorS) import Yesod.Content -import Yesod.Handler hiding (getExpires, lift) +import Yesod.Handler hiding (getExpires) import Yesod.Routes.Class diff --git a/yesod-core/Yesod/Core/Handler/Class.hs b/yesod-core/Yesod/Core/Handler/Class.hs index 46cb8176..6d35112d 100644 --- a/yesod-core/Yesod/Core/Handler/Class.hs +++ b/yesod-core/Yesod/Core/Handler/Class.hs @@ -11,37 +11,34 @@ import Data.IORef.Lifted (atomicModifyIORef) import Control.Exception.Lifted (throwIO) class Monad m => HandlerReader m where - type HandlerReaderSub m - type HandlerReaderMaster m + type HandlerSub m + type HandlerMaster m askYesodRequest :: m YesodRequest - askHandlerEnv :: m (RunHandlerEnv (HandlerReaderSub m) (HandlerReaderMaster m)) + askHandlerEnv :: m (RunHandlerEnv (HandlerSub m) (HandlerMaster m)) instance HandlerReader (GHandler sub master) where - type HandlerReaderSub (GHandler sub master) = sub - type HandlerReaderMaster (GHandler sub master) = master + type HandlerSub (GHandler sub master) = sub + type HandlerMaster (GHandler sub master) = master askYesodRequest = GHandler $ return . handlerRequest askHandlerEnv = GHandler $ return . handlerEnv instance HandlerReader (GWidget sub master) where - type HandlerReaderSub (GWidget sub master) = sub - type HandlerReaderMaster (GWidget sub master) = master + type HandlerSub (GWidget sub master) = sub + type HandlerMaster (GWidget sub master) = master askYesodRequest = lift askYesodRequest askHandlerEnv = lift askHandlerEnv instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where - type HandlerReaderSub (t m) = HandlerReaderSub m - type HandlerReaderMaster (t m) = HandlerReaderMaster m + type HandlerSub (t m) = HandlerSub m + type HandlerMaster (t m) = HandlerMaster m askYesodRequest = lift askYesodRequest askHandlerEnv = lift askHandlerEnv class HandlerReader m => HandlerState m where - type HandlerStateSub m - type HandlerStateMaster m - stateGHState :: (GHState -> (a, GHState)) -> m a getGHState :: m GHState @@ -51,31 +48,22 @@ class HandlerReader m => HandlerState m where putGHState s = stateGHState $ const ((), s) instance HandlerState (GHandler sub master) where - type HandlerStateSub (GHandler sub master) = sub - type HandlerStateMaster (GHandler sub master) = master - stateGHState f = GHandler $ flip atomicModifyIORef f' . handlerState where f' z = let (x, y) = f z in (y, x) instance HandlerState (GWidget sub master) where - type HandlerStateSub (GWidget sub master) = sub - type HandlerStateMaster (GWidget sub master) = master - stateGHState = lift . stateGHState instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where - type HandlerStateSub (t m) = HandlerStateSub m - type HandlerStateMaster (t m) = HandlerStateMaster m - stateGHState = lift . stateGHState -class Monad m => HandlerError m where - handlerError :: ErrorResponse -> m a +class HandlerReader m => HandlerError m where + handlerError :: HandlerContents -> m a instance HandlerError (GHandler sub master) where - handlerError = throwIO . HCError + handlerError = throwIO instance HandlerError (GWidget sub master) where handlerError = lift . handlerError diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index d4e3eaa8..b4ca9c06 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -20,7 +20,8 @@ module Yesod.Core.Json , acceptsJson ) where -import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect) +import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect) +import Yesod.Core.Trans.Class (lift) import Yesod.Content ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) , RepJson (RepJson) diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index dc752019..6c4a0d6b 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -32,7 +32,7 @@ module Yesod.Dispatch import Control.Applicative ((<$>), (<*>)) import Prelude hiding (exp) import Yesod.Internal.Core -import Yesod.Handler hiding (lift) +import Yesod.Handler import Web.PathPieces import Language.Haskell.TH diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 3f5ba9a0..61f0257e 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -117,7 +117,6 @@ module Yesod.Handler -- ** Misc , newIdent -- * Lifting - , MonadLift (..) , handlerToIO -- * i18n , getMessageRender @@ -130,53 +129,52 @@ module Yesod.Handler , ErrorResponse (..) ) where -import Prelude hiding (catch) -import Yesod.Core.Internal.Request -import Data.Time (UTCTime, getCurrentTime, addUTCTime) +import Data.Time (UTCTime, addUTCTime, + getCurrentTime) +import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, + mkFileInfoLBS, mkFileInfoSource) -import Control.Exception hiding (Handler, catch, finally) -import Control.Applicative +import Control.Applicative ((<$>)) -import Control.Monad (liftM) +import Control.Monad (liftM) -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource (MonadResource, liftResourceT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Resource (MonadResource, liftResourceT) -import qualified Network.Wai as W -import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types as H +import qualified Network.Wai as W -import Text.Hamlet +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html.Renderer.Text as RenderText -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as TL +import Text.Hamlet (Html, HtmlUrl, hamlet) -import qualified Data.Map as Map -import qualified Data.ByteString as S +import qualified Data.ByteString as S +import qualified Data.Map as Map -import Yesod.Content -import Data.Maybe (mapMaybe) -import Web.Cookie (SetCookie (..)) -import Control.Arrow ((***)) -import qualified Network.Wai.Parse as NWP -import Data.Monoid (mappend, mempty, Endo (..)) -import qualified Data.ByteString.Char8 as S8 -import Data.Text (Text) -import Text.Shakespeare.I18N (RenderMessage (..)) +import Control.Arrow ((***)) +import qualified Data.ByteString.Char8 as S8 +import Data.Maybe (mapMaybe) +import Data.Monoid (Endo (..), mappend, mempty) +import Data.Text (Text) +import qualified Network.Wai.Parse as NWP +import Text.Shakespeare.I18N (RenderMessage (..)) +import Web.Cookie (SetCookie (..)) +import Yesod.Content (HasReps, chooseRep, + formatRFC1123, toContent) -import Text.Blaze.Html (toHtml, preEscapedToMarkup) -#define preEscapedText preEscapedToMarkup +import Text.Blaze.Html (preEscapedToMarkup, toHtml) -import qualified Data.IORef as I -import Control.Monad.Trans.Resource (ResourceT, runResourceT) -import Yesod.Routes.Class (Route) -import Yesod.Core.Types -import Yesod.Core.Trans.Class -import Data.Maybe (listToMaybe) -import Data.Typeable (Typeable, typeOf) -import Data.Dynamic (fromDynamic, toDyn) -import Yesod.Core.Handler.Class +import Control.Monad.Trans.Resource (ResourceT, runResourceT) +import Data.Dynamic (fromDynamic, toDyn) +import qualified Data.IORef as I +import Data.Maybe (listToMaybe) +import Data.Typeable (Typeable, typeOf) +import Yesod.Core.Handler.Class +import Yesod.Core.Types +import Yesod.Routes.Class (Route) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y @@ -194,7 +192,7 @@ tell :: HandlerState m => Endo [Header] -> m () tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } hcError :: HandlerError m => ErrorResponse -> m a -hcError = handlerError +hcError = handlerError . HCError class SubsiteGetter g m s | g -> s where runSubsiteGetter :: g -> m s @@ -254,32 +252,33 @@ rbHelper' backend mkFI req = go = decodeUtf8With lenientDecode -- | Get the sub application argument. -getYesodSub :: HandlerReader m => m (HandlerReaderSub m) +getYesodSub :: HandlerReader m => m (HandlerSub m) getYesodSub = rheSub `liftM` askHandlerEnv -- | Get the master site appliation argument. -getYesod :: HandlerReader m => m (HandlerReaderMaster m) +getYesod :: HandlerReader m => m (HandlerMaster m) getYesod = rheMaster `liftM` askHandlerEnv -- | Get the URL rendering function. -getUrlRender :: GHandler sub master (Route master -> Text) +getUrlRender :: HandlerReader m => m (Route (HandlerMaster m) -> Text) getUrlRender = do x <- rheRender `liftM` askHandlerEnv return $ flip x [] -- | The URL rendering function with query-string parameters. getUrlRenderParams - :: GHandler sub master (Route master -> [(Text, Text)] -> Text) + :: HandlerReader m + => m (Route (HandlerMaster m) -> [(Text, Text)] -> Text) getUrlRenderParams = rheRender `liftM` askHandlerEnv -- | 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'. -getCurrentRoute :: GHandler sub master (Maybe (Route sub)) +getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSub m))) getCurrentRoute = rheRoute `liftM` askHandlerEnv -- | Get the function to promote a route for a subsite to a route for the -- master site. -getRouteToMaster :: GHandler sub master (Route sub -> Route master) +getRouteToMaster :: HandlerReader m => m (Route (HandlerSub m) -> Route (HandlerMaster m)) getRouteToMaster = rheToMaster `liftM` askHandlerEnv @@ -359,7 +358,8 @@ handlerToIO = -- -- If you want direct control of the final status code, or need a different -- status code, please use 'redirectWith'. -redirect :: RedirectUrl master url => url -> GHandler sub master a +redirect :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m) + => url -> m a redirect url = do req <- waiRequest let status = @@ -369,10 +369,13 @@ redirect url = do redirectWith status url -- | Redirect to the given URL with the specified status code. -redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a +redirectWith :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m) + => H.Status + -> url + -> m a redirectWith status url = do urlText <- toTextUrl url - liftIO $ throwIO $ HCRedirect status urlText + handlerError $ HCRedirect status urlText ultDestKey :: Text ultDestKey = "_ULT" @@ -381,7 +384,9 @@ ultDestKey = "_ULT" -- -- An ultimate destination is stored in the user session and can be loaded -- later by 'redirectUltDest'. -setUltDest :: RedirectUrl master url => url -> GHandler sub master () +setUltDest :: (HandlerState m, RedirectUrl (HandlerMaster m) url) + => url + -> m () setUltDest url = do urlText <- toTextUrl url setSession ultDestKey urlText @@ -390,7 +395,7 @@ setUltDest url = do -- -- If this is a 404 handler, there is no current page, and then this call does -- nothing. -setUltDestCurrent :: GHandler sub master () +setUltDestCurrent :: HandlerState m => m () setUltDestCurrent = do route <- getCurrentRoute case route of @@ -403,7 +408,7 @@ setUltDestCurrent = do -- | Sets the ultimate destination to the referer request header, if present. -- -- This function will not overwrite an existing ultdest. -setUltDestReferer :: GHandler sub master () +setUltDestReferer :: HandlerState m => m () setUltDestReferer = do mdest <- lookupSession ultDestKey maybe @@ -420,16 +425,16 @@ setUltDestReferer = do -- -- This function uses 'redirect', and thus will perform a temporary redirect to -- a GET request. -redirectUltDest :: RedirectUrl master url +redirectUltDest :: (RedirectUrl (HandlerMaster m) url, HandlerState m, HandlerError m) => url -- ^ default destination if nothing in session - -> GHandler sub master a + -> m a redirectUltDest def = do mdest <- lookupSession ultDestKey deleteSession ultDestKey maybe (redirect def) redirect mdest -- | Remove a previously set ultimate destination. See 'setUltDest'. -clearUltDest :: GHandler sub master () +clearUltDest :: HandlerState m => m () clearUltDest = deleteSession ultDestKey msgKey :: Text @@ -438,13 +443,14 @@ msgKey = "_MSG" -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessage :: Html -> GHandler sub master () +setMessage :: HandlerState m => Html -> m () setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml -- | Sets a message in the user's session. -- -- See 'getMessage'. -setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y () +setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg) + => msg -> m () setMessageI msg = do mr <- getMessageRender setMessage $ toHtml $ mr msg @@ -453,9 +459,9 @@ setMessageI msg = do -- variable. -- -- See 'setMessage'. -getMessage :: GHandler sub master (Maybe Html) +getMessage :: HandlerState m => m (Maybe Html) getMessage = do - mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey + mmsg <- liftM (fmap preEscapedToMarkup) $ lookupSession msgKey deleteSession msgKey return mmsg @@ -463,71 +469,72 @@ getMessage = do -- -- 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 fp = liftIO . throwIO $ HCSendFile ct fp Nothing +sendFile :: HandlerError m => ContentType -> FilePath -> m a +sendFile ct fp = handlerError $ HCSendFile ct fp Nothing -- | Same as 'sendFile', but only sends part of a file. -sendFilePart :: ContentType +sendFilePart :: HandlerError m + => ContentType -> FilePath -> Integer -- ^ offset -> Integer -- ^ count - -> GHandler sub master a + -> m a sendFilePart ct fp off count = - liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count + handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count -- | Bypass remaining handler code and output the given content with a 200 -- status code. -sendResponse :: HasReps c => c -> GHandler sub master a -sendResponse = liftIO . throwIO . HCContent H.status200 - . chooseRep +sendResponse :: (HandlerError m, HasReps c) => c -> m a +sendResponse = handlerError . HCContent H.status200 . chooseRep -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a -sendResponseStatus s = liftIO . throwIO . HCContent s - . chooseRep +sendResponseStatus :: (HandlerError m, HasReps c) => H.Status -> c -> m a +sendResponseStatus s = handlerError . HCContent s . chooseRep -- | Send a 201 "Created" response with the given route as the Location -- response header. -sendResponseCreated :: Route m -> GHandler s m a +sendResponseCreated :: HandlerError m => Route (HandlerMaster m) -> m a sendResponseCreated url = do r <- getUrlRender - liftIO . throwIO $ HCCreated $ r url + handlerError $ HCCreated $ r url -- | Send a 'W.Response'. Please note: this function is rarely -- necessary, and will /disregard/ any changes to response headers and session -- that you have already specified. This function short-circuits. It should be -- considered only for very specific needs. If you are not sure if you need it, -- you don't. -sendWaiResponse :: W.Response -> GHandler s m b -sendWaiResponse = liftIO . throwIO . HCWai +sendWaiResponse :: HandlerError m => W.Response -> m b +sendWaiResponse = handlerError . HCWai -- | Return a 404 not found page. Also denotes no handler available. -notFound :: GHandler sub master a +notFound :: HandlerError m => m a notFound = hcError NotFound -- | Return a 405 method not supported page. -badMethod :: GHandler sub master a +badMethod :: HandlerError m => m a badMethod = do w <- waiRequest hcError $ BadMethod $ W.requestMethod w -- | Return a 403 permission denied page. -permissionDenied :: Text -> GHandler sub master a +permissionDenied :: HandlerError m => Text -> m a permissionDenied = hcError . PermissionDenied -- | Return a 403 permission denied page. -permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a +permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m) + => msg + -> m a permissionDeniedI msg = do mr <- getMessageRender permissionDenied $ mr msg -- | Return a 400 invalid arguments page. -invalidArgs :: [Text] -> GHandler sub master a +invalidArgs :: HandlerError m => [Text] -> m a invalidArgs = hcError . InvalidArgs -- | Return a 400 invalid arguments page. -invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a +invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a invalidArgsI msg = do mr <- getMessageRender invalidArgs $ map mr msg @@ -535,13 +542,13 @@ invalidArgsI msg = do ------- Headers -- | Set the cookie on the client. -setCookie :: SetCookie - -> GHandler sub master () +setCookie :: HandlerState m => SetCookie -> m () setCookie = addHeader . AddCookie -- | Helper function for setCookieExpires value -getExpires :: Int -- ^ minutes - -> IO UTCTime +getExpires :: MonadIO m + => Int -- ^ minutes + -> m UTCTime getExpires m = do now <- liftIO getCurrentTime return $ fromIntegral (m * 60) `addUTCTime` now @@ -551,27 +558,28 @@ getExpires m = do -- -- Note: although the value used for key and path is 'Text', you should only -- use ASCII values to be HTTP compliant. -deleteCookie :: Text -- ^ key +deleteCookie :: HandlerState m + => Text -- ^ key -> Text -- ^ path - -> GHandler sub master () + -> m () deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8 -- | Set the language in the user session. Will show up in 'languages' on the -- next request. -setLanguage :: Text -> GHandler sub master () +setLanguage :: HandlerState m => Text -> m () setLanguage = setSession langKey -- | Set an arbitrary response header. -- -- Note that, while the data type used here is 'Text', you must provide only -- ASCII value to be HTTP compliant. -setHeader :: Text -> Text -> GHandler sub master () +setHeader :: HandlerState m => Text -> Text -> m () setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8 -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. -cacheSeconds :: Int -> GHandler s m () +cacheSeconds :: HandlerState m => Int -> m () cacheSeconds i = setHeader "Cache-Control" $ T.concat [ "max-age=" , T.pack $ show i @@ -580,16 +588,16 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat -- | Set the Expires header to some date in 2037. In other words, this content -- is never (realistically) expired. -neverExpires :: GHandler s m () +neverExpires :: HandlerState m => m () neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT" -- | Set an Expires header in the past, meaning this content should not be -- cached. -alreadyExpired :: GHandler s m () +alreadyExpired :: HandlerState m => m () alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" -- | Set an Expires header to the given date. -expiresAt :: UTCTime -> GHandler s m () +expiresAt :: HandlerState m => UTCTime -> m () expiresAt = setHeader "Expires" . formatRFC1123 -- | Set a variable in the user's session. @@ -597,38 +605,40 @@ expiresAt = setHeader "Expires" . formatRFC1123 -- The session is handled by the clientsession package: it sets an encrypted -- and hashed cookie on the client. This ensures that all data is secure and -- not tampered with. -setSession :: Text -- ^ key +setSession :: HandlerState m + => Text -- ^ key -> Text -- ^ value - -> GHandler sub master () + -> m () setSession k = setSessionBS k . encodeUtf8 -- | Same as 'setSession', but uses binary data for the value. -setSessionBS :: Text +setSessionBS :: HandlerState m + => Text -> S.ByteString - -> GHandler sub master () + -> m () setSessionBS k = modify . modSession . Map.insert k -- | Unsets a session variable. See 'setSession'. -deleteSession :: Text -> GHandler sub master () +deleteSession :: HandlerState m => Text -> m () deleteSession = modify . modSession . Map.delete -- | Clear all session variables. -- -- Since: 1.0.1 -clearSession :: GHandler sub master () +clearSession :: HandlerState m => m () clearSession = modify $ \x -> x { ghsSession = Map.empty } modSession :: (SessionMap -> SessionMap) -> GHState -> GHState modSession f x = x { ghsSession = f $ ghsSession x } -- | Internal use only, not to be confused with 'setHeader'. -addHeader :: Header -> GHandler sub master () +addHeader :: HandlerState m => Header -> m () addHeader = tell . Endo . (:) -- | Some value which can be turned into a URL for redirects. class RedirectUrl master a where -- | Converts the value to the URL and a list of query-string parameters. - toTextUrl :: a -> GHandler sub master Text + toTextUrl :: (HandlerReader m, HandlerMaster m ~ master) => a -> m Text instance RedirectUrl master Text where toTextUrl = return @@ -650,21 +660,21 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k toTextUrl (url, params) = toTextUrl (url, Map.toList params) -- | Lookup for session data. -lookupSession :: Text -> GHandler s m (Maybe Text) -lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS +lookupSession :: HandlerState m => Text -> m (Maybe Text) +lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS -- | Lookup for session data in binary format. -lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString) +lookupSessionBS :: HandlerState m => Text -> m (Maybe S.ByteString) lookupSessionBS n = do m <- liftM ghsSession get return $ Map.lookup n m -- | Get all session variables. -getSession :: GHandler sub master SessionMap +getSession :: HandlerState m => m SessionMap getSession = liftM ghsSession get -- | Get a unique identifier. -newIdent :: GHandler sub master Text +newIdent :: HandlerState m => m Text newIdent = do x <- get let i' = ghsIdent x + 1 @@ -677,7 +687,9 @@ newIdent = do -- POST form, and some Javascript to automatically submit the form. This can be -- useful when you need to post a plain link somewhere that needs to cause -- changes on the server. -redirectToPost :: RedirectUrl master url => url -> GHandler sub master a +redirectToPost :: (HandlerError m, RedirectUrl (HandlerMaster m) url) + => url + -> m a redirectToPost url = do urlText <- toTextUrl url hamletToRepHtml [hamlet| @@ -696,20 +708,21 @@ $doctype 5 -- | Converts the given Hamlet template into 'Content', which can be used in a -- Yesod 'Response'. -hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content +hamletToContent :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m Content hamletToContent h = do render <- getUrlRenderParams return $ toContent $ h render -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml +hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m RepHtml hamletToRepHtml = liftM RepHtml . hamletToContent -- | Get the request\'s 'W.Request' value. waiRequest :: HandlerReader m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest -getMessageRender :: RenderMessage master message => GHandler s master (message -> Text) +getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message) + => m (message -> Text) getMessageRender = do m <- getYesod l <- reqLangs `liftM` getRequest @@ -720,9 +733,9 @@ getMessageRender = do -- newtype wrappers to distinguish logically different types. -- -- Since 1.2.0 -cached :: Typeable a - => GHandler sub master a - -> GHandler sub master a +cached :: (HandlerState m, Typeable a) + => m a + -> m a cached f = do gs <- get let cache = ghsCache gs @@ -761,50 +774,53 @@ cached f = do -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed). -languages :: GHandler s m [Text] +languages :: HandlerReader m => m [Text] languages = reqLangs `liftM` getRequest lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup for GET parameters. -lookupGetParams :: Text -> GHandler s m [Text] +lookupGetParams :: HandlerReader m => Text -> m [Text] lookupGetParams pn = do rr <- getRequest return $ lookup' pn $ reqGetParams rr -- | Lookup for GET parameters. -lookupGetParam :: Text -> GHandler s m (Maybe Text) +lookupGetParam :: HandlerReader m => Text -> m (Maybe Text) lookupGetParam = liftM listToMaybe . lookupGetParams -- | Lookup for POST parameters. -lookupPostParams :: Text -> GHandler s m [Text] +lookupPostParams :: (MonadResource m, HandlerState m) => Text -> m [Text] lookupPostParams pn = do (pp, _) <- runRequestBody return $ lookup' pn pp -lookupPostParam :: Text - -> GHandler s m (Maybe Text) +lookupPostParam :: (MonadResource m, HandlerState m) + => Text + -> m (Maybe Text) lookupPostParam = liftM listToMaybe . lookupPostParams -- | Lookup for POSTed files. -lookupFile :: Text - -> GHandler s m (Maybe FileInfo) +lookupFile :: (HandlerState m, MonadResource m) + => Text + -> m (Maybe FileInfo) lookupFile = liftM listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: Text - -> GHandler s m [FileInfo] +lookupFiles :: (HandlerState m, MonadResource m) + => Text + -> m [FileInfo] lookupFiles pn = do (_, files) <- runRequestBody return $ lookup' pn files -- | Lookup for cookie data. -lookupCookie :: Text -> GHandler s m (Maybe Text) +lookupCookie :: HandlerReader m => Text -> m (Maybe Text) lookupCookie = liftM listToMaybe . lookupCookies -- | Lookup for cookie data. -lookupCookies :: Text -> GHandler s m [Text] +lookupCookies :: HandlerReader m => Text -> m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 4a8a3a4e..1e330eb7 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -41,7 +41,7 @@ module Yesod.Internal.Core ) where import Yesod.Content -import Yesod.Handler hiding (lift, getExpires) +import Yesod.Handler hiding (getExpires) import Yesod.Routes.Class diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 9dbb4acb..7391c841 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -53,8 +53,9 @@ import Text.Julius import Yesod.Routes.Class import Yesod.Handler ( YesodSubRoute(..), getYesod - , getMessageRender, getUrlRenderParams, MonadLift (..) + , getMessageRender, getUrlRenderParams ) +import Yesod.Core.Trans.Class (lift) import Text.Shakespeare.I18N (RenderMessage) import Yesod.Content (toContent) import Control.Monad (liftM) From e673c1f35e67a3d346f0519311dbc87f67770d27 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 07:23:30 +0200 Subject: [PATCH 027/165] Removed some subsite stuff --- yesod-core/Yesod/Core.hs | 1 + yesod-core/Yesod/Core/Class.hs | 3 +- yesod-core/Yesod/Handler.hs | 40 +++++++------------------- yesod-core/Yesod/Internal/Core.hs | 4 +-- yesod-core/Yesod/Widget.hs | 23 ++++++++------- yesod-core/test/YesodCoreTest/Media.hs | 3 +- 6 files changed, 27 insertions(+), 47 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 0cd10eee..76e19fd1 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -11,6 +11,7 @@ module Yesod.Core -- * Types , Approot (..) , FileUpload (..) + , ErrorResponse (..) -- * Utitlities , maybeAuthorized , widgetToPageContent diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 920028c2..347d39b4 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -287,8 +287,7 @@ $doctype 5 yesodMiddleware handler = do setHeader "Vary" "Accept, Accept-Language" route <- getCurrentRoute - toMaster <- getRouteToMaster - case fmap toMaster route of + case route of Nothing -> handler Just url -> do isWrite <- isWriteRequest url diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 61f0257e..b8379b5a 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -25,16 +25,15 @@ -- --------------------------------------------------------- module Yesod.Handler - ( -- * Type families - YesodSubRoute (..) - -- * Handler monad - , GHandler + ( -- * Handler monad + GHandler -- ** Read information from handler , getYesod , getYesodSub , getUrlRender , getUrlRenderParams , getCurrentRoute + , getCurrentRouteSub , getRouteToMaster , getRequest , waiRequest @@ -122,11 +121,6 @@ module Yesod.Handler , getMessageRender -- * Per-request caching , cached - -- * Internal Yesod - , YesodApp - , runSubsiteGetter - , HandlerData - , ErrorResponse (..) ) where import Data.Time (UTCTime, addUTCTime, @@ -136,7 +130,7 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, import Control.Applicative ((<$>)) -import Control.Monad (liftM) +import Control.Monad (ap, liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, liftResourceT) @@ -176,9 +170,6 @@ import Yesod.Core.Handler.Class import Yesod.Core.Types import Yesod.Routes.Class (Route) -class YesodSubRoute s y where - fromSubRoute :: s -> y -> Route s -> Route y - get :: HandlerState m => m GHState get = getGHState @@ -194,18 +185,6 @@ tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } hcError :: HandlerError m => ErrorResponse -> m a hcError = handlerError . HCError -class SubsiteGetter g m s | g -> s where - runSubsiteGetter :: g -> m s - -instance (master ~ master' - ) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where - runSubsiteGetter getter = getter <$> getYesod - -instance (anySub ~ anySub' - ,master ~ master' - ) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where - runSubsiteGetter = id - getRequest :: HandlerReader m => m YesodRequest getRequest = askYesodRequest @@ -273,8 +252,12 @@ getUrlRenderParams = rheRender `liftM` askHandlerEnv -- | 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'. -getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSub m))) -getCurrentRoute = rheRoute `liftM` askHandlerEnv +getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerMaster m))) +getCurrentRoute = fmap `liftM` getRouteToMaster `ap` getCurrentRouteSub + +-- | Same as 'getCurrentRoute', but for the subsite. +getCurrentRouteSub :: HandlerReader m => m (Maybe (Route (HandlerSub m))) +getCurrentRouteSub = rheRoute `liftM` askHandlerEnv -- | Get the function to promote a route for a subsite to a route for the -- master site. @@ -401,9 +384,8 @@ setUltDestCurrent = do case route of Nothing -> return () Just r -> do - tm <- getRouteToMaster gets' <- reqGetParams `liftM` askYesodRequest - setUltDest (tm r, gets') + setUltDest (r, gets') -- | Sets the ultimate destination to the referer request header, if present. -- diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 1e330eb7..a0bc2392 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -71,9 +71,7 @@ class YesodBreadcrumbs y where -- along with their respective titles. breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)]) breadcrumbs = do - x' <- getCurrentRoute - tm <- getRouteToMaster - let x = fmap tm x' + x <- getCurrentRoute case x of Nothing -> return ("Not found", []) Just y -> do diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 7391c841..62c54174 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -51,10 +51,7 @@ import Text.Hamlet import Text.Cassius import Text.Julius import Yesod.Routes.Class -import Yesod.Handler - ( YesodSubRoute(..), getYesod - , getMessageRender, getUrlRenderParams - ) +import Yesod.Handler (getMessageRender, getUrlRenderParams) import Yesod.Core.Trans.Class (lift) import Text.Shakespeare.I18N (RenderMessage) import Yesod.Content (toContent) @@ -74,13 +71,17 @@ import Yesod.Core.Types preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup -addSubWidget :: (YesodSubRoute sub master) => sub -> GWidget sub master a -> GWidget sub' master a -addSubWidget sub (GWidget w) = do - master <- lift getYesod - let sr = fromSubRoute sub master - (a, w') <- lift $ error "FIXME Yesod.Widget.toMasterHandlerMaybe" sr (const sub) Nothing w - tell w' - return a +addSubWidget :: (Route sub -> Route master) -> sub -> GWidget sub master a -> GWidget sub' master a +addSubWidget toMaster sub (GWidget (GHandler f)) = + GWidget $ GHandler $ f . modHD + where + modHD hd = hd + { handlerEnv = (handlerEnv hd) + { rheRoute = Nothing + , rheSub = sub + , rheToMaster = toMaster + } + } class ToWidget sub master a where toWidget :: a -> GWidget sub master () diff --git a/yesod-core/test/YesodCoreTest/Media.hs b/yesod-core/test/YesodCoreTest/Media.hs index 8f6053ec..1dc52dca 100644 --- a/yesod-core/test/YesodCoreTest/Media.hs +++ b/yesod-core/test/YesodCoreTest/Media.hs @@ -15,9 +15,8 @@ mkYesodDispatch "Y" resourcesY instance Yesod Y where addStaticContent _ _ content = do - tm <- getRouteToMaster route <- getCurrentRoute - case fmap tm route of + case route of Just StaticR -> return $ Just $ Left $ if content == "foo2{bar:baz}" then "screen.css" From 81ec09bf63549b3b0ee9456f8e3118ee4b66dd3e Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 07:29:43 +0200 Subject: [PATCH 028/165] Some more rearranging --- yesod-core/Yesod/Content.hs | 19 ----------------- .../Yesod/Core/{Time.hs => Internal/Util.hs} | 21 +++++++++++++++++-- yesod-core/Yesod/Core/Types.hs | 2 +- yesod-core/Yesod/Handler.hs | 9 ++------ yesod-core/Yesod/Internal/Session.hs | 2 +- yesod-core/yesod-core.cabal | 2 +- 6 files changed, 24 insertions(+), 31 deletions(-) rename yesod-core/Yesod/Core/{Time.hs => Internal/Util.hs} (53%) diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index 41f6d208..dcda9da9 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -40,10 +40,6 @@ module Yesod.Content , RepHtmlJson (..) , RepPlain (..) , RepXml (..) - -- * Utilities - , formatW3 - , formatRFC1123 - , formatRFC822 ) where import Data.Maybe (mapMaybe) @@ -52,9 +48,6 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T -import Data.Time -import System.Locale - import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding @@ -222,18 +215,6 @@ typeOctet = "application/octet-stream" simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.breakByte 59 -- 59 == ; --- | Format a 'UTCTime' in W3 format. -formatW3 :: UTCTime -> T.Text -formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00" - --- | Format as per RFC 1123. -formatRFC1123 :: UTCTime -> T.Text -formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" - --- | Format as per RFC 822. -formatRFC822 :: UTCTime -> T.Text -formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" - instance HasReps a => HasReps (DontFullyEvaluate a) where chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a diff --git a/yesod-core/Yesod/Core/Time.hs b/yesod-core/Yesod/Core/Internal/Util.hs similarity index 53% rename from yesod-core/Yesod/Core/Time.hs rename to yesod-core/Yesod/Core/Internal/Util.hs index 371159df..1e705795 100644 --- a/yesod-core/Yesod/Core/Time.hs +++ b/yesod-core/Yesod/Core/Internal/Util.hs @@ -1,12 +1,17 @@ -module Yesod.Core.Time +module Yesod.Core.Internal.Util ( putTime , getTime + , formatW3 + , formatRFC1123 + , formatRFC822 ) where import Data.Int (Int64) import Data.Serialize (Get, Put, Serialize (..)) +import qualified Data.Text as T import Data.Time (Day (ModifiedJulianDay, toModifiedJulianDay), - DiffTime, UTCTime (..)) + DiffTime, UTCTime (..), formatTime) +import System.Locale (defaultTimeLocale) putTime :: UTCTime -> Put putTime (UTCTime d t) = @@ -27,3 +32,15 @@ posixDayLength_int64 = 86400 diffTimeScale :: DiffTime diffTimeScale = 1e12 + +-- | Format a 'UTCTime' in W3 format. +formatW3 :: UTCTime -> T.Text +formatW3 = T.pack . formatTime defaultTimeLocale "%FT%X-00:00" + +-- | Format as per RFC 1123. +formatRFC1123 :: UTCTime -> T.Text +formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z" + +-- | Format as per RFC 822. +formatRFC822 :: UTCTime -> T.Text +formatRFC822 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index b8c3e1d9..f85084c0 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -50,7 +50,7 @@ import Text.Blaze.Html (Html) import Text.Hamlet (HtmlUrl) import Text.Julius (JavascriptUrl) import Web.Cookie (SetCookie) -import Yesod.Core.Time (getTime, putTime) +import Yesod.Core.Internal.Util (getTime, putTime) import Yesod.Core.Trans.Class (MonadLift (..)) import Yesod.Routes.Class (RenderRoute (..)) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index b8379b5a..dbf25d75 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -1,16 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Yesod.Handler @@ -157,8 +152,8 @@ import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) import Yesod.Content (HasReps, chooseRep, - formatRFC1123, toContent) - + toContent) +import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) import Control.Monad.Trans.Resource (ResourceT, runResourceT) diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 5d1c3cb2..ff9f93cc 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -14,7 +14,7 @@ import Data.ByteString (ByteString) import Control.Concurrent (forkIO, killThread, threadDelay) import Control.Monad (forever, guard) import Yesod.Core.Types -import Yesod.Core.Time +import Yesod.Core.Internal.Util import qualified Data.IORef as I encodeClientSession :: CS.Key diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index f6501cc7..84a52612 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -98,7 +98,7 @@ library Yesod.Core.Internal.Request other-modules: Yesod.Internal.Core Yesod.Internal.Session - Yesod.Core.Time + Yesod.Core.Internal.Util Yesod.Core.Trans.Class Yesod.Core.Run Yesod.Core.Class From d2f5ca449d819f5fe4d1fa1bd630e17f8beb8e31 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 09:08:34 +0200 Subject: [PATCH 029/165] selectRep/provideRep API --- yesod-core/Yesod/Handler.hs | 82 ++++++++++++++++++++++++++- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/Reps.hs | 53 +++++++++++++++++ 3 files changed, 135 insertions(+), 2 deletions(-) create mode 100644 yesod-core/test/YesodCoreTest/Reps.hs diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index dbf25d75..337ac3ec 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -74,6 +74,11 @@ module Yesod.Handler , sendResponseStatus , sendResponseCreated , sendWaiResponse + -- * Different representations + -- $representations + , selectRep + , provideRep + , ProvidedRep -- * Setting headers , setCookie , getExpires @@ -123,9 +128,10 @@ import Data.Time (UTCTime, addUTCTime, import Yesod.Core.Internal.Request (langKey, mkFileInfoFile, mkFileInfoLBS, mkFileInfoSource) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<|>)) import Control.Monad (ap, liftM) +import qualified Control.Monad.Trans.Writer as Writer import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, liftResourceT) @@ -152,7 +158,7 @@ import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) import Yesod.Content (HasReps, chooseRep, - toContent) + toContent, typePlain, simpleContentType) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) @@ -801,3 +807,75 @@ lookupCookies :: HandlerReader m => Text -> m [Text] lookupCookies pn = do rr <- getRequest return $ lookup' pn $ reqCookies rr + +-- $representations +-- +-- HTTP allows content negotation to determine what /representation/ of data +-- you would like to use. The most common example of this is providing both a +-- user-facing HTML page and an API facing JSON response from the same URL. The +-- means of achieving this is the Accept HTTP header, which provides a list of +-- content types the client will accept, sorted by preference. +-- +-- By using 'selectRep' and 'provideRep', you can provide a number of different +-- representations, e.g.: +-- +-- > selectRep $ do +-- > provideRep typeHtml $ produceHtmlOutput +-- > provideRep typeJson $ produceJsonOutput +-- +-- The first provided representation will be used if no matches are found. + +-- | Select a representation to send to the client based on the representations +-- provided inside this do-block. Should be used together with 'provideRep'. +-- +-- Since 1.2.0 +selectRep :: HandlerReader m + => Writer.Writer (Endo [ProvidedRep m]) () + -> m (ContentType, Content) +selectRep w = do + cts <- liftM reqAccept askYesodRequest + case mapMaybe tryAccept cts of + [] -> + case reps of + [] -> return (typePlain, "No reps provided to selectRep") + rep:_ -> returnRep rep + rep:_ -> returnRep rep + where + returnRep (ProvidedRep ct mcontent) = do + content <- mcontent + return (ct, content) + + reps = appEndo (Writer.execWriter w) [] + repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList + [ (k, v) + , (noSpace k, v) + , (simpleContentType k, v) + ]) reps + tryAccept ct = Map.lookup ct repMap <|> + Map.lookup (noSpace ct) repMap <|> + Map.lookup (simpleContentType ct) repMap + + -- Mime types such as "text/html; charset=foo" get converted to + -- "text/html;charset=foo" + noSpace = S8.filter (/= ' ') + +-- | Internal representation of a single provided representation. +-- +-- Since 1.2.0 +data ProvidedRep m = ProvidedRep !ContentType !(m Content) + +-- | Provide a single representation to be used, based on the request of the +-- client. Should be used together with 'selectRep'. +-- +-- Since 1.2.0 +provideRep :: (MonadIO m, HasReps a) + => ContentType + -> m a + -> Writer.Writer (Endo [ProvidedRep m]) () +provideRep ct handler = + Writer.tell $ Endo $ (ProvidedRep ct (grabContent handler):) + where + grabContent f = do + rep <- f + (_, content) <- liftIO $ chooseRep rep [ct] + return content diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 58bf0325..dc220d33 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -14,6 +14,7 @@ import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json +import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth import Test.Hspec @@ -34,4 +35,5 @@ specs = do JsLoader.specs RequestBodySize.specs Json.specs + Reps.specs Auth.specs diff --git a/yesod-core/test/YesodCoreTest/Reps.hs b/yesod-core/test/YesodCoreTest/Reps.hs new file mode 100644 index 00000000..903c66ec --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Reps.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +module YesodCoreTest.Reps (specs, Widget) where + +import Yesod.Core +import Test.Hspec +import Network.Wai +import Network.Wai.Test +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Char8 as S8 +import Data.String (IsString) + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +instance Yesod App + +specialHtml :: IsString a => a +specialHtml = "text/html; charset=special" + +getHomeR :: Handler (ContentType, Content) +getHomeR = selectRep $ do + provideRep typeHtml $ return $ RepPlain "HTML" + provideRep specialHtml $ return $ RepPlain "HTMLSPECIAL" + provideRep typeJson $ return $ RepPlain "JSON" + provideRep typeXml $ return $ RepPlain "XML" + +test :: String -- ^ accept header + -> ByteString -- ^ expected body + -> Spec +test accept expected = it accept $ do + app <- toWaiApp App + flip runSession app $ do + sres <- request defaultRequest + { requestHeaders = [("Accept", S8.pack accept)] + } + assertBody expected sres + assertStatus 200 sres + +specs :: Spec +specs = describe "selectRep" $ do + test "application/json" "JSON" + test (S8.unpack typeJson) "JSON" + test "text/xml" "XML" + test (S8.unpack typeXml) "XML" + test "text/xml,application/json" "XML" + test "text/foo" "HTML" + test "text/xml;q=0.9,application/json;q=1.0" "JSON" + test (S8.unpack typeHtml) "HTML" + test "text/html" "HTML" + test specialHtml "HTMLSPECIAL" From 1d0cac6e03a75d48d043bdd2227e32b9042ee7a9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 10:45:01 +0200 Subject: [PATCH 030/165] TypedContent --- yesod-core/Yesod/Content.hs | 146 ++++++++++++-------- yesod-core/Yesod/Core/Class.hs | 8 +- yesod-core/Yesod/Core/Json.hs | 21 ++- yesod-core/Yesod/Core/Run.hs | 14 +- yesod-core/Yesod/Core/Types.hs | 11 +- yesod-core/Yesod/Dispatch.hs | 4 +- yesod-core/Yesod/Handler.hs | 46 +++--- yesod-core/Yesod/Internal/Core.hs | 2 +- yesod-core/test/YesodCoreTest/Exceptions.hs | 2 +- yesod-core/test/YesodCoreTest/Reps.hs | 12 +- 10 files changed, 149 insertions(+), 117 deletions(-) diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index dcda9da9..383a54c1 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} @@ -31,22 +33,26 @@ module Yesod.Content -- * Evaluation strategy , DontFullyEvaluate (..) -- * Representations - , ChooseRep - , HasReps (..) - , defChooseRep + , TypedContent (..) + , ToTypedContent (..) + , HasContentType (..) -- ** Specific content types , RepHtml (..) , RepJson (..) - , RepHtmlJson (..) , RepPlain (..) , RepXml (..) + -- ** Smart constructors + , repHtml + , repJson + , repPlain + , repXml ) where -import Data.Maybe (mapMaybe) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text, pack) import qualified Data.Text as T +import Control.Monad (liftM) import qualified Data.Text.Encoding import qualified Data.Text.Lazy.Encoding @@ -80,6 +86,8 @@ emptyContent = ContentBuilder mempty $ Just 0 class ToContent a where toContent :: a -> Content +instance ToContent Content where + toContent = id instance ToContent Builder where toContent = flip ContentBuilder Nothing instance ToContent B.ByteString where @@ -94,6 +102,12 @@ instance ToContent String where toContent = toContent . pack instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing +instance ToContent () where + toContent () = toContent B.empty +instance ToContent (ContentType, Content) where + toContent = snd +instance ToContent TypedContent where + toContent (TypedContent _ c) = c instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where toContent src = ContentSource $ mapOutput toFlushBuilder src @@ -106,61 +120,37 @@ instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString --- | Any type which can be converted to representations. -class HasReps a where - chooseRep :: a -> ChooseRep +repHtml :: ToContent a => a -> RepHtml +repHtml = RepHtml . toContent --- | A helper method for generating 'HasReps' instances. --- --- This function should be given a list of pairs of content type and conversion --- functions. If none of the content types match, the first pair is used. -defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep -defChooseRep reps a ts = do - let (ct, c) = - case mapMaybe helper ts of - (x:_) -> x - [] -> case reps of - [] -> error "Empty reps to defChooseRep" - (x:_) -> x - c' <- c a - return (ct, c') - where - helper ct = do - c <- lookup ct reps - return (ct, c) +repJson :: ToContent a => a -> RepJson +repJson = RepJson . toContent -instance HasReps ChooseRep where - chooseRep = id +repPlain :: ToContent a => a -> RepPlain +repPlain = RepPlain . toContent -instance HasReps () where - chooseRep = defChooseRep [(typePlain, const $ return $ toContent B.empty)] +repXml :: ToContent a => a -> RepXml +repXml = RepXml . toContent -instance HasReps (ContentType, Content) where - chooseRep = const . return +class ToTypedContent a => HasContentType a where + getContentType :: Monad m => m a -> ContentType -instance HasReps [(ContentType, Content)] where - chooseRep a cts = return $ - case filter (\(ct, _) -> go ct `elem` map go cts) a of - ((ct, c):_) -> (ct, c) - _ -> case a of - (x:_) -> x - _ -> error "chooseRep [(ContentType, Content)] of empty" - where - go = simpleContentType +instance HasContentType RepHtml where + getContentType _ = typeHtml +deriving instance ToContent RepHtml + +instance HasContentType RepJson where + getContentType _ = typeJson +deriving instance ToContent RepJson + +instance HasContentType RepPlain where + getContentType _ = typePlain +deriving instance ToContent RepPlain + +instance HasContentType RepXml where + getContentType _ = typeXml +deriving instance ToContent RepXml -instance HasReps RepHtml where - chooseRep (RepHtml c) _ = return (typeHtml, c) -instance HasReps RepJson where - chooseRep (RepJson c) _ = return (typeJson, c) -instance HasReps RepHtmlJson where - chooseRep (RepHtmlJson html json) = chooseRep - [ (typeHtml, html) - , (typeJson, json) - ] -instance HasReps RepPlain where - chooseRep (RepPlain c) _ = return (typePlain, c) -instance HasReps RepXml where - chooseRep (RepXml c) _ = return (typeXml, c) typeHtml :: ContentType typeHtml = "text/html; charset=utf-8" @@ -215,8 +205,8 @@ typeOctet = "application/octet-stream" simpleContentType :: ContentType -> ContentType simpleContentType = fst . B.breakByte 59 -- 59 == ; -instance HasReps a => HasReps (DontFullyEvaluate a) where - chooseRep (DontFullyEvaluate a) = fmap (fmap (fmap ContentDontEvaluate)) $ chooseRep a +instance HasContentType a => HasContentType (DontFullyEvaluate a) where + getContentType = getContentType . liftM unDontFullyEvaluate instance ToContent a => ToContent (DontFullyEvaluate a) where toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a @@ -226,3 +216,47 @@ instance ToContent J.Value where . Blaze.fromLazyText . toLazyText . fromValue +instance HasContentType J.Value where + getContentType _ = typeJson + +instance HasContentType Html where + getContentType _ = typeHtml + +instance HasContentType Text where + getContentType _ = typePlain + +instance HasContentType T.Text where + getContentType _ = typePlain + +-- | Any type which can be converted to 'TypedContent'. +-- +-- Since 1.2.0 +class ToContent a => ToTypedContent a where + toTypedContent :: a -> TypedContent + +instance ToTypedContent TypedContent where + toTypedContent = id +instance ToTypedContent () where + toTypedContent () = TypedContent typePlain (toContent ()) +instance ToTypedContent (ContentType, Content) where + toTypedContent (ct, content) = TypedContent ct content +instance ToTypedContent RepHtml where + toTypedContent (RepHtml c) = TypedContent typeHtml c +instance ToTypedContent RepJson where + toTypedContent (RepJson c) = TypedContent typeJson c +instance ToTypedContent RepPlain where + toTypedContent (RepPlain c) = TypedContent typePlain c +instance ToTypedContent RepXml where + toTypedContent (RepXml c) = TypedContent typeXml c +instance ToTypedContent J.Value where + toTypedContent v = TypedContent typeJson (toContent v) +instance ToTypedContent Html where + toTypedContent h = TypedContent typeHtml (toContent h) +instance ToTypedContent T.Text where + toTypedContent t = TypedContent typePlain (toContent t) +instance ToTypedContent Text where + toTypedContent t = TypedContent typePlain (toContent t) +instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where + toTypedContent (DontFullyEvaluate a) = + let TypedContent ct c = toTypedContent a + in TypedContent ct (ContentDontEvaluate c) diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index 347d39b4..e4362dc1 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -75,7 +75,7 @@ class RenderRoute a => Yesod a where approot = ApprootRelative -- | Output error response pages. - errorHandler :: ErrorResponse -> GHandler sub a ChooseRep + errorHandler :: ErrorResponse -> GHandler sub a TypedContent errorHandler = defaultErrorHandler -- | Applies some form of layout to the contents of a page. @@ -405,13 +405,13 @@ $newline never applyLayout' :: Yesod master => Html -- ^ title -> HtmlUrl (Route master) -- ^ body - -> GHandler sub master ChooseRep -applyLayout' title body = fmap chooseRep $ defaultLayout $ do + -> GHandler sub master TypedContent +applyLayout' title body = fmap toTypedContent $ defaultLayout $ do setTitle title toWidget body -- | The default error handler for 'errorHandler'. -defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep +defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y TypedContent defaultErrorHandler NotFound = do r <- waiRequest let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index b4ca9c06..2c751c6c 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -20,12 +20,9 @@ module Yesod.Core.Json , acceptsJson ) where -import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect) +import Yesod.Handler (GHandler, waiRequest, invalidArgs, redirect, selectRep, provideRep) import Yesod.Core.Trans.Class (lift) -import Yesod.Content - ( ToContent (toContent), RepHtmlJson (RepHtmlJson), RepHtml (RepHtml) - , RepJson (RepJson) - ) +import Yesod.Content (TypedContent) import Yesod.Internal.Core (defaultLayout, Yesod) import Yesod.Widget (GWidget) import Yesod.Routes.Class @@ -52,17 +49,17 @@ import Data.Maybe (listToMaybe) defaultLayoutJson :: (Yesod master, J.ToJSON a) => GWidget sub master () -- ^ HTML -> a -- ^ JSON - -> GHandler sub master RepHtmlJson -defaultLayoutJson w json = do - RepHtml html' <- defaultLayout w - return $ RepHtmlJson html' $ toContent (J.toJSON json) + -> GHandler sub master TypedContent +defaultLayoutJson w json = selectRep $ do + provideRep $ defaultLayout w + provideRep $ return $ J.toJSON json -- | Wraps a data type in a 'RepJson'. The data type must -- support conversion to JSON via 'J.ToJSON'. -- -- /Since: 0.3.0/ -jsonToRepJson :: J.ToJSON a => a -> GHandler sub master RepJson -jsonToRepJson = return . RepJson . toContent . J.toJSON +jsonToRepJson :: J.ToJSON a => a -> GHandler sub master J.Value +jsonToRepJson = return . J.toJSON -- | Parse the request body to a data type as a JSON value. The -- data type must support conversion from JSON via 'J.FromJSON'. @@ -108,7 +105,7 @@ array = J.Array . V.fromList . map J.toJSON jsonOrRedirect :: (Yesod master, J.ToJSON a) => Route master -- ^ Redirect target -> a -- ^ Data to send via JSON - -> GHandler sub master RepJson + -> GHandler sub master J.Value jsonOrRedirect r j = do q <- acceptsJson if q then jsonToRepJson (J.toJSON j) diff --git a/yesod-core/Yesod/Core/Run.hs b/yesod-core/Yesod/Core/Run.hs index e13356af..7518fed7 100644 --- a/yesod-core/Yesod/Core/Run.hs +++ b/yesod-core/Yesod/Core/Run.hs @@ -91,7 +91,7 @@ local f (GHandler x) = GHandler $ \r -> x $ f r -- | Function used internally by Yesod in the process of converting a -- 'GHandler' into an 'Application'. Should not be needed by users. -runHandler :: HasReps c +runHandler :: ToTypedContent c => RunHandlerEnv sub master -> GHandler sub master c -> YesodApp @@ -101,7 +101,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do Just (HCError x) -> x _ -> InternalError $ T.pack $ show e istate <- liftIO $ I.newIORef GHState - { ghsSession = initSession + { ghsSession = reqSession yreq , ghsRBC = Nothing , ghsIdent = 1 , ghsCache = mempty @@ -118,7 +118,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do state <- liftIO $ I.readIORef istate let finalSession = ghsSession state let headers = ghsHeaders state - let contents = either id (HCContent H.status200 . chooseRep) contents' + let contents = either id (HCContent H.status200 . toTypedContent) contents' let handleError e = do yar <- rheOnError e yreq { reqSession = finalSession @@ -131,8 +131,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do let sendFile' ct fp p = return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession case contents of - HCContent status a -> do - (ct, c) <- liftIO $ a cts + HCContent status (TypedContent ct c) -> do ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e @@ -160,9 +159,6 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = do emptyContent finalSession HCWai r -> return $ YRWai r - where - cts = reqAccept yreq - initSession = reqSession yreq safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse @@ -276,7 +272,7 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do defaultYesodRunner :: Yesod master => YesodRunnerEnv sub master - -> GHandler sub master ChooseRep + -> GHandler sub master TypedContent -> Application defaultYesodRunner YesodRunnerEnv {..} handler' req | KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index f85084c0..5e649e66 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -249,15 +249,10 @@ data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content an | ContentFile !FilePath !(Maybe FilePart) | ContentDontEvaluate !Content --- | A function which gives targetted representations of content based on the --- content-types the user accepts. -type ChooseRep = - [ContentType] -- ^ list of content-types user accepts, ordered by preference - -> IO (ContentType, Content) +data TypedContent = TypedContent !ContentType !Content newtype RepHtml = RepHtml Content newtype RepJson = RepJson Content -data RepHtmlJson = RepHtmlJson Content Content newtype RepPlain = RepPlain Content newtype RepXml = RepXml Content @@ -267,7 +262,7 @@ type ContentType = ByteString -- FIXME Text? -- request. -- -- Since 1.1.0 -newtype DontFullyEvaluate a = DontFullyEvaluate a +newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a } -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. @@ -327,7 +322,7 @@ instance Monoid (GWData a) where (a7 `mappend` b7) data HandlerContents = - HCContent H.Status ChooseRep + HCContent H.Status !TypedContent | HCError ErrorResponse | HCSendFile ContentType FilePath (Maybe FilePart) | HCRedirect H.Status Text diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 6c4a0d6b..b9f8cad3 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -52,7 +52,7 @@ import qualified Data.ByteString as S import qualified Blaze.ByteString.Builder import Network.HTTP.Types (status301) import Yesod.Routes.TH -import Yesod.Content (chooseRep) +import Yesod.Content (toTypedContent) import Yesod.Routes.Parse import System.Log.FastLogger (Logger) import Yesod.Core.Types @@ -151,7 +151,7 @@ mkDispatchInstance context sub master res = do Clause pat body decs <- mkDispatchClause [|yesodRunner $loggerE |] [|yesodDispatch $loggerE |] - [|fmap chooseRep|] + [|fmap toTypedContent|] res return $ FunD 'yesodDispatch [ Clause (loggerP:pat) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 337ac3ec..04e85740 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -78,6 +78,7 @@ module Yesod.Handler -- $representations , selectRep , provideRep + , provideRepType , ProvidedRep -- * Setting headers , setCookie @@ -157,8 +158,7 @@ import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) import Web.Cookie (SetCookie (..)) -import Yesod.Content (HasReps, chooseRep, - toContent, typePlain, simpleContentType) +import Yesod.Content (ToTypedContent (..), simpleContentType, HasContentType (..), ToContent (..)) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToMarkup, toHtml) @@ -467,13 +467,13 @@ sendFilePart ct fp off count = -- | Bypass remaining handler code and output the given content with a 200 -- status code. -sendResponse :: (HandlerError m, HasReps c) => c -> m a -sendResponse = handlerError . HCContent H.status200 . chooseRep +sendResponse :: (HandlerError m, ToTypedContent c) => c -> m a +sendResponse = handlerError . HCContent H.status200 . toTypedContent -- | Bypass remaining handler code and output the given content with the given -- status code. -sendResponseStatus :: (HandlerError m, HasReps c) => H.Status -> c -> m a -sendResponseStatus s = handlerError . HCContent s . chooseRep +sendResponseStatus :: (HandlerError m, ToTypedContent c) => H.Status -> c -> m a +sendResponseStatus s = handlerError . HCContent s . toTypedContent -- | Send a 201 "Created" response with the given route as the Location -- response header. @@ -831,19 +831,19 @@ lookupCookies pn = do -- Since 1.2.0 selectRep :: HandlerReader m => Writer.Writer (Endo [ProvidedRep m]) () - -> m (ContentType, Content) + -> m TypedContent selectRep w = do cts <- liftM reqAccept askYesodRequest case mapMaybe tryAccept cts of [] -> case reps of - [] -> return (typePlain, "No reps provided to selectRep") + [] -> return $ toTypedContent ("No reps provided to selectRep" :: Text) rep:_ -> returnRep rep rep:_ -> returnRep rep where returnRep (ProvidedRep ct mcontent) = do content <- mcontent - return (ct, content) + return $ TypedContent ct content reps = appEndo (Writer.execWriter w) [] repMap = Map.unions $ map (\v@(ProvidedRep k _) -> Map.fromList @@ -868,14 +868,22 @@ data ProvidedRep m = ProvidedRep !ContentType !(m Content) -- client. Should be used together with 'selectRep'. -- -- Since 1.2.0 -provideRep :: (MonadIO m, HasReps a) - => ContentType - -> m a +provideRep :: (MonadIO m, HasContentType a) + => m a -> Writer.Writer (Endo [ProvidedRep m]) () -provideRep ct handler = - Writer.tell $ Endo $ (ProvidedRep ct (grabContent handler):) - where - grabContent f = do - rep <- f - (_, content) <- liftIO $ chooseRep rep [ct] - return content +provideRep handler = provideRepType (getContentType handler) handler + +-- | Same as 'provideRep', but instead of determining the content type from the +-- type of the value itself, you provide the content type separately. This can +-- be a convenience instead of creating newtype wrappers for uncommonly used +-- content types. +-- +-- > provideRepType "application/x-special-format" "This is the content" +-- +-- Since 1.2.0 +provideRepType :: (MonadIO m, ToContent a) + => ContentType + -> m a + -> Writer.Writer (Endo [ProvidedRep m]) () +provideRepType ct handler = + Writer.tell $ Endo $ (ProvidedRep ct (liftM toContent handler):) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index a0bc2392..e7e5d753 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -114,7 +114,7 @@ class YesodDispatch sub master where yesodRunner :: Yesod master => Logger - -> GHandler sub master ChooseRep + -> GHandler sub master TypedContent -> master -> sub -> Maybe (Route sub) diff --git a/yesod-core/test/YesodCoreTest/Exceptions.hs b/yesod-core/test/YesodCoreTest/Exceptions.hs index d8ba52d2..3e0fcddf 100644 --- a/yesod-core/test/YesodCoreTest/Exceptions.hs +++ b/yesod-core/test/YesodCoreTest/Exceptions.hs @@ -18,7 +18,7 @@ mkYesod "Y" [parseRoutes| instance Yesod Y where approot = ApprootStatic "http://test" - errorHandler (InternalError e) = return $ chooseRep $ RepPlain $ toContent e + errorHandler (InternalError e) = return $ toTypedContent e errorHandler x = defaultErrorHandler x getRootR :: Handler () diff --git a/yesod-core/test/YesodCoreTest/Reps.hs b/yesod-core/test/YesodCoreTest/Reps.hs index 903c66ec..e2496b61 100644 --- a/yesod-core/test/YesodCoreTest/Reps.hs +++ b/yesod-core/test/YesodCoreTest/Reps.hs @@ -8,6 +8,7 @@ import Network.Wai.Test import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.String (IsString) +import Data.Text (Text) data App = App @@ -20,12 +21,13 @@ instance Yesod App specialHtml :: IsString a => a specialHtml = "text/html; charset=special" -getHomeR :: Handler (ContentType, Content) +getHomeR :: Handler TypedContent getHomeR = selectRep $ do - provideRep typeHtml $ return $ RepPlain "HTML" - provideRep specialHtml $ return $ RepPlain "HTMLSPECIAL" - provideRep typeJson $ return $ RepPlain "JSON" - provideRep typeXml $ return $ RepPlain "XML" + let go ct t = provideRepType ct $ return (t :: Text) + go typeHtml "HTML" + go specialHtml "HTMLSPECIAL" + go typeJson "JSON" + go typeXml "XML" test :: String -- ^ accept header -> ByteString -- ^ expected body From f3f55a1ecdfbbb0f61047f80b62a1f9dcfb7561d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 10:54:26 +0200 Subject: [PATCH 031/165] RepHtml is a synonym for Html --- yesod-core/Yesod/Content.hs | 12 +----------- yesod-core/Yesod/Core/Types.hs | 2 +- yesod-core/Yesod/Handler.hs | 24 ++++++++++++++---------- yesod-core/Yesod/Widget.hs | 5 ++--- 4 files changed, 18 insertions(+), 25 deletions(-) diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index 383a54c1..2c3ea2b7 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -37,12 +37,11 @@ module Yesod.Content , ToTypedContent (..) , HasContentType (..) -- ** Specific content types - , RepHtml (..) + , RepHtml , RepJson (..) , RepPlain (..) , RepXml (..) -- ** Smart constructors - , repHtml , repJson , repPlain , repXml @@ -120,9 +119,6 @@ instance ToFlushBuilder Builder where toFlushBuilder = Chunk instance ToFlushBuilder (Flush B.ByteString) where toFlushBuilder = fmap fromByteString instance ToFlushBuilder B.ByteString where toFlushBuilder = Chunk . fromByteString -repHtml :: ToContent a => a -> RepHtml -repHtml = RepHtml . toContent - repJson :: ToContent a => a -> RepJson repJson = RepJson . toContent @@ -135,10 +131,6 @@ repXml = RepXml . toContent class ToTypedContent a => HasContentType a where getContentType :: Monad m => m a -> ContentType -instance HasContentType RepHtml where - getContentType _ = typeHtml -deriving instance ToContent RepHtml - instance HasContentType RepJson where getContentType _ = typeJson deriving instance ToContent RepJson @@ -240,8 +232,6 @@ instance ToTypedContent () where toTypedContent () = TypedContent typePlain (toContent ()) instance ToTypedContent (ContentType, Content) where toTypedContent (ct, content) = TypedContent ct content -instance ToTypedContent RepHtml where - toTypedContent (RepHtml c) = TypedContent typeHtml c instance ToTypedContent RepJson where toTypedContent (RepJson c) = TypedContent typeJson c instance ToTypedContent RepPlain where diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 5e649e66..669fa141 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -251,7 +251,7 @@ data Content = ContentBuilder !BBuilder.Builder !(Maybe Int) -- ^ The content an data TypedContent = TypedContent !ContentType !Content -newtype RepHtml = RepHtml Content +type RepHtml = Html newtype RepJson = RepJson Content newtype RepPlain = RepPlain Content newtype RepXml = RepXml Content diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 04e85740..6e07dea0 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -112,8 +112,8 @@ module Yesod.Handler , getMessage -- * Helpers for specific content -- ** Hamlet - , hamletToContent , hamletToRepHtml + , giveUrlRenderer -- ** Misc , newIdent -- * Lifting @@ -689,16 +689,20 @@ $doctype 5 |] >>= sendResponse --- | Converts the given Hamlet template into 'Content', which can be used in a --- Yesod 'Response'. -hamletToContent :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m Content -hamletToContent h = do - render <- getUrlRenderParams - return $ toContent $ h render - -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. -hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m RepHtml -hamletToRepHtml = liftM RepHtml . hamletToContent +hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m Html +hamletToRepHtml = giveUrlRenderer + +-- | Provide a URL rendering function to the given function and return the +-- result. Useful for processing Shakespearean templates. +-- +-- Since 1.2.0 +giveUrlRenderer :: HandlerReader m + => ((Route (HandlerMaster m) -> [(Text, Text)] -> Text) -> output) + -> m output +giveUrlRenderer f = do + render <- getUrlRenderParams + return $ f render -- | Get the request\'s 'W.Request' value. waiRequest :: HandlerReader m => m W.Request diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 62c54174..c0099e49 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -54,7 +54,6 @@ import Yesod.Routes.Class import Yesod.Handler (getMessageRender, getUrlRenderParams) import Yesod.Core.Trans.Class (lift) import Text.Shakespeare.I18N (RenderMessage) -import Yesod.Content (toContent) import Control.Monad (liftM) import Data.Text (Text) import qualified Data.Map as Map @@ -217,11 +216,11 @@ rules = do -- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. ihamletToRepHtml :: RenderMessage master message => HtmlUrlI18n message (Route master) - -> GHandler sub master RepHtml + -> GHandler sub master Html ihamletToRepHtml ih = do urender <- getUrlRenderParams mrender <- getMessageRender - return $ RepHtml $ toContent $ ih (toHtml . mrender) urender + return $ ih (toHtml . mrender) urender tell :: GWData (Route master) -> GWidget sub master () tell w = GWidget $ return ((), w) From 0959194fb52ed0eac97e6274046e45d9f870ffa3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 10:57:35 +0200 Subject: [PATCH 032/165] Travis: do cabal update --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index a2a948b3..ea542176 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,7 @@ language: haskell install: + - cabal update - cabal install mega-sdist hspec cabal-meta cabal-src - cabal-meta install --force-reinstalls From 2af304bd7fe498859555a829717e83ca57499182 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 11 Mar 2013 11:10:00 +0200 Subject: [PATCH 033/165] Provide JSON reps for default error message handler (fixes #478) --- yesod-core/Yesod/Core/Class.hs | 93 +++++++++++++++++----------------- yesod-core/Yesod/Core/Json.hs | 4 +- 2 files changed, 48 insertions(+), 49 deletions(-) diff --git a/yesod-core/Yesod/Core/Class.hs b/yesod-core/Yesod/Core/Class.hs index e4362dc1..665477a6 100644 --- a/yesod-core/Yesod/Core/Class.hs +++ b/yesod-core/Yesod/Core/Class.hs @@ -19,6 +19,7 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO LogSource) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import Data.Aeson (object, (.=)) import Data.List (foldl') import Data.List (nub) import qualified Data.Map as Map @@ -54,6 +55,7 @@ import Web.Cookie (SetCookie (..)) import Yesod.Core.Types import Yesod.Internal.Session import Yesod.Widget +import Yesod.Core.Trans.Class (lift) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -401,57 +403,54 @@ $newline never runUniqueList :: Eq x => UniqueList x -> [x] runUniqueList (UniqueList x) = nub $ x [] --- | Helper function for 'defaultErrorHandler'. -applyLayout' :: Yesod master - => Html -- ^ title - -> HtmlUrl (Route master) -- ^ body - -> GHandler sub master TypedContent -applyLayout' title body = fmap toTypedContent $ defaultLayout $ do - setTitle title - toWidget body - -- | The default error handler for 'errorHandler'. defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y TypedContent -defaultErrorHandler NotFound = do - r <- waiRequest - let path' = TE.decodeUtf8With TEE.lenientDecode $ W.rawPathInfo r - applyLayout' "Not Found" - [hamlet| -$newline never -

Not Found -

#{path'} -|] -defaultErrorHandler (PermissionDenied msg) = - applyLayout' "Permission Denied" - [hamlet| -$newline never -

Permission denied -

#{msg} -|] -defaultErrorHandler (InvalidArgs ia) = - applyLayout' "Invalid Arguments" - [hamlet| -$newline never -

Invalid Arguments -