From 487e5c9bc44fe5d30de93a2cfbf2dbfedc1a3403 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 4 Apr 2012 07:12:05 +0300 Subject: [PATCH 001/250] Don't test for tiny --- yesod/test/scaffold_test.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod/test/scaffold_test.sh b/yesod/test/scaffold_test.sh index 0e0a121a..2597f502 100644 --- a/yesod/test/scaffold_test.sh +++ b/yesod/test/scaffold_test.sh @@ -4,4 +4,3 @@ teardown() { rm -rf foobar; ghc-pkg unregister foobar &>/dev/null; } test_sqlite() { ../test/scaffold.sh < ../test/sqlite-input.txt ; } test_postgresql() { ../test/scaffold.sh < ../test/postgresql-input.txt; } #test_mongodb() { ../test/scaffold.sh < ../test/mongodb-input.txt ; } -test_tiny() { ../test/scaffold.sh < ../test/tiny-input.txt ; } From c1ff148cfd263f05126d086cd55fdcaf33b946cd Mon Sep 17 00:00:00 2001 From: gregwebs Date: Wed, 4 Apr 2012 14:22:53 -0700 Subject: [PATCH 002/250] remove fromArgsWith from documentation --- yesod-default/Yesod/Default/Main.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/yesod-default/Yesod/Default/Main.hs b/yesod-default/Yesod/Default/Main.hs index 199b1f1d..a1e330f9 100644 --- a/yesod-default/Yesod/Default/Main.hs +++ b/yesod-default/Yesod/Default/Main.hs @@ -26,16 +26,10 @@ import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -- | Run your app, taking environment and port settings from the -- commandline. -- --- Use @'fromArgs'@ when using the provided @'DefaultEnv'@ type, or --- @'fromArgsWith'@ when using a custom type +-- @'fromArgs'@ helps parse a custom configuration -- -- > main :: IO () --- > main = defaultMain fromArgs withMySite --- --- or --- --- > main :: IO () --- > main = defaultMain (fromArgsWith customArgConfig) withMySite +-- > main = defaultMain (fromArgs parseExtra) makeApplication -- defaultMain :: (Show env, Read env) => IO (AppConfig env extra) From c2d4f15cad186b5bc058de6185a69ab87bb29757 Mon Sep 17 00:00:00 2001 From: Hiromi Ishii Date: Thu, 5 Apr 2012 16:23:25 +0900 Subject: [PATCH 003/250] removed extra file deps for qq.h --- yesod-auth-oauth/yesod-auth-oauth.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index d3c92cc5..88fe8a5d 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -10,7 +10,6 @@ stability: Stable cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/ -extra-source-files: include/qq.h description: Authentication for Yesod. flag ghc7 From f8c41eb5aca5653bea681796edbf4031c77052a8 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Apr 2012 22:39:39 +0300 Subject: [PATCH 004/250] Doc fix --- yesod-core/Yesod/Internal/Session.hs | 6 +++--- yesod-core/yesod-core.cabal | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-core/Yesod/Internal/Session.hs b/yesod-core/Yesod/Internal/Session.hs index 09f66f38..810f44e6 100644 --- a/yesod-core/Yesod/Internal/Session.hs +++ b/yesod-core/Yesod/Internal/Session.hs @@ -21,9 +21,9 @@ import qualified Network.Wai as W type BackendSession = [(Text, S8.ByteString)] -type SaveSession = BackendSession -> -- ^ The session contents after running the handler - UTCTime -> -- ^ current time - IO [Header] +type SaveSession = BackendSession -- ^ The session contents after running the handler + -> UTCTime -- ^ current time + -> IO [Header] newtype SessionBackend master = SessionBackend { sbLoadSession :: master diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 686ba6f6..8c86c9a8 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.0.0 +version: 1.0.0.1 license: MIT license-file: LICENSE author: Michael Snoyman From 110b4a2b45128d9fbbf100f7044b64a5cb20ed9f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Apr 2012 22:40:51 +0300 Subject: [PATCH 005/250] Relax some upper bounds --- yesod-form/yesod-form.cabal | 4 ++-- yesod-static/yesod-static.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index c53eb6e2..ecaa476e 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.0.0 +version: 1.0.0.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -23,7 +23,7 @@ library , persistent >= 0.9 && < 0.10 , template-haskell , transformers >= 0.2.2 && < 0.4 - , data-default >= 0.3 && < 0.4 + , data-default >= 0.3 && < 0.5 , xss-sanitize >= 0.3.0.1 && < 0.4 , blaze-builder >= 0.2.1.4 && < 0.4 , network >= 2.2 && < 2.4 diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 1c245c27..ec68235f 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.0.0 +version: 1.0.0.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -25,7 +25,7 @@ library , bytestring >= 0.9.1.4 && < 0.10 , template-haskell , directory >= 1.0 && < 1.2 - , transformers >= 0.2.2 && < 0.3 + , transformers >= 0.2.2 && < 0.4 , wai-app-static >= 1.2 && < 1.3 , wai >= 1.2 && < 1.3 , text >= 0.9 && < 1.0 From 687961cd22dba85b81b553b7056227eb27ffb21c Mon Sep 17 00:00:00 2001 From: Patrick Palka Date: Fri, 6 Apr 2012 12:16:03 -0400 Subject: [PATCH 006/250] [scaffold] refactor uses of CPP into pure Haskell --- yesod/scaffold/Application.hs.cg | 16 +++------------- yesod/scaffold/Import.hs.cg | 1 + yesod/scaffold/Settings.hs.cg | 8 +++----- yesod/scaffold/Settings/Development.hs.cg | 12 ++++++++++++ yesod/scaffold/Settings/StaticFiles.hs.cg | 8 ++------ 5 files changed, 21 insertions(+), 24 deletions(-) create mode 100644 yesod/scaffold/Settings/Development.hs.cg diff --git a/yesod/scaffold/Application.hs.cg b/yesod/scaffold/Application.hs.cg index 20a58b61..64a38706 100644 --- a/yesod/scaffold/Application.hs.cg +++ b/yesod/scaffold/Application.hs.cg @@ -10,13 +10,8 @@ import Yesod.Auth import Yesod.Default.Config import Yesod.Default.Main import Yesod.Default.Handlers -#if DEVELOPMENT -import Yesod.Logger (Logger, logBS) -import Network.Wai.Middleware.RequestLogger (logCallbackDev) -#else import Yesod.Logger (Logger, logBS, toProduction) -import Network.Wai.Middleware.RequestLogger (logCallback) -#endif +import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev) import qualified Database.Persist.Store~importMigration~ import Network.HTTP.Conduit (newManager, def) @@ -38,13 +33,8 @@ makeApplication conf logger = do app <- toWaiAppPlain foundation return $ logWare app where -#ifdef DEVELOPMENT - logWare = logCallbackDev (logBS setLogger) - setLogger = logger -#else - setLogger = toProduction logger -- by default the logger is set for development - logWare = logCallback (logBS setLogger) -#endif + logWare = dev logCallbackDev logCallback (logBS setLogger) + setLogger = dev id toProduction logger makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO ~sitearg~ makeFoundation conf setLogger = do diff --git a/yesod/scaffold/Import.hs.cg b/yesod/scaffold/Import.hs.cg index bc64119d..61ccab17 100644 --- a/yesod/scaffold/Import.hs.cg +++ b/yesod/scaffold/Import.hs.cg @@ -18,6 +18,7 @@ import Data.Monoid (Monoid (mappend, mempty, mconcat)) import Control.Applicative ((<$>), (<*>), pure) import Data.Text (Text) import Settings.StaticFiles +import Settings.Development #if __GLASGOW_HASKELL__ < 704 infixr 5 <> diff --git a/yesod/scaffold/Settings.hs.cg b/yesod/scaffold/Settings.hs.cg index e022d478..2c8434e6 100644 --- a/yesod/scaffold/Settings.hs.cg +++ b/yesod/scaffold/Settings.hs.cg @@ -21,6 +21,7 @@ import qualified Yesod.Default.Util import Data.Text (Text) import Data.Yaml import Control.Applicative +import Settings.Development -- | Which Persistent backend this site is using. type PersistConfig = ~configPersist~ @@ -53,11 +54,8 @@ staticRoot conf = [st|#{appRoot conf}/static|] -- user. widgetFile :: String -> Q Exp -#if DEVELOPMENT -widgetFile = Yesod.Default.Util.widgetFileReload -#else -widgetFile = Yesod.Default.Util.widgetFileNoReload -#endif +widgetFile = dev Yesod.Default.Util.widgetFileReload + Yesod.Default.Util.widgetFileNoReload data Extra = Extra { extraCopyright :: Text diff --git a/yesod/scaffold/Settings/Development.hs.cg b/yesod/scaffold/Settings/Development.hs.cg new file mode 100644 index 00000000..38e4448f --- /dev/null +++ b/yesod/scaffold/Settings/Development.hs.cg @@ -0,0 +1,12 @@ +module Settings.Development where + +development :: Bool +development = +#if DEVELOPMENT + True +#else + False +#endif + +dev :: a -> a -> a +dev a b = if development then a else b diff --git a/yesod/scaffold/Settings/StaticFiles.hs.cg b/yesod/scaffold/Settings/StaticFiles.hs.cg index e6048731..759c7427 100644 --- a/yesod/scaffold/Settings/StaticFiles.hs.cg +++ b/yesod/scaffold/Settings/StaticFiles.hs.cg @@ -4,15 +4,11 @@ import Prelude (IO) import Yesod.Static import qualified Yesod.Static as Static import Settings (staticDir) +import Settings.Development -- | use this to create your static file serving site staticSite :: IO Static.Static -staticSite = -#ifdef DEVELOPMENT - Static.staticDevel staticDir -#else - Static.static staticDir -#endif +staticSite = dev Static.staticDevel Static.static staticDir -- | This generates easy references to files in the static directory at compile time, -- giving you compile-time verification that referenced files exist. From 55bd35fc5c0b7359d2c2eee0788064096ca52370 Mon Sep 17 00:00:00 2001 From: Patrick Palka Date: Fri, 6 Apr 2012 12:21:03 -0400 Subject: [PATCH 007/250] [scaffold] add 'production' and 'prod' combinator --- yesod/scaffold/Settings/Development.hs.cg | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/yesod/scaffold/Settings/Development.hs.cg b/yesod/scaffold/Settings/Development.hs.cg index 38e4448f..30964dc1 100644 --- a/yesod/scaffold/Settings/Development.hs.cg +++ b/yesod/scaffold/Settings/Development.hs.cg @@ -10,3 +10,9 @@ development = dev :: a -> a -> a dev a b = if development then a else b + +production :: Bool +production = not development + +prod :: a -> a -> a +prod a b = if production then a else b From 4ac413e419de667219c52643ad238f3195d786da Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 7 Apr 2012 23:01:29 +0300 Subject: [PATCH 008/250] Configurable session name --- yesod-core/Yesod/Internal.hs | 4 ---- yesod-core/Yesod/Internal/Core.hs | 7 ++++--- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index a4baf477..cffb6a6f 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -24,7 +24,6 @@ module Yesod.Internal , runUniqueList , toUnique -- * Names - , sessionName , tokenKey ) where @@ -98,9 +97,6 @@ newtype Body url = Body (HtmlUrl url) tokenKey :: IsString a => a tokenKey = "_TOKEN" -sessionName :: IsString a => a -sessionName = "_SESSION" - type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder data GWData a = GWData diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index a182b9e0..74efc21a 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -699,17 +699,18 @@ clientSessionBackend :: Yesod master -> Int -- ^ Inactive session valitity in minutes -> SessionBackend master clientSessionBackend key timeout = SessionBackend - { sbLoadSession = loadClientSession key timeout + { sbLoadSession = loadClientSession key timeout "_SESSION" } loadClientSession :: Yesod master => CS.Key - -> Int + -> Int -- ^ timeout + -> S8.ByteString -- ^ session name -> master -> W.Request -> UTCTime -> IO (BackendSession, SaveSession) -loadClientSession key timeout master req now = return (sess, save) +loadClientSession key timeout sessionName master req now = return (sess, save) where sess = fromMaybe [] $ do raw <- lookup "Cookie" $ W.requestHeaders req From 1f392d2b7938e0c4c3a1c9aed75c3b6a29d0232c Mon Sep 17 00:00:00 2001 From: gregwebs Date: Sat, 7 Apr 2012 17:40:55 -0700 Subject: [PATCH 009/250] install yesod with cabal-meta --- README.md | 85 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 41 deletions(-) diff --git a/README.md b/README.md index e0156e8f..295595a6 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +# Yesod + An advanced web framework using the Haskell programming language. Featuring: * safety & security guaranteed at compile time @@ -11,7 +13,7 @@ An advanced web framework using the Haskell programming language. Featuring: ## Learn more: http://yesodweb.com/ -## Installation: http://www.yesodweb.com/page/five-minutes +## Installation: http://www.yesodweb.com/page/quickstart cabal update && cabal install yesod @@ -19,77 +21,82 @@ An advanced web framework using the Haskell programming language. Featuring: yesod init +Your application is a cabal package and you use `cabal` to install its dependencies. ## Using cabal-dev cabal-dev creates a sandboxed environment for an individual cabal package. -Your application is a cabal package and you should use cabal-dev with your Yesod application. -Instead of using the `cabal` command, use the `cabal-dev` command. +Instead of using the `cabal` command, use the `cabal-dev` command which will use the sandbox. Use `yesod-devel --dev` when developing your application. -## Installing the latest development version from github +## Installing the latest development version from github for use with your application -Yesod is broken up into 4 separate code repositories each built upon many smaller packages. + cabal update + cabal install cabal-meta cabal-src +In your application folder, create a `sources.txt` file with the following contents: + + ./ + https://github.com/yesodweb/yesod + https://github.com/yesodweb/shakespeare + https://github.com/yesodweb/persistent + https://github.com/yesodweb/wai + +`./` means build your app. The yesod repos will be cloned and placed in a `vendor` repo. +Now run: `cabal-meta install`. If you use `cabal-dev`, run `cabal-meta --dev install` + +You should be good now! Install conflicts are unfortunately common in Haskell development. -However, we can prevent most of them by using some extra tools. -This will require a little up-front reading and learning, but save you from a lot of misery in the long-run. -See the above explanation of cabal-dev, and below of virthualenv. +If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken. +You can prevent this by using sandbox tools. `cabal-dev` was already mentioned. +Another alternative is `virthualenv`. -Please note that cabal-dev will not work in a virthualenv shell - you can't use both at the same time. ### virthualenv -We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv) when hacking on Yesod. +We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv) when hacking on Yesod from Linux. This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages. -virthualenv will not work on Windows - Windows users should use only cabal-dev. +virthualenv will not work on Windows and maybe not Mac. Use cabal-dev instead * virthualenv creates an isolated environment like cabal-dev * virthualenv works at the shell level, so every shell must activate the virthualenv * cabal-dev by default isolates a single cabal package, but virthualenv isolates multiple packages together. * cabal-dev can isolate multiple packages together by using the -s sandbox argument -To just install Yesod from github, we only need cabal-dev. For hacking we prefer virthualenv: it is more convenient to just use normal cabal commands rather than `cabal-dev -s`. - ### cabal-src -Michael Snoyman just released the cabal-src tool, which helps resolve dependency conflicts when installing local packages. This capability is already built in if you are using cabal-dev. Otherwise install it with: +The cabal-src tool helps resolve dependency conflicts when installing local packages. +This capability is already built in if you are using cabal-dev or cabal-meta. Otherwise install cabal-src with: cabal install cabal-src -Whenever you would use `cabal install` for a local package, use `cabal-src-install` instead. Our installer script now uses cabal-src-install when it is available. +Whenever you would use `cabal install` to install a local package, use `cabal-src-install` instead. +Our installer script now uses cabal-src-install when it is available. -### Building Yesod +### Building your changes to Yesod + +#### Cloning the repos ~~~ { .bash } -# update your package database if you haven't recently -cabal update -# install required libraries -cabal install Cabal cabal-install - -# use cabal-dev -cabal install cabal-dev - -# or use virthualenv -cabal install cabal-src virthualenv -cd yesodweb # the folder where you put the yesod, persistent, hamlet & wai repos -virthualenv --name=yesod -. .virthualenv/bin/activate - -# clone and install all repos -# see below about first using virthualenv/cabal-dev before running ./scripts/install for repo in hamlet persistent wai yesod; do git clone http://github.com/yesodweb/$repo ( cd $repo git submodule update --init - ./scripts/install ) done +~~~~ + +#### install all repos + +~~~ { .bash } +for repo in hamlet persistent wai yesod; do + ./scripts/install +done ~~~ @@ -101,20 +108,16 @@ done # If things seem weird, you may need to do a clean. ./scripts/install --clean +~~~ + +#### Building individual packages # move to the individual package you are working on cd shakespeare-text +~~~ { .bash } # build and test the individual package cabal configure -ftest --enable-tests cabal build cabal test ~~~ - - -### Use your development version of Yesod in your application - -Note that we have recommended to you to install Yesod into a sandboxed virthualenv environment. -This is great for development, but when you want to use these development versions in your application that means they are not available through your user/global cabal database for your application. -You should just continue to use your yesod virthualenv shell for your application. -You can also use the same`cabal-dev shared sandbox. From 5b8925962f70c03b6b47f6a91a38a0776c20f371 Mon Sep 17 00:00:00 2001 From: Patrick Palka Date: Sun, 8 Apr 2012 00:27:22 -0400 Subject: [PATCH 010/250] [scaffold] make the scaffolding buildable --- yesod/Scaffolding/Scaffolder.hs | 1 + yesod/scaffold/Import.hs.cg | 1 + yesod/scaffold/Settings/Development.hs.cg | 2 ++ yesod/scaffold/project.cabal.cg | 1 + 4 files changed, 5 insertions(+) diff --git a/yesod/Scaffolding/Scaffolder.hs b/yesod/Scaffolding/Scaffolder.hs index a730b408..163b69d3 100644 --- a/yesod/Scaffolding/Scaffolder.hs +++ b/yesod/Scaffolding/Scaffolder.hs @@ -161,6 +161,7 @@ scaffold = do writeFile' "Model.hs" $(codegen "Model.hs") writeFile' "Settings.hs" $(codegen "Settings.hs") writeFile' "Settings/StaticFiles.hs" $(codegen "Settings/StaticFiles.hs") + writeFile' "Settings/Development.hs" $(codegen "Settings/Development.hs") writeFile' "static/css/bootstrap.css" $(codegen "static/css/bootstrap.css") writeFile' "templates/default-layout.hamlet" diff --git a/yesod/scaffold/Import.hs.cg b/yesod/scaffold/Import.hs.cg index 61ccab17..641de382 100644 --- a/yesod/scaffold/Import.hs.cg +++ b/yesod/scaffold/Import.hs.cg @@ -3,6 +3,7 @@ module Import , module Yesod , module Foundation , module Settings.StaticFiles + , module Settings.Development , module Data.Monoid , module Control.Applicative , Text diff --git a/yesod/scaffold/Settings/Development.hs.cg b/yesod/scaffold/Settings/Development.hs.cg index 30964dc1..46194f72 100644 --- a/yesod/scaffold/Settings/Development.hs.cg +++ b/yesod/scaffold/Settings/Development.hs.cg @@ -1,5 +1,7 @@ module Settings.Development where +import Prelude + development :: Bool development = #if DEVELOPMENT diff --git a/yesod/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg index 44d3f503..3fb9ce34 100644 --- a/yesod/scaffold/project.cabal.cg +++ b/yesod/scaffold/project.cabal.cg @@ -32,6 +32,7 @@ library Model Settings Settings.StaticFiles + Settings.Development Handler.Home ghc-options: -Wall -threaded -O0 From 27d8f13e7fdcdb8b3ef3d975528029766ab33fe5 Mon Sep 17 00:00:00 2001 From: Patrick Palka Date: Sun, 8 Apr 2012 00:58:19 -0400 Subject: [PATCH 011/250] [yesod] update extra-source-files in cabal file --- yesod/yesod.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 058770b2..a7a0a009 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -32,6 +32,7 @@ extra-source-files: scaffold/.ghci.cg scaffold/tests/main.hs.cg scaffold/Settings.hs.cg + scaffold/Settings/Development.hs.cg scaffold/Settings/StaticFiles.hs.cg scaffold/Application.hs.cg scaffold/deploy/Procfile.cg From aed67fc6803469643a93bddad71e8b84e704d1a4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Apr 2012 07:08:03 +0300 Subject: [PATCH 012/250] Better scaffolded default-layout for Twitter Bootstrap --- yesod/scaffold/templates/default-layout-wrapper.hamlet.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg b/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg index 3d548d55..37a22d96 100644 --- a/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg +++ b/yesod/scaffold/templates/default-layout-wrapper.hamlet.cg @@ -22,7 +22,7 @@ " res From 9fdb8c9d2d0539f47eb1d54771e7cbb12f6d7c37 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 4 Jul 2012 17:53:47 +0300 Subject: [PATCH 131/250] Field names for GWData --- yesod-core/Yesod/Internal.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index a1f275d4..33715489 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -99,13 +99,14 @@ tokenKey = "_TOKEN" type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> Builder data GWData a = GWData - !(Body a) - !(Last Title) - !(UniqueList (Script a)) - !(UniqueList (Stylesheet a)) - !(Map.Map (Maybe Text) (CssBuilderUrl a)) -- media type - !(Maybe (JavascriptUrl a)) - !(Head a) + { 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) From c611543a6f8c598234cb58fc4c36632b534158e2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 4 Jul 2012 17:53:24 +0300 Subject: [PATCH 132/250] Javascript in Head (#380) --- yesod-core/Yesod/Widget.hs | 2 +- yesod-core/test/YesodCoreTest/Widget.hs | 12 ++++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 59d0f844..5dcea990 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -152,7 +152,7 @@ instance render ~ RY master => ToWidgetHead sub master (render -> Html) where instance render ~ RY master => ToWidgetHead sub master (render -> Css) where toWidgetHead = toWidget instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where - toWidgetHead = toWidget + toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j instance ToWidgetHead sub master Html where toWidgetHead = toWidgetHead . const diff --git a/yesod-core/test/YesodCoreTest/Widget.hs b/yesod-core/test/YesodCoreTest/Widget.hs index 055e42dd..35440f19 100644 --- a/yesod-core/test/YesodCoreTest/Widget.hs +++ b/yesod-core/test/YesodCoreTest/Widget.hs @@ -26,6 +26,7 @@ mkYesod "Y" [parseRoutes| /whamlet WhamletR GET /towidget TowidgetR GET /auto AutoR GET +/jshead JSHeadR GET |] instance Yesod Y where @@ -77,12 +78,16 @@ getAutoR = defaultLayout [whamlet| where someHtml = [shamlet|somehtml|] +getJSHeadR :: Handler RepHtml +getJSHeadR = defaultLayout $ toWidgetHead [julius|alert("hello");|] + widgetTest :: Spec widgetTest = describe "Test.Widget" [ it "addJuliusBody" case_addJuliusBody , it "whamlet" case_whamlet , it "two letter lang codes" case_two_letter_lang , it "automatically applies toWidget" case_auto + , it "toWidgetHead puts JS in head" case_jshead ] runner :: Session () -> IO () @@ -116,3 +121,10 @@ case_auto = runner $ do , requestHeaders = [("Accept-Language", "es")] } assertBody "\nsomehtml" res + +case_jshead :: IO () +case_jshead = runner $ do + res <- request defaultRequest + { pathInfo = ["jshead"] + } + assertBody "\n" res From 2f6cdb1ced477d399a0435a1997eeb8277913676 Mon Sep 17 00:00:00 2001 From: Adam Tulinius Date: Wed, 4 Jul 2012 17:34:36 +0200 Subject: [PATCH 133/250] Export blank --- yesod-form/Yesod/Form/Fields.hs | 6 +----- yesod-form/Yesod/Form/Functions.hs | 7 +++++++ yesod-form/Yesod/Form/Jquery.hs | 5 ----- 3 files changed, 8 insertions(+), 10 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index fcca7344..49e8f807 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -47,6 +47,7 @@ module Yesod.Form.Fields import Yesod.Form.Types import Yesod.Form.I18n.English +import Yesod.Form.Functions (blank) import Yesod.Handler (getMessageRender) import Yesod.Widget (toWidget, whamlet, GWidget) import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..)) @@ -97,11 +98,6 @@ import Control.Applicative ((<$>)) defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage -blank :: (Monad m, RenderMessage master FormMessage) - => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a)) -blank _ [] = return $ Right Nothing -blank _ ("":_) = return $ Right Nothing -blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i intField = Field diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 0dfb3777..2751548c 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -36,6 +36,7 @@ module Yesod.Form.Functions -- * Utilities , fieldSettingsLabel , aformM + , blank ) where import Yesod.Form.Types @@ -361,3 +362,9 @@ aformM :: GHandler sub master a -> AForm sub master a aformM action = AForm $ \_ _ ints -> do value <- action return (FormSuccess value, id, ints, mempty) + +blank :: (Monad m, RenderMessage master FormMessage) + => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a)) +blank _ [] = return $ Right Nothing +blank _ ("":_) = return $ Right Nothing +blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x diff --git a/yesod-form/Yesod/Form/Jquery.hs b/yesod-form/Yesod/Form/Jquery.hs index 9c1ec388..ad0ea1fb 100644 --- a/yesod-form/Yesod/Form/Jquery.hs +++ b/yesod-form/Yesod/Form/Jquery.hs @@ -50,11 +50,6 @@ class YesodJquery a where urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -blank :: (RenderMessage master FormMessage, Monad m) => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a)) -blank _ [] = return $ Right Nothing -blank _ ("":_) = return $ Right Nothing -blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x - jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day jqueryDayField jds = Field { fieldParse = blank $ maybe From ed2c67ad79135f28efa54ec6dec063225187e304 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 4 Jul 2012 20:45:38 +0300 Subject: [PATCH 134/250] yesod-core version bump --- yesod-core/yesod-core.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 642feded..622a47d8 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.0.1.2 +version: 1.0.1.3 license: MIT license-file: LICENSE author: Michael Snoyman From ddd105998390d32e80bb22770b9af586483e26c4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Jul 2012 11:03:00 +0300 Subject: [PATCH 135/250] Updated fast-logger/wai-logger --- yesod-core/Yesod/Content.hs | 4 - yesod-core/Yesod/Core.hs | 35 +---- yesod-core/Yesod/Dispatch.hs | 24 ++- yesod-core/Yesod/Handler.hs | 28 ++-- yesod-core/Yesod/Internal/Core.hs | 92 ++++++------ yesod-core/Yesod/Logger.hs | 138 ------------------ yesod-core/Yesod/Widget.hs | 11 +- yesod-core/helloworld.hs | 8 +- yesod-core/test/YesodCoreTest/CleanPath.hs | 2 +- .../test/YesodCoreTest/ErrorHandling.hs | 4 +- yesod-core/yesod-core.cabal | 4 +- 11 files changed, 89 insertions(+), 261 deletions(-) delete mode 100644 yesod-core/Yesod/Logger.hs diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index 9b98883f..b8ff28e0 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -60,11 +60,7 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) import Text.Hamlet (Html) -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) -#else -import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder) -#endif import Data.String (IsString (fromString)) import Network.Wai (FilePart) import Data.Conduit (Source, ResourceT, Flush) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index cc7a7719..8beedc72 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -20,8 +20,6 @@ module Yesod.Core , unauthorizedI -- * Logging , LogLevel (..) - , formatLogMessage - , fileLocationToString , logDebug , logInfo , logWarn @@ -59,38 +57,7 @@ import Yesod.Request import Yesod.Widget import Yesod.Message -import Language.Haskell.TH.Syntax -import qualified Language.Haskell.TH.Syntax as TH -import Data.Text (Text) - -logTH :: LogLevel -> Q Exp -logTH level = - [|messageLoggerHandler $(qLocation >>= liftLoc) $(TH.lift level)|] - where - liftLoc :: Loc -> Q Exp - liftLoc (Loc a b c d e) = [|Loc $(TH.lift a) $(TH.lift b) $(TH.lift c) $(TH.lift d) $(TH.lift e)|] - --- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage: --- --- > $(logDebug) "This is a debug log message" -logDebug :: Q Exp -logDebug = logTH LevelDebug - --- | See 'logDebug' -logInfo :: Q Exp -logInfo = logTH LevelInfo --- | See 'logDebug' -logWarn :: Q Exp -logWarn = logTH LevelWarn --- | See 'logDebug' -logError :: Q Exp -logError = logTH LevelError - --- | Generates a function that takes a 'Text' and logs a 'LevelOther' message. Usage: --- --- > $(logOther "My new level") "This is a log message" -logOther :: Text -> Q Exp -logOther = logTH . LevelOther +import System.Log.FastLogger -- | Return an 'Unauthorized' value, with the given i18n message. unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs index 312bd212..0a3e87d9 100644 --- a/yesod-core/Yesod/Dispatch.hs +++ b/yesod-core/Yesod/Dispatch.hs @@ -28,7 +28,7 @@ module Yesod.Dispatch , WaiSubsite (..) ) where -import Data.Functor ((<$>)) +import Control.Applicative ((<$>), (<*>)) import Prelude hiding (exp) import Yesod.Internal.Core import Yesod.Handler hiding (lift) @@ -53,6 +53,7 @@ import Network.HTTP.Types (status301) import Yesod.Routes.TH import Yesod.Content (chooseRep) import Yesod.Routes.Parse +import System.Log.FastLogger (Logger) type Texts = [Text] @@ -119,7 +120,13 @@ mkYesodGeneral name args clazzes isSub resS = do let res = map (fmap parseType) resS renderRouteDec <- mkRenderRouteInstance arg res - disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res + let logger = mkName "logger" + Clause pat body decs <- mkDispatchClause + [|yesodRunner $(return $ VarE logger)|] + [|yesodDispatch $(return $ VarE logger)|] + [|fmap chooseRep|] + res + let disp = Clause (VarP logger : pat) body decs let master = mkName "master" let ctx = if isSub then ClassP (mkName "Yesod") [VarT master] : clazzes @@ -160,23 +167,24 @@ toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y toWaiAppPlain :: ( Yesod master , YesodDispatch master master ) => master -> IO W.Application -toWaiAppPlain a = toWaiApp' a <$> makeSessionBackend a +toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a toWaiApp' :: ( Yesod master , YesodDispatch master master ) => master + -> Logger -> Maybe (SessionBackend master) -> W.Application -toWaiApp' y sb env = +toWaiApp' y logger sb env = case cleanPath y $ W.pathInfo env of Left pieces -> sendRedirect y pieces env Right pieces -> - yesodDispatch y y id app404 handler405 method pieces sb env + yesodDispatch logger y y id app404 handler405 method pieces sb env where - app404 = yesodRunner notFound y y Nothing id - handler405 route = yesodRunner badMethod y y (Just route) id + app404 = yesodRunner logger notFound y y Nothing id + handler405 route = yesodRunner logger badMethod y y (Just route) id method = decodeUtf8With lenientDecode $ W.requestMethod env sendRedirect :: Yesod master => master -> [Text] -> W.Application @@ -202,4 +210,4 @@ instance RenderRoute WaiSubsite where renderRoute (WaiSubsiteRoute ps qs) = (ps, qs) instance YesodDispatch WaiSubsite master where - yesodDispatch _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app + 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 330e15cb..b519dfae 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -138,11 +138,7 @@ import qualified Network.Wai as W import qualified Network.HTTP.Types as H import Text.Hamlet -#if MIN_VERSION_blaze_html(0, 5, 0) import qualified Text.Blaze.Html.Renderer.Text as RenderText -#else -import qualified Text.Blaze.Renderer.Text as RenderText -#endif import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -165,12 +161,10 @@ import Blaze.ByteString.Builder (toByteString) import Data.Text (Text) import Yesod.Message (RenderMessage (..)) -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html (toHtml, preEscapedToMarkup) #define preEscapedText preEscapedToMarkup -#else -import Text.Blaze (toHtml, preEscapedText) -#endif + +import System.Log.FastLogger import qualified Yesod.Internal.Cache as Cache import Yesod.Internal.Cache (mkCacheKey, CacheKey) @@ -183,6 +177,7 @@ import Control.Monad.Base import Yesod.Routes.Class import Data.Word (Word64) import Data.Conduit (Sink) +import Language.Haskell.TH.Syntax (Loc) class YesodSubRoute s y where fromSubRoute :: s -> y -> Route s -> Route y @@ -196,6 +191,7 @@ data HandlerData sub master = HandlerData , handlerToMaster :: Route sub -> Route master , handlerState :: I.IORef GHState , handlerUpload :: Word64 -> FileUpload + , handlerLog :: Loc -> LogLevel -> LogStr -> IO () } handlerSubData :: (Route sub -> Route master) @@ -396,8 +392,9 @@ runHandler :: HasReps c -> master -> sub -> (Word64 -> FileUpload) + -> (Loc -> LogLevel -> LogStr -> IO ()) -> YesodApp -runHandler handler mrender sroute tomr master sub upload = +runHandler handler mrender sroute tomr master sub upload log' = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of @@ -419,6 +416,7 @@ runHandler handler mrender sroute tomr master sub upload = , handlerToMaster = tomr , handlerState = istate , handlerUpload = upload + , handlerLog = log' } contents' <- catch (fmap Right $ unGHandler handler hd) (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id @@ -792,6 +790,7 @@ handlerToYAR :: (HasReps a, HasReps b) => master -- ^ master site foundation -> sub -- ^ sub site foundation -> (Word64 -> FileUpload) + -> (Loc -> LogLevel -> LogStr -> IO ()) -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a) @@ -800,11 +799,11 @@ handlerToYAR :: (HasReps a, HasReps b) -> SessionMap -> GHandler sub master b -> ResourceT IO YesodAppResult -handlerToYAR y s upload toMasterRoute render errorHandler rr murl sessionMap h = +handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where - ya = runHandler h render murl toMasterRoute y s upload - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload + 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 @@ -957,3 +956,8 @@ instance MonadResource (GHandler sub master) where register = lift . register release = lift . release resourceMask = lift . resourceMask + +instance MonadLogging (GHandler sub master) where + monadLoggingLog a b c = do + hd <- ask + liftIO $ handlerLog hd a b (toLogStr c) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 7ead0d1c..11791592 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -20,11 +20,6 @@ module Yesod.Internal.Core , defaultErrorHandler -- * Data types , AuthResult (..) - -- * Logging - , LogLevel (..) - , formatLogMessage - , fileLocationToString - , messageLoggerHandler -- * Sessions , SessionBackend (..) , defaultClientSessionBackend @@ -82,10 +77,7 @@ import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Data.List (foldl') import qualified Network.HTTP.Types as H import Web.Cookie (SetCookie (..)) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO -import qualified Data.Text.Lazy.Builder as TB -import Language.Haskell.TH.Syntax (Loc (..), Lift (..)) +import Language.Haskell.TH.Syntax (Loc (..)) import Text.Blaze (preEscapedToMarkup) import Data.Aeson (Value (Array, String)) import Data.Aeson.Encode (encode) @@ -94,6 +86,9 @@ import Network.Wai.Middleware.Gzip (GzipSettings, def) import Network.Wai.Parse (tempFileSink, lbsSink) import qualified Paths_yesod_core import Data.Version (showVersion) +import System.Log.FastLogger (LogLevel (LevelInfo), Logger, mkLogger, loggerDateRef, LogStr (..), loggerPutStr) +import System.Log.FastLogger.Date (getDate, DateRef) +import System.IO (stdout) yesodVersion :: String yesodVersion = showVersion Paths_yesod_core.version @@ -103,7 +98,8 @@ yesodVersion = showVersion Paths_yesod_core.version class YesodDispatch sub master where yesodDispatch :: Yesod master - => master + => Logger + -> master -> sub -> (Route sub -> Route master) -> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler @@ -114,7 +110,8 @@ class YesodDispatch sub master where -> W.Application yesodRunner :: Yesod master - => GHandler sub master ChooseRep + => Logger + -> GHandler sub master ChooseRep -> master -> sub -> Maybe (Route sub) @@ -285,21 +282,28 @@ $doctype 5 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 - -- | Send a message to the log. By default, prints to stdout. + -- | 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@. messageLogger :: a + -> Logger -> Loc -- ^ position in source code -> LogLevel - -> Text -- ^ message + -> LogStr -- ^ message -> IO () - messageLogger a loc level msg = + messageLogger a logger loc level msg = if level < logLevel a then return () - else - formatLogMessage loc level msg >>= - Data.Text.Lazy.IO.putStrLn + else formatLogMessage (loggerDateRef logger) loc level msg >>= loggerPutStr logger -- | The logging level in place for this application. Any messages below -- this level will simply be ignored. @@ -338,37 +342,23 @@ $doctype 5 | size > 50000 = FileUploadDisk tempFileSink | otherwise = FileUploadMemory lbsSink -messageLoggerHandler :: Yesod m - => Loc -> LogLevel -> Text -> GHandler s m () -messageLoggerHandler loc level msg = do - y <- getYesod - liftIO $ messageLogger y loc level msg - -data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther Text - deriving (Eq, Show, Read, Ord) - -instance Lift LogLevel where - lift LevelDebug = [|LevelDebug|] - lift LevelInfo = [|LevelInfo|] - lift LevelWarn = [|LevelWarn|] - lift LevelError = [|LevelError|] - lift (LevelOther x) = [|LevelOther $ T.pack $(lift $ T.unpack x)|] - -formatLogMessage :: Loc +formatLogMessage :: DateRef + -> Loc -> LogLevel - -> Text -- ^ message - -> IO TL.Text -formatLogMessage loc level msg = do - now <- getCurrentTime - return $ TB.toLazyText $ - TB.fromText (T.pack $ show now) - `mappend` TB.fromText " [" - `mappend` TB.fromText (T.pack $ drop 5 $ show level) - `mappend` TB.fromText "] " - `mappend` TB.fromText msg - `mappend` TB.fromText " @(" - `mappend` TB.fromText (T.pack $ fileLocationToString loc) - `mappend` TB.fromText ") " + -> LogStr -- ^ message + -> IO [LogStr] +formatLogMessage dateref loc level msg = do + now <- getDate dateref + return + [ LB now + , LB " [" + , LS $ drop 5 $ show level + , LB "] " + , msg + , LB " @(" + , LS $ fileLocationToString loc + , LB ")\n" + ] -- taken from file-location package -- turn the TH Loc loaction information into a human readable string @@ -381,14 +371,15 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++ char = show . snd . loc_start defaultYesodRunner :: Yesod master - => GHandler sub master ChooseRep + => Logger + -> GHandler sub master ChooseRep -> master -> sub -> Maybe (Route sub) -> (Route sub -> Route master) -> Maybe (SessionBackend master) -> W.Application -defaultYesodRunner handler master sub murl toMasterRoute msb req +defaultYesodRunner logger handler master sub murl toMasterRoute msb req | maximumContentLength master (fmap toMasterRoute murl) < len = return $ W.responseLBS (H.Status 413 "Too Large") @@ -419,7 +410,8 @@ defaultYesodRunner handler master sub murl toMasterRoute msb req handler let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session let ra = resolveApproot master req - yar <- handlerToYAR master sub (fileUpload master) toMasterRoute + let log' = messageLogger 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 diff --git a/yesod-core/Yesod/Logger.hs b/yesod-core/Yesod/Logger.hs deleted file mode 100644 index c391ac4f..00000000 --- a/yesod-core/Yesod/Logger.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Yesod.Logger - ( Logger - , handle - , developmentLogger, productionLogger - , defaultDevelopmentLogger, defaultProductionLogger - , toProduction - , flushLogger - , logText - , logLazyText - , logString - , logBS - , logMsg - , formatLogText - , timed - -- * Deprecated - , makeLoggerWithHandle - , makeDefaultLogger - ) where - -import System.IO (Handle, stdout, hFlush) -import Data.ByteString (ByteString) -import Data.ByteString.Char8 (pack) -import Data.ByteString.Lazy (toChunks) -import qualified Data.Text.Lazy as TL -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import qualified Data.Text.Lazy.Encoding as TLE -import System.Log.FastLogger -import Network.Wai.Logger.Date (DateRef, dateInit, getDate) - --- for timed logging -import Data.Time (getCurrentTime, diffUTCTime) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Text.Printf (printf) -import Data.Text (unpack) - --- for formatter -import Language.Haskell.TH.Syntax (Loc) -import Yesod.Core (LogLevel, fileLocationToString) - -data Logger = Logger { - loggerLogFun :: [LogStr] -> IO () - , loggerHandle :: Handle - , loggerDateRef :: DateRef - } - -handle :: Logger -> Handle -handle = loggerHandle - -flushLogger :: Logger -> IO () -flushLogger = hFlush . loggerHandle - -makeDefaultLogger :: IO Logger -makeDefaultLogger = defaultDevelopmentLogger -{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-} - -makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger -makeLoggerWithHandle = productionLogger -{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-} - --- | uses stdout handle -defaultProductionLogger, defaultDevelopmentLogger :: IO Logger -defaultProductionLogger = productionLogger stdout -defaultDevelopmentLogger = developmentLogger stdout - - -productionLogger h = mkLogger h (handleToLogFun h) --- | a development logger gets automatically flushed -developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h) - -mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger -mkLogger h logFun = do - initHandle h - dateInit >>= return . Logger logFun h - --- convert (a development) logger to production settings -toProduction :: Logger -> Logger -toProduction (Logger _ h d) = Logger (handleToLogFun h) h d - -handleToLogFun :: Handle -> ([LogStr] -> IO ()) -handleToLogFun = hPutLogStr - -logMsg :: Logger -> [LogStr] -> IO () -logMsg = hPutLogStr . handle - -logLazyText :: Logger -> TL.Text -> IO () -logLazyText logger msg = loggerLogFun logger $ - map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine] - -logText :: Logger -> Text -> IO () -logText logger = logBS logger . encodeUtf8 - -logBS :: Logger -> ByteString -> IO () -logBS logger msg = loggerLogFun logger $ [LB msg, newLine] - -logString :: Logger -> String -> IO () -logString logger msg = loggerLogFun logger $ [LS msg, newLine] - -formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr] -formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg) - -toLB :: Text -> LogStr -toLB = LB . encodeUtf8 - -formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr] -formatLogMsg logger loc level msg = do - date <- liftIO $ getDate $ loggerDateRef logger - return - [ LB date - , LB $ pack" [" - , LS (drop 5 $ show level) - , LB $ pack "] " - , msg - , LB $ pack " @(" - , LS (fileLocationToString loc) - , LB $ pack ") " - ] - -newLine :: LogStr -newLine = LB $ pack "\n" - --- | Execute a monadic action and log the duration --- -timed :: MonadIO m - => Logger -- ^ Logger - -> Text -- ^ Message - -> m a -- ^ Action - -> m a -- ^ Timed and logged action -timed logger msg action = do - start <- liftIO getCurrentTime - !result <- action - stop <- liftIO getCurrentTime - let diff = fromEnum $ diffUTCTime stop start - ms = diff `div` 10 ^ (9 :: Int) - formatted = printf " [%4dms] %s" ms (unpack msg) - liftIO $ logString logger formatted - return result diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index c372b9e7..9c3cb69e 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -81,20 +81,16 @@ import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Exception (throwIO) import qualified Text.Hamlet as NP import Data.Text.Lazy.Builder (fromLazyText) -#if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html (toHtml, preEscapedToMarkup) import qualified Data.Text.Lazy as TL -#else -import Text.Blaze (toHtml, preEscapedLazyText) -#endif import Control.Monad.Base (MonadBase (liftBase)) import Control.Arrow (first) import Control.Monad.Trans.Resource -#if MIN_VERSION_blaze_html(0, 5, 0) +import System.Log.FastLogger + preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup -#endif -- | A generic widget, allowing specification of both the subsite and master -- site datatypes. While this is simply a @WriterT@, we define a newtype for @@ -348,3 +344,6 @@ instance MonadResource (GWidget sub master) where register = lift . register release = lift . release resourceMask = lift . resourceMask + +instance MonadLogging (GWidget sub master) where + monadLoggingLog a b = lift . monadLoggingLog a b diff --git a/yesod-core/helloworld.hs b/yesod-core/helloworld.hs index 4e42a2a5..889e46fe 100644 --- a/yesod-core/helloworld.hs +++ b/yesod-core/helloworld.hs @@ -5,7 +5,7 @@ import Yesod.Core import Control.Monad.IO.Class (liftIO) import Network.Wai.Handler.Warp (run) -import Data.Text (unpack) +import Data.Text (unpack, pack) import Text.Julius (julius) data Subsite = Subsite String @@ -22,13 +22,13 @@ getSubRootR = do Subsite s <- getYesodSub tm <- getRouteToMaster render <- getUrlRender - $(logDebug) "I'm in SubRootR" + $logDebug "I'm in SubRootR" return $ RepPlain $ toContent $ "Hello Sub World: " ++ s ++ ". " ++ unpack (render (tm SubRootR)) handleSubMultiR :: Yesod m => Strings -> GHandler Subsite m RepPlain handleSubMultiR x = do Subsite y <- getYesodSub - $(logInfo) "In SubMultiR" + $logInfo "In SubMultiR" return . RepPlain . toContent . show $ (x, y) data HelloWorld = HelloWorld { getSubsite :: String -> Subsite } @@ -38,7 +38,7 @@ mkYesod "HelloWorld" [parseRoutes| |] instance Yesod HelloWorld where addStaticContent a b c = do - liftIO $ print (a, b, c) + $logInfo $ pack $ show (a, b, c) return Nothing getRootR = do diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index 3b916bc5..10d95497 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -26,7 +26,7 @@ instance RenderRoute Subsite where renderRoute (SubsiteRoute x) = (x, []) instance YesodDispatch Subsite master where - yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS + yesodDispatch _ _ _ _ _ _ _ pieces _ _ = return $ responseLBS status200 [ ("Content-Type", "SUBSITE") ] $ L8.pack $ show pieces diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 8267a133..66362c57 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -24,7 +24,9 @@ mkYesod "App" [parseRoutes| instance Yesod App getHomeR :: Handler RepHtml -getHomeR = defaultLayout $ toWidget [hamlet| +getHomeR = do + $logDebug "Testing logging" + defaultLayout $ toWidget [hamlet| $doctype 5 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index ca22b882..756632dc 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -77,8 +77,7 @@ library , directory >= 1 && < 1.2 , vector >= 0.9 && < 0.10 , aeson >= 0.5 - , fast-logger >= 0.0.2 - , wai-logger >= 0.0.1 + , fast-logger >= 0.1 && < 0.2 , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2 @@ -89,7 +88,6 @@ library Yesod.Core Yesod.Dispatch Yesod.Handler - Yesod.Logger Yesod.Request Yesod.Widget Yesod.Message From 9af79e4d13cdf21b6818f710461d8293a553c969 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Jul 2012 11:58:53 +0300 Subject: [PATCH 136/250] Recognize 'on' for booleans --- yesod-form/Yesod/Form/Fields.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index fcca7344..52520836 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -370,6 +370,7 @@ boolField = Field "" -> Right Nothing "none" -> Right Nothing "yes" -> Right $ Just True + "on" -> Right $ Just True "no" -> Right $ Just False t -> Left $ SomeMessage $ MsgInvalidBool t showVal = either (\_ -> False) @@ -393,6 +394,7 @@ checkBoxField = Field checkBoxParser [] = Right $ Just False checkBoxParser (x:_) = case x of "yes" -> Right $ Just True + "on" -> Right $ Just True _ -> Right $ Just False showVal = either (\_ -> False) From 985dd6c924cdcdd2c97c8b9712d109df7b44b0b3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Jul 2012 13:37:54 +0300 Subject: [PATCH 137/250] Remainder of Logger changes, scaffolded site works (#360) --- yesod-default/Yesod/Default/Main.hs | 13 +++++-------- yesod-static/Yesod/Static.hs | 4 ++-- yesod/Yesod.hs | 24 +++--------------------- yesod/scaffold/Application.hs.cg | 20 +++++++++----------- yesod/scaffold/Foundation.hs.cg | 5 ----- yesod/yesod.cabal | 2 -- 6 files changed, 19 insertions(+), 49 deletions(-) diff --git a/yesod-default/Yesod/Default/Main.hs b/yesod-default/Yesod/Default/Main.hs index a1e330f9..ed5f3e43 100644 --- a/yesod-default/Yesod/Default/Main.hs +++ b/yesod-default/Yesod/Default/Main.hs @@ -7,7 +7,6 @@ module Yesod.Default.Main ) where import Yesod.Default.Config -import Yesod.Logger (Logger, defaultDevelopmentLogger, logString) import Network.Wai (Application) import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsHost) @@ -33,12 +32,11 @@ import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -- defaultMain :: (Show env, Read env) => IO (AppConfig env extra) - -> (AppConfig env extra -> Logger -> IO Application) + -> (AppConfig env extra -> IO Application) -> IO () defaultMain load getApp = do config <- load - logger <- defaultDevelopmentLogger - app <- getApp config logger + app <- getApp config print $ appHost config runSettings defaultSettings { settingsPort = appPort config @@ -80,12 +78,11 @@ defaultRunner f app = do defaultDevelApp :: (Show env, Read env) => IO (AppConfig env extra) -- ^ A means to load your development @'AppConfig'@ - -> (AppConfig env extra -> Logger -> IO Application) -- ^ Get your @Application@ + -> (AppConfig env extra -> IO Application) -- ^ Get your @Application@ -> IO (Int, Application) defaultDevelApp load getApp = do conf <- load - logger <- defaultDevelopmentLogger let p = appPort conf - logString logger $ "Devel application launched: http://localhost:" ++ show p - app <- getApp conf logger + putStrLn $ "Devel application launched: http://localhost:" ++ show p + app <- getApp conf return (p, app) diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index f7c02c39..7a09177e 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -138,10 +138,10 @@ instance RenderRoute Static where instance Yesod master => YesodDispatch Static master where -- Need to append trailing slash to make relative links work - yesodDispatch _ _ _ _ _ _ [] _ req = + yesodDispatch _ _ _ _ _ _ _ [] _ req = return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] "" - yesodDispatch _ (Static set) _ _ _ _ textPieces _ req = + yesodDispatch _ _ (Static set) _ _ _ _ textPieces _ req = staticApp set req { pathInfo = textPieces } notHidden :: Prelude.FilePath -> Bool diff --git a/yesod/Yesod.hs b/yesod/Yesod.hs index b9d05b30..a7885130 100644 --- a/yesod/Yesod.hs +++ b/yesod/Yesod.hs @@ -45,15 +45,13 @@ import Text.Julius import Yesod.Form import Yesod.Json import Yesod.Persist -import Network.HTTP.Types (status200) import Control.Monad.IO.Class (liftIO, MonadIO(..)) import Control.Monad.Trans.Control (MonadBaseControl) import Network.Wai -import Network.Wai.Logger +import Network.Wai.Middleware.RequestLogger (logStdout) import Network.Wai.Handler.Warp (run) -import System.IO (stderr, stdout, hFlush, hPutStrLn) -import System.Log.FastLogger +import System.IO (stderr, hPutStrLn) #if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html (toHtml) #else @@ -80,23 +78,7 @@ warpDebug :: (Yesod a, YesodDispatch a a) => Int -> a -> IO () warpDebug port app = do hPutStrLn stderr $ "Application launched, listening on port " ++ show port waiApp <- toWaiApp app - dateRef <- dateInit - run port $ (logStdout dateRef) waiApp - -logStdout :: DateRef -> Middleware -logStdout dateRef waiApp = - \req -> do - logRequest dateRef req - waiApp req - -logRequest :: Control.Monad.IO.Class.MonadIO m => - DateRef -> Network.Wai.Request -> m () -logRequest dateRef req = do - date <- liftIO $ getDate dateRef - let status = status200 - len = 4 - liftIO $ hPutLogStr stdout $ apacheFormat FromSocket date req status (Just len) - liftIO $ hFlush stdout + run port $ logStdout waiApp -- | Run a development server, where your code changes are automatically -- reloaded. diff --git a/yesod/scaffold/Application.hs.cg b/yesod/scaffold/Application.hs.cg index e2de8390..f4ab5c3d 100644 --- a/yesod/scaffold/Application.hs.cg +++ b/yesod/scaffold/Application.hs.cg @@ -11,8 +11,7 @@ import Yesod.Auth import Yesod.Default.Config import Yesod.Default.Main import Yesod.Default.Handlers -import Yesod.Logger (Logger, logBS, toProduction) -import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev) +import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev) import qualified Database.Persist.Store~importMigration~ import Network.HTTP.Conduit (newManager, def) @@ -29,25 +28,24 @@ mkYesodDispatch "~sitearg~" resources~sitearg~ -- performs initialization and creates a WAI application. This is also the -- place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application -makeApplication conf logger = do - foundation <- makeFoundation conf setLogger +makeApplication :: AppConfig DefaultEnv Extra -> IO Application +makeApplication conf = do + foundation <- makeFoundation conf app <- toWaiAppPlain foundation return $ logWare app where - setLogger = if development then logger else toProduction logger - logWare = if development then logCallbackDev (logBS setLogger) - else logCallback (logBS setLogger) + logWare = if development then logStdoutDev + else logStdout -makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO ~sitearg~ -makeFoundation conf setLogger = do +makeFoundation :: AppConfig DefaultEnv Extra -> IO ~sitearg~ +makeFoundation conf = do manager <- newManager def s <- staticSite dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf) Database.Persist.Store.loadConfig >>= Database.Persist.Store.applyEnv p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)~runMigration~ - return $ ~sitearg~ conf setLogger s p manager dbconf + return $ ~sitearg~ conf s p manager dbconf -- for yesod devel getApplicationDev :: IO (Int, Application) diff --git a/yesod/scaffold/Foundation.hs.cg b/yesod/scaffold/Foundation.hs.cg index 96f2e2a3..41f05973 100644 --- a/yesod/scaffold/Foundation.hs.cg +++ b/yesod/scaffold/Foundation.hs.cg @@ -20,7 +20,6 @@ import Yesod.Auth.BrowserId import Yesod.Auth.GoogleEmail import Yesod.Default.Config import Yesod.Default.Util (addStaticContentExternal) -import Yesod.Logger (Logger, logMsg, formatLogText) import Network.HTTP.Conduit (Manager) import qualified Settings import qualified Database.Persist.Store @@ -38,7 +37,6 @@ import Text.Hamlet (hamletFile) -- access to the data present here. data ~sitearg~ = ~sitearg~ { settings :: AppConfig DefaultEnv Extra - , getLogger :: Logger , getStatic :: Static -- ^ Settings for static file serving. , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool. , httpManager :: Manager @@ -107,9 +105,6 @@ instance Yesod ~sitearg~ where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - messageLogger y loc level msg = - formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y) - -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows -- expiration dates to be set far in the future without worry of diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 41eff819..3316aa32 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -74,7 +74,6 @@ library , transformers >= 0.2.2 && < 0.4 , wai >= 1.3 && < 1.4 , wai-extra >= 1.3 && < 1.4 - , wai-logger >= 0.1.2 , hamlet >= 1.1 && < 1.2 , shakespeare-js >= 1.0 && < 1.1 , shakespeare-css >= 1.0 && < 1.1 @@ -103,7 +102,6 @@ executable yesod , http-types >= 0.6.1 && < 0.7 , blaze-builder >= 0.2.1.4 && < 0.4 , filepath >= 1.1 - , fast-logger >= 0.0.2 && < 0.1 , process ghc-options: -Wall -threaded main-is: main.hs From 29c242d03b4cc65e0ccca324743fcef8c5eb69bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 5 Jul 2012 16:14:23 +0300 Subject: [PATCH 138/250] monad-logger --- yesod-core/Yesod/Core.hs | 2 +- yesod-core/Yesod/Handler.hs | 5 +++-- yesod-core/Yesod/Internal/Core.hs | 8 ++++++-- yesod-core/Yesod/Widget.hs | 6 +++--- yesod-core/yesod-core.cabal | 1 + 5 files changed, 14 insertions(+), 8 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 8beedc72..661d8ec6 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -57,7 +57,7 @@ import Yesod.Request import Yesod.Widget import Yesod.Message -import System.Log.FastLogger +import Control.Monad.Logger -- | Return an 'Unauthorized' value, with the given i18n message. unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index b519dfae..04688af4 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -165,6 +165,7 @@ 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, CacheKey) @@ -957,7 +958,7 @@ instance MonadResource (GHandler sub master) where release = lift . release resourceMask = lift . resourceMask -instance MonadLogging (GHandler sub master) where - monadLoggingLog a b c = do +instance MonadLogger (GHandler sub master) where + monadLoggerLog a b c = do hd <- ask liftIO $ handlerLog hd a b (toLogStr c) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 11791592..2335dca2 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -86,7 +86,8 @@ import Network.Wai.Middleware.Gzip (GzipSettings, def) import Network.Wai.Parse (tempFileSink, lbsSink) import qualified Paths_yesod_core import Data.Version (showVersion) -import System.Log.FastLogger (LogLevel (LevelInfo), Logger, mkLogger, loggerDateRef, LogStr (..), loggerPutStr) +import System.Log.FastLogger (Logger, mkLogger, loggerDateRef, LogStr (..), loggerPutStr) +import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther)) import System.Log.FastLogger.Date (getDate, DateRef) import System.IO (stdout) @@ -352,7 +353,10 @@ formatLogMessage dateref loc level msg = do return [ LB now , LB " [" - , LS $ drop 5 $ show level + , LS $ + case level of + LevelOther t -> T.unpack t + _ -> drop 5 $ show level , LB "] " , msg , LB " @(" diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs index 9c3cb69e..e6a27cc3 100644 --- a/yesod-core/Yesod/Widget.hs +++ b/yesod-core/Yesod/Widget.hs @@ -87,7 +87,7 @@ import Control.Monad.Base (MonadBase (liftBase)) import Control.Arrow (first) import Control.Monad.Trans.Resource -import System.Log.FastLogger +import Control.Monad.Logger preEscapedLazyText :: TL.Text -> Html preEscapedLazyText = preEscapedToMarkup @@ -345,5 +345,5 @@ instance MonadResource (GWidget sub master) where release = lift . release resourceMask = lift . resourceMask -instance MonadLogging (GWidget sub master) where - monadLoggingLog a b = lift . monadLoggingLog a b +instance MonadLogger (GWidget sub master) where + monadLoggerLog a b = lift . monadLoggerLog a b diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 756632dc..0a8fa555 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -78,6 +78,7 @@ library , vector >= 0.9 && < 0.10 , aeson >= 0.5 , fast-logger >= 0.1 && < 0.2 + , monad-logger >= 0.0 && < 0.1 , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2 From 5c4e5d989fddd07fd36f3104d688d3b520403004 Mon Sep 17 00:00:00 2001 From: Max Cantor Date: Thu, 5 Jul 2012 09:45:47 -0700 Subject: [PATCH 139/250] Added warning about Static embed. Updated to address Felipe's very valid criticisms. --- yesod-static/Yesod/Static.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 3aa274a2..fdc0d683 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -118,6 +118,13 @@ staticDevel dir = do -- | Produce a 'Static' based on embedding all of the static -- files' contents in the executable at compile time. +-- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs +-- you will need to change the scaffolded addStaticContent. Otherwise, some of your +-- assets will be 404'ed. This is because by default yesod will generate compile those +-- assets to @static/tmp@ which for 'static' is fine since they are served out of the +-- directory itself. With embedded static, that will not work. +-- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround. +-- This will cause yesod to embed those assets into the generated HTML file itself. embed :: Prelude.FilePath -> Q Exp embed fp = [|Static (defaultWebAppSettings From 9f61b1da66709d7fcc0c84cce131b3e75f477fe8 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Thu, 5 Jul 2012 23:18:07 -0300 Subject: [PATCH 140/250] Export yesod-json's acceptsJson. --- yesod-json/Yesod/Json.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/yesod-json/Yesod/Json.hs b/yesod-json/Yesod/Json.hs index a169819a..0eec299f 100644 --- a/yesod-json/Yesod/Json.hs +++ b/yesod-json/Yesod/Json.hs @@ -18,6 +18,7 @@ module Yesod.Json -- * Convenience functions , jsonOrRedirect + , acceptsJson ) where import Yesod.Handler (GHandler, waiRequest, lift, invalidArgs, redirect) @@ -109,7 +110,8 @@ array = J.Array . V.fromList . map J.toJSON -- | jsonOrRedirect simplifies the scenario where a POST handler sends a different -- response based on Accept headers: -- --- 1. 200 with JSON data if the client prefers application/json (e.g. AJAX). +-- 1. 200 with JSON data if the client prefers +-- @application\/json@ (e.g. AJAX, see 'acceptsJSON'). -- -- 2. 3xx otherwise, following the PRG pattern. jsonOrRedirect :: (Yesod master, J.ToJSON a) @@ -120,9 +122,12 @@ jsonOrRedirect r j = do q <- acceptsJson if q then jsonToRepJson (J.toJSON j) else redirect r - where - acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) - . join - . fmap (headMay . parseHttpAccept) - . lookup "Accept" . requestHeaders - <$> waiRequest + +-- | Returns @True@ if the client prefers @application\/json@ as +-- indicated by the @Accept@ HTTP header. +acceptsJson :: Yesod master => GHandler sub master Bool +acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';')) + . join + . fmap (headMay . parseHttpAccept) + . lookup "Accept" . requestHeaders + <$> waiRequest From 2f07a6a19f2474388e1cbb9c18c20230d78333a9 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Thu, 5 Jul 2012 23:18:30 -0300 Subject: [PATCH 141/250] Bump yesod-json to 1.0.1.0. --- yesod-json/yesod-json.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-json/yesod-json.cabal b/yesod-json/yesod-json.cabal index 9730795f..d05d5230 100644 --- a/yesod-json/yesod-json.cabal +++ b/yesod-json/yesod-json.cabal @@ -1,5 +1,5 @@ name: yesod-json -version: 1.0.0.1 +version: 1.0.1.0 license: MIT license-file: LICENSE author: Michael Snoyman From ce6aabf82f37906d45e9183bb852af51e833af2b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 6 Jul 2012 15:03:25 +0300 Subject: [PATCH 142/250] hspec 1.2 (fixes warnings) --- yesod-core/yesod-core.cabal | 2 +- yesod-static/yesod-static.cabal | 2 +- yesod-test/Yesod/Test.hs | 11 ++++++++--- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 622a47d8..211c114c 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -119,7 +119,7 @@ test-suite tests cpp-options: -DTEST build-depends: base - ,hspec >= 1.1 && < 1.2 + ,hspec >= 1.2 && < 1.3 ,wai-test ,wai ,yesod-core diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 6af96206..25a3ac86 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -44,7 +44,7 @@ test-suite tests type: exitcode-stdio-1.0 cpp-options: -DTEST_EXPORT build-depends: base - , hspec >= 1.0 && < 1.2 + , hspec >= 1.2 && < 1.3 , HUnit -- copy from above , containers >= 0.2 diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index e8715d10..e8f11282 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} {-| Yesod.Test is a pragmatic framework for testing web applications built using wai and persistent. @@ -133,10 +133,15 @@ type CookieValue = H.Ascii -- -- Look at the examples directory on this package to get an idea of the (small) amount of -- boilerplate code you'll need to write before calling this. -runTests :: Application -> ConnectionPool -> Specs -> IO a +runTests :: Application -> ConnectionPool -> Specs -> IO () runTests app connection specsDef = do (SpecsData _ _ specs) <- ST.execStateT specsDef (SpecsData app connection []) - Runner.hspecX specs +#if MIN_VERSION_hspec(1,2,0) + Runner.hspec +#else + Runner.hspecX +#endif + specs -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' From f3a3408260dd3cc7337f3d07c728ab129bd1eb81 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 6 Jul 2012 16:24:24 +0300 Subject: [PATCH 143/250] http-types 0.7 --- yesod-core/Yesod/Handler.hs | 5 +++-- yesod-core/Yesod/Internal.hs | 6 +++--- yesod-core/yesod-core.cabal | 2 +- yesod-static/yesod-static.cabal | 4 ++-- yesod-test/Yesod/Test.hs | 3 ++- yesod-test/yesod-test.cabal | 2 +- yesod/yesod.cabal | 2 +- 7 files changed, 13 insertions(+), 11 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 04688af4..0e355161 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -155,6 +155,7 @@ 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) @@ -808,7 +809,7 @@ handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMa types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler -yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response +yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> W.Response yarToResponse (YARWai a) _ = a yarToResponse (YARPlain s hs _ c _) extraHeaders = case c of @@ -830,7 +831,7 @@ httpAccept = parseHttpAccept -- | Convert Header to a key/value pair. headerToPair :: Header - -> (CI H.Ascii, H.Ascii) + -> (CI ByteString, ByteString) headerToPair (AddCookie sc) = ("Set-Cookie", toByteString $ renderSetCookie $ sc) headerToPair (DeleteCookie key path) = diff --git a/yesod-core/Yesod/Internal.hs b/yesod-core/Yesod/Internal.hs index 33715489..05f26798 100644 --- a/yesod-core/Yesod/Internal.hs +++ b/yesod-core/Yesod/Internal.hs @@ -42,8 +42,8 @@ import qualified Network.HTTP.Types as H import Data.String (IsString) import qualified Data.Map as Map import Data.Text.Lazy.Builder (Builder) -import Network.HTTP.Types (Ascii) import Web.Cookie (SetCookie (..)) +import Data.ByteString (ByteString) -- | Responses to indicate some form of an error occurred. These are different -- from 'SpecialResponse' in that they allow for custom error pages. @@ -60,8 +60,8 @@ instance Exception ErrorResponse -- | Headers to be added to a 'Result'. data Header = AddCookie SetCookie - | DeleteCookie Ascii Ascii - | Header Ascii Ascii + | DeleteCookie ByteString ByteString + | Header ByteString ByteString deriving (Eq, Show) langKey :: IsString a => a diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 0a8fa555..c19b3333 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -71,7 +71,7 @@ library , monad-control >= 0.3 && < 0.4 , transformers-base >= 0.4 , cookie >= 0.4 && < 0.5 - , http-types >= 0.6.5 && < 0.7 + , http-types >= 0.7 && < 0.8 , case-insensitive >= 0.2 , parsec >= 2 && < 3.2 , directory >= 1 && < 1.2 diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index cf39f1c8..84a9fe38 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -30,7 +30,7 @@ library , wai >= 1.3 && < 1.4 , text >= 0.9 && < 1.0 , file-embed >= 0.0.4.1 && < 0.5 - , http-types >= 0.6.5 && < 0.7 + , http-types >= 0.7 && < 0.8 , unix-compat >= 0.2 , conduit >= 0.5 && < 0.6 , crypto-conduit >= 0.4 && < 0.5 @@ -61,7 +61,7 @@ test-suite tests , wai , text >= 0.9 && < 1.0 , file-embed >= 0.0.4.1 && < 0.5 - , http-types >= 0.6.5 && < 0.7 + , http-types , unix-compat >= 0.2 , conduit , crypto-conduit diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 312eb889..5d8c371f 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -69,6 +69,7 @@ import qualified Test.Hspec.Runner as Runner import qualified Data.List as DL import qualified Data.Maybe as DY import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString (ByteString) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy.Char8 as BSL8 @@ -123,7 +124,7 @@ instance HoldsResponse OneSpecData where instance HoldsResponse RequestBuilderData where readResponse (RequestBuilderData _ x) = x -type CookieValue = H.Ascii +type CookieValue = ByteString -- | Runs your test suite, using you wai 'Application' and 'ConnectionPool' for performing -- the database queries in your tests. diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 793e5d93..758e10c1 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -22,7 +22,7 @@ library , wai >= 1.3 && < 1.4 , wai-test >= 1.3 && < 1.4 , network >= 2.2 && < 2.4 - , http-types >= 0.6 && < 0.7 + , http-types >= 0.7 && < 0.8 , HUnit >= 1.2 && < 1.3 , hspec >= 1.2 && < 1.3 , bytestring >= 0.9 diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 3316aa32..45fcc303 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -99,7 +99,7 @@ executable yesod , unix-compat >= 0.2 && < 0.4 , containers >= 0.2 , attoparsec >= 0.10 - , http-types >= 0.6.1 && < 0.7 + , http-types >= 0.7 && < 0.8 , blaze-builder >= 0.2.1.4 && < 0.4 , filepath >= 1.1 , process From d5c0418559d10b690409f07a7babfd22e8cba666 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Jul 2012 09:45:23 +0300 Subject: [PATCH 144/250] keter.conf -> keter.yaml --- yesod/yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 45fcc303..6e143fda 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -51,7 +51,7 @@ extra-source-files: scaffold/templates/boilerplate-wrapper.hamlet.cg scaffold/templates/homepage.lucius.cg scaffold/messages/en.msg.cg - scaffold/config/keter.conf.cg + scaffold/config/keter.yaml.cg scaffold/config/models.cg scaffold/config/mysql.yml.cg scaffold/config/sqlite.yml.cg From debbdc4aed2e2a5c9fa30aca2a75487babe8ef42 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Jul 2012 13:40:24 +0300 Subject: [PATCH 145/250] Removed HtmlParse --- yesod-test/Yesod/Test/HtmlParse.hs | 14 -------------- yesod-test/Yesod/Test/TransversingCSS.hs | 4 ++-- yesod-test/test/main.hs | 6 +++--- yesod-test/yesod-test.cabal | 2 +- 4 files changed, 6 insertions(+), 20 deletions(-) delete mode 100644 yesod-test/Yesod/Test/HtmlParse.hs diff --git a/yesod-test/Yesod/Test/HtmlParse.hs b/yesod-test/Yesod/Test/HtmlParse.hs deleted file mode 100644 index ca7238c8..00000000 --- a/yesod-test/Yesod/Test/HtmlParse.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Parse an HTML document into xml-conduit's Document. --- --- Assumes UTF-8 encoding. -module Yesod.Test.HtmlParse - ( parseHtml - ) where - -import qualified Data.ByteString.Lazy as L -import Text.XML (Document) -import qualified Text.HTML.DOM as HD - -parseHtml :: L.ByteString -> Either String Document -parseHtml = Right . HD.parseLBS diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index d123a615..743f778f 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -41,11 +41,11 @@ where import Yesod.Test.CssQuery import qualified Data.Text as T -import Yesod.Test.HtmlParse (parseHtml) import Control.Applicative ((<$>), (<*>)) import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L +import qualified Text.HTML.DOM as HD #if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.String (renderHtml) @@ -64,7 +64,7 @@ type Html = L.ByteString -- * Right: List of matching Html fragments. findBySelector :: Html -> Query -> Either String [String] findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x) - <$> (fromDocument <$> parseHtml html) + <$> (Right $ fromDocument $ HD.parseLBS html) <*> parseQuery query -- Run a compiled query on Html, returning a list of matching Html fragments. diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index b7f605ad..7ff5b43c 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -5,18 +5,18 @@ import Test.Hspec.HUnit () import Yesod.Test.CssQuery import Yesod.Test.TransversingCSS -import Yesod.Test.HtmlParse import Text.XML import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map +import qualified Text.HTML.DOM as HD parseQuery_ = either error id . parseQuery findBySelector_ x = either error id . findBySelector x -parseHtml_ = either error id . parseHtml +parseHtml_ = HD.parseLBS main :: IO () -main = hspecX $ do +main = hspec $ do describe "CSS selector parsing" $ do it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]] it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]] diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 758e10c1..9881f99b 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -38,7 +38,6 @@ library exposed-modules: Yesod.Test Yesod.Test.CssQuery Yesod.Test.TransversingCSS - Yesod.Test.HtmlParse ghc-options: -Wall test-suite test @@ -52,6 +51,7 @@ test-suite test , xml-conduit , bytestring , containers + , html-conduit source-repository head type: git From 288f3b36eb78ad6c55e0511b2d499bab24af1afb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Jul 2012 14:14:45 +0300 Subject: [PATCH 146/250] fast-logger/monad-logger 0.2 --- yesod-core/Yesod/Internal/Core.hs | 12 ++++++------ yesod-core/yesod-core.cabal | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 2335dca2..2ae32d5c 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -86,9 +86,9 @@ import Network.Wai.Middleware.Gzip (GzipSettings, def) import Network.Wai.Parse (tempFileSink, lbsSink) import qualified Paths_yesod_core import Data.Version (showVersion) -import System.Log.FastLogger (Logger, mkLogger, loggerDateRef, LogStr (..), loggerPutStr) +import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr) import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther)) -import System.Log.FastLogger.Date (getDate, DateRef) +import System.Log.FastLogger.Date (ZonedDate) import System.IO (stdout) yesodVersion :: String @@ -304,7 +304,7 @@ $doctype 5 messageLogger a logger loc level msg = if level < logLevel a then return () - else formatLogMessage (loggerDateRef logger) loc level msg >>= loggerPutStr logger + else formatLogMessage (loggerDate logger) loc level msg >>= loggerPutStr logger -- | The logging level in place for this application. Any messages below -- this level will simply be ignored. @@ -343,13 +343,13 @@ $doctype 5 | size > 50000 = FileUploadDisk tempFileSink | otherwise = FileUploadMemory lbsSink -formatLogMessage :: DateRef +formatLogMessage :: IO ZonedDate -> Loc -> LogLevel -> LogStr -- ^ message -> IO [LogStr] -formatLogMessage dateref loc level msg = do - now <- getDate dateref +formatLogMessage getdate loc level msg = do + now <- getdate return [ LB now , LB " [" diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index c19b3333..ffd641a0 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -77,8 +77,8 @@ library , directory >= 1 && < 1.2 , vector >= 0.9 && < 0.10 , aeson >= 0.5 - , fast-logger >= 0.1 && < 0.2 - , monad-logger >= 0.0 && < 0.1 + , fast-logger >= 0.2 && < 0.3 + , monad-logger >= 0.2 && < 0.3 , conduit >= 0.5 && < 0.6 , resourcet >= 0.3 && < 0.4 , lifted-base >= 0.1 && < 0.2 From 0dbd724155284c494a3d8b805e2d34550b41be78 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Jul 2012 14:15:10 +0300 Subject: [PATCH 147/250] Remove hxt dep from yesod-test (#382) --- yesod-test/Yesod/Test.hs | 98 ++++++++++++++++++++++--------------- yesod-test/yesod-test.cabal | 1 - 2 files changed, 58 insertions(+), 41 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 5d8c371f..167e030b 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -78,7 +78,6 @@ import qualified Test.Hspec.HUnit () import qualified Network.HTTP.Types as H import qualified Network.Socket.Internal as Sock import Data.CaseInsensitive (CI) -import Text.XML.HXT.Core hiding (app, err) import Network.Wai import Network.Wai.Test hiding (assertHeader, assertNoHeader) import qualified Control.Monad.Trans.State as ST @@ -89,6 +88,8 @@ import Database.Persist.GenericSql import Data.Monoid (mappend) import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) +import Text.XML.Cursor hiding (element) +import qualified Text.HTML.DOM as HD -- | The state used in 'describe' to build a list of specs data SpecsData = SpecsData Application ConnectionPool [Core.Spec] @@ -106,8 +107,8 @@ data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse) -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart - = ReqPlainPart String String - | ReqFilePart String FilePath BSL8.ByteString String + = ReqPlainPart T.Text T.Text + | ReqFilePart T.Text FilePath BSL8.ByteString T.Text -- | The RequestBuilder state monad constructs an url encoded string of arguments -- to send with your requests. Some of the functions that run on it use the current @@ -164,14 +165,14 @@ withResponse f = maybe err f =<< fmap readResponse ST.get -- | Use HXT to parse a value from an html tag. -- Check for usage examples in this module's source. -parseHTML :: Html -> LA XmlTree a -> [a] -parseHTML html p = runLA (hread >>> p ) (TL.unpack $ decodeUtf8 html) +parseHTML :: Html -> (Cursor -> [a]) -> [a] +parseHTML html p = p $ fromDocument $ HD.parseLBS html -- | Query the last response using css selectors, returns a list of matched fragments htmlQuery :: HoldsResponse a => Query -> ST.StateT a IO [Html] htmlQuery query = withResponse $ \ res -> case findBySelector (simpleBody res) query of - Left err -> failure $ T.unpack query ++ " did not parse: " ++ (show err) + Left err -> failure $ query <> " did not parse: " <> T.pack (show err) Right matches -> return $ map (encodeUtf8 . TL.pack) matches -- | Asserts that the two given values are equal. @@ -190,7 +191,7 @@ statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> assertHeader :: HoldsResponse a => CI BS8.ByteString -> BS8.ByteString -> ST.StateT a IO () assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of - Nothing -> failure $ concat + Nothing -> failure $ T.pack $ concat [ "Expected header " , show header , " to be " @@ -211,7 +212,7 @@ assertNoHeader :: HoldsResponse a => CI BS8.ByteString -> ST.StateT a IO () assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> return () - Just s -> failure $ concat + Just s -> failure $ T.pack $ concat [ "Unexpected header " , show header , " containing " @@ -241,7 +242,7 @@ htmlAllContain :: HoldsResponse a => Query -> String -> ST.StateT a IO () htmlAllContain query search = do matches <- htmlQuery query case matches of - [] -> failure $ "Nothing matched css query: "++T.unpack query + [] -> failure $ "Nothing matched css query: " <> query _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $ DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) @@ -265,7 +266,7 @@ printMatches query = do liftIO $ hPutStrLn stderr $ show matches -- | Add a parameter with the given name and value. -byName :: String -> String -> RequestBuilder () +byName :: T.Text -> T.Text -> RequestBuilder () byName name value = do RequestBuilderData parts r <- ST.get ST.put $ RequestBuilderData ((ReqPlainPart name value):parts) r @@ -273,50 +274,67 @@ byName name value = do -- | Add a file to be posted with the current request -- -- Adding a file will automatically change your request content-type to be multipart/form-data -fileByName :: String -> FilePath -> String -> RequestBuilder () +fileByName :: T.Text -> FilePath -> T.Text -> RequestBuilder () fileByName name path mimetype = do RequestBuilderData parts r <- ST.get contents <- liftIO $ BSL8.readFile path ST.put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r -- This looks up the name of a field based on the contents of the label pointing to it. -nameFromLabel :: String -> RequestBuilder String +nameFromLabel :: T.Text -> RequestBuilder T.Text nameFromLabel label = withResponse $ \ res -> do let body = simpleBody res escaped = escapeHtmlEntities label - mfor = parseHTML body $ deep $ hasName "label" - >>> filterA (xshow this >>> mkText >>> hasText (DL.isInfixOf escaped)) - >>> getAttrValue "for" + mfor = parseHTML body $ \c -> c + $// attributeIs "name" "label" + >=> contentContains escaped + >=> attribute "for" + + contentContains x c + | x `T.isInfixOf` T.concat (c $// content) = [c] + | otherwise = [] case mfor of for:[] -> do - let mname = parseHTML body $ deep $ hasAttrValue "id" (==for) >>> getAttrValue "name" + let mname = parseHTML body $ \c -> c + $// attributeIs "id" for + >=> attribute "name" case mname of - "":_ -> failure $ "Label "++label++" resolved to id "++for++" which was not found. " + "":_ -> failure $ T.concat + [ "Label " + , label + , " resolved to id " + , for + , " which was not found. " + ] name:_ -> return name - _ -> failure $ "More than one input with id " ++ for - [] -> failure $ "No label contained: "++label - _ -> failure $ "More than one label contained "++label + _ -> failure $ "More than one input with id " <> for + [] -> failure $ "No label contained: " <> label + _ -> failure $ "More than one label contained " <> label + +(<>) :: T.Text -> T.Text -> T.Text +(<>) = T.append -- | Escape HTML entities in a string, so you can write the text you want in -- label lookups without worrying about the fact that yesod escapes some characters. -escapeHtmlEntities :: String -> String -escapeHtmlEntities "" = "" -escapeHtmlEntities (c:cs) = case c of - '<' -> '&' : 'l' : 't' : ';' : escapeHtmlEntities cs - '>' -> '&' : 'g' : 't' : ';' : escapeHtmlEntities cs - '&' -> '&' : 'a' : 'm' : 'p' : ';' : escapeHtmlEntities cs - '"' -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeHtmlEntities cs - '\'' -> '&' : '#' : '3' : '9' : ';' : escapeHtmlEntities cs - x -> x : escapeHtmlEntities cs +escapeHtmlEntities :: T.Text -> T.Text +escapeHtmlEntities = + T.concatMap go + where + go '<' = "<" + go '>' = ">" + go '&' = "&" + go '"' = """ + go '\'' = "'" + go x = T.singleton x -byLabel :: String -> String -> RequestBuilder () +byLabel :: T.Text -> T.Text -> RequestBuilder () byLabel label value = do name <- nameFromLabel label byName name value -fileByLabel :: String -> FilePath -> String -> RequestBuilder () +fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder () fileByLabel label path mime = do name <- nameFromLabel label fileByName name path mime @@ -328,7 +346,7 @@ addNonce_ scope = do matches <- htmlQuery $ scope `mappend` "input[name=_token][type=hidden][value]" case matches of [] -> failure $ "No nonce found in the current page" - element:[] -> byName "_token" $ head $ parseHTML element $ getAttrValue "value" + element:[] -> byName "_token" $ head $ parseHTML element $ attribute "value" _ -> failure $ "More than one nonce found in the page" -- | For responses that display a single form, just lookup the only nonce available. @@ -380,22 +398,22 @@ doRequest method url paramsBuild = do BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] multipartPart (ReqPlainPart k v) = BS8.concat [ "Content-Disposition: form-data; " - , "name=\"", (BS8.pack k), "\"\r\n\r\n" - , (BS8.pack v), "\r\n"] + , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n" + , TE.encodeUtf8 v, "\r\n"] multipartPart (ReqFilePart k v bytes mime) = BS8.concat [ "Content-Disposition: form-data; " - , "name=\"", BS8.pack k, "\"; " + , "name=\"", TE.encodeUtf8 k, "\"; " , "filename=\"", BS8.pack v, "\"\r\n" - , "Content-Type: ", BS8.pack mime, "\r\n\r\n" + , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n" , BS8.concat $ BSL8.toChunks bytes, "\r\n"] -- For building the regular non-multipart requests makeSinglepart cookie parts = SRequest (mkRequest [("Cookie",cookie), ("Content-Type", "application/x-www-form-urlencoded")]) $ - BSL8.pack $ DL.concat $ DL.intersperse "&" $ map singlepartPart parts + BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts singlepartPart (ReqFilePart _ _ _ _) = "" - singlepartPart (ReqPlainPart k v) = concat [k,"=",v] + singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v] -- General request making mkRequest headers = defaultRequest @@ -414,5 +432,5 @@ runDB query = do liftIO $ runSqlPool query pool -- Yes, just a shortcut -failure :: (MonadIO a) => String -> a b -failure reason = (liftIO $ HUnit.assertFailure reason) >> error "" +failure :: (MonadIO a) => T.Text -> a b +failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error "" diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 9881f99b..64e240df 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -15,7 +15,6 @@ extra-source-files: README.md, LICENSE, test/main.hs library build-depends: base >= 4.3 && < 5 - , hxt >= 9.1.6 , attoparsec >= 0.10 && < 0.11 , persistent >= 1.0 && < 1.1 , transformers >= 0.2.2 && < 0.4 From fffb3028c98eb8879bc60acc88b45c94426c1dee Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 9 Jul 2012 15:11:24 +0300 Subject: [PATCH 148/250] Export FileUpload (#262) --- yesod-core/Yesod/Core.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 661d8ec6..8a5c2cb3 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -10,6 +10,7 @@ module Yesod.Core , breadcrumbs -- * Types , Approot (..) + , FileUpload (..) -- * Utitlities , maybeAuthorized , widgetToPageContent From 58647e4826d47e9b6bbcd8c13827abd6dbf55402 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 11 Jul 2012 15:10:38 +0300 Subject: [PATCH 149/250] yesod keter (#359) --- yesod/Keter.hs | 69 +++++++++++++++++++++++++++++ yesod/main.hs | 6 +++ yesod/scaffold/config/keter.yaml.cg | 6 ++- yesod/yesod.cabal | 7 +++ 4 files changed, 87 insertions(+), 1 deletion(-) create mode 100644 yesod/Keter.hs diff --git a/yesod/Keter.hs b/yesod/Keter.hs new file mode 100644 index 00000000..8a246509 --- /dev/null +++ b/yesod/Keter.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +module Keter + ( keter + ) where + +import Data.Yaml +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T +import System.Exit +import System.Cmd +import Control.Monad +import System.Directory +import Data.Maybe (mapMaybe) +import qualified Filesystem.Path.CurrentOS as F +import qualified Filesystem as F +import qualified Codec.Archive.Tar as Tar +import Control.Exception +import qualified Data.ByteString.Lazy as L +import Codec.Compression.GZip (compress) + +run :: String -> [String] -> IO () +run a b = do + ec <- rawSystem a b + unless (ec == ExitSuccess) $ exitWith ec + +keter :: String -- ^ cabal command + -> Bool -- ^ no build? + -> IO () +keter cabal noBuild = do + mvalue <- decodeFile "config/keter.yaml" + value <- + case mvalue of + Nothing -> error "No config/keter.yaml found" + Just (Object value) -> + case Map.lookup "host" value of + Just (String s) | "<<" `T.isPrefixOf` s -> + error "Please set your hostname in config/keter.yaml" + _ -> return value + Just _ -> error "config/keter.yaml is not an object" + + files <- getDirectoryContents "." + project <- + case mapMaybe (T.stripSuffix ".cabal" . T.pack) files of + [x] -> return x + [] -> error "No cabal file found" + _ -> error "Too many cabal files found" + + exec <- + case Map.lookup "exec" value of + Just (String s) -> return $ F.collapse $ "config" F. F.fromText s + _ -> error "exec not found in config/keter.yaml" + + unless noBuild $ do + run cabal ["clean"] + run cabal ["configure"] + run cabal ["build"] + + _ <- try' $ F.removeTree "static/tmp" + + archive <- Tar.pack "" [F.encodeString exec, "config", "static"] + let fp = T.unpack project ++ ".keter" + L.writeFile fp $ compress $ Tar.write archive + + case Map.lookup "copy-to" value of + Just (String s) -> run "scp" [fp, T.unpack s] + _ -> return () + +try' :: IO a -> IO (Either SomeException a) +try' = try diff --git a/yesod/main.hs b/yesod/main.hs index 6b5c136c..7e7ef772 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -12,6 +12,7 @@ import Build (touch) #endif import Devel (devel) import AddHandler (addHandler) +import Keter (keter) windowsWarning :: String #ifdef WINDOWS @@ -48,6 +49,8 @@ main = do ["version"] -> putStrLn $ "yesod-core version:" ++ yesodVersion "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith ["add-handler"] -> addHandler + ["keter"] -> keter cmd False + ["keter", "--nobuild"] -> keter cmd True _ -> do putStrLn "Usage: yesod " putStrLn "Available commands:" @@ -62,6 +65,9 @@ main = do putStrLn " test Build and run the integration tests" putStrLn " use --dev devel to build with cabal-dev" putStrLn " add-handler Add a new handler and module to your project" + putStrLn " keter Build a keter bundle" + putStrLn " use --dev devel to build with cabal-dev" + putStrLn " use --nobuild to skip rebuilding" putStrLn " version Print the version of Yesod" -- | Like @rawSystem@, but exits if it receives a non-success result. diff --git a/yesod/scaffold/config/keter.yaml.cg b/yesod/scaffold/config/keter.yaml.cg index fde81084..c21f2210 100644 --- a/yesod/scaffold/config/keter.yaml.cg +++ b/yesod/scaffold/config/keter.yaml.cg @@ -1,4 +1,8 @@ exec: ../dist/build/~project~/~project~ args: - production -host: ~project~.yesodweb.com +host: <> + +# Use the following to automatically copy your bundle upon creation via `yesod +# keter`. Uses `scp` internally, so you can set it to a remote destination +# copy-to: user@host:/opt/keter/incoming diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 6e143fda..6e2eac11 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -103,12 +103,19 @@ executable yesod , blaze-builder >= 0.2.1.4 && < 0.4 , filepath >= 1.1 , process + , zlib >= 0.5 && < 0.6 + , tar >= 0.4 && < 0.5 + , system-filepath >= 0.4 && < 0.5 + , system-fileio >= 0.3 && < 0.4 + , unordered-containers + , yaml >= 0.8 && < 0.9 ghc-options: -Wall -threaded main-is: main.hs other-modules: Scaffolding.CodeGen Scaffolding.Scaffolder Devel Build + Keter AddHandler source-repository head From 33c39662b994a2bf85c0a04d7b45bb64af8e9f82 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 11 Jul 2012 15:58:36 +0300 Subject: [PATCH 150/250] Reflect wai changes for #262 --- yesod-core/Yesod/Handler.hs | 7 +++---- yesod-core/Yesod/Internal/Core.hs | 6 +++--- yesod-core/Yesod/Internal/Request.hs | 6 +++--- 3 files changed, 9 insertions(+), 10 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 0e355161..4640fba8 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -178,7 +178,6 @@ import Control.Monad.Trans.Resource import Control.Monad.Base import Yesod.Routes.Class import Data.Word (Word64) -import Data.Conduit (Sink) import Language.Haskell.TH.Syntax (Loc) class YesodSubRoute s y where @@ -343,12 +342,12 @@ rbHelper upload = FileUploadDisk s -> rbHelper' s mkFileInfoFile FileUploadSource s -> rbHelper' s mkFileInfoSource -rbHelper' :: Sink S8.ByteString (ResourceT IO) x +rbHelper' :: NWP.BackEnd x -> (Text -> Text -> x -> FileInfo) -> W.Request -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)]) -rbHelper' sink mkFI req = - (map fix1 *** map fix2) <$> (NWP.parseRequestBody sink req) +rbHelper' backend mkFI req = + (map fix1 *** map fix2) <$> (NWP.parseRequestBody backend req) where fix1 = go *** go fix2 (x, NWP.FileInfo a b c) = diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 2ae32d5c..0eb78497 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -83,7 +83,7 @@ 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 (tempFileSink, lbsSink) +import Network.Wai.Parse (tempFileBackEnd, lbsBackEnd) import qualified Paths_yesod_core import Data.Version (showVersion) import System.Log.FastLogger (Logger, mkLogger, loggerDate, LogStr (..), loggerPutStr) @@ -340,8 +340,8 @@ $doctype 5 -> Word64 -- ^ request body size -> FileUpload fileUpload _ size - | size > 50000 = FileUploadDisk tempFileSink - | otherwise = FileUploadMemory lbsSink + | size > 50000 = FileUploadDisk tempFileBackEnd + | otherwise = FileUploadMemory lbsBackEnd formatLogMessage :: IO ZonedDate -> Loc diff --git a/yesod-core/Yesod/Internal/Request.hs b/yesod-core/Yesod/Internal/Request.hs index d23baaa7..3fe09758 100644 --- a/yesod-core/Yesod/Internal/Request.hs +++ b/yesod-core/Yesod/Internal/Request.hs @@ -145,6 +145,6 @@ 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 (Sink ByteString (ResourceT IO) L.ByteString) - | FileUploadDisk (Sink ByteString (ResourceT IO) FilePath) - | FileUploadSource (Sink ByteString (ResourceT IO) (Source (ResourceT IO) ByteString)) +data FileUpload = FileUploadMemory (NWP.BackEnd L.ByteString) + | FileUploadDisk (NWP.BackEnd FilePath) + | FileUploadSource (NWP.BackEnd (Source (ResourceT IO) ByteString)) From 14f1fd1e27b5b7bb606946e561343ff015d04ece Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Jul 2012 16:20:10 +0300 Subject: [PATCH 151/250] Better parseTime --- yesod-form/Yesod/Form/Fields.hs | 72 ++++++++++++++++++++++----------- yesod-form/Yesod/Form/Types.hs | 1 + yesod-form/test/main.hs | 34 ++++++++++++++++ yesod-form/yesod-form.cabal | 14 ++++++- 4 files changed, 96 insertions(+), 25 deletions(-) create mode 100644 yesod-form/test/main.hs diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 81bb67b5..1d051dbc 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -67,7 +67,7 @@ import Database.Persist (PersistField) import Database.Persist.Store (Entity (..)) import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) -import Data.Maybe (listToMaybe) +import Data.Maybe (listToMaybe, fromMaybe) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) @@ -92,7 +92,9 @@ import Yesod.Core (toPathPiece, GHandler, PathPiece, fromPathPiece) import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery) import Control.Arrow ((&&&)) -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), (<|>)) + +import Data.Attoparsec.Text defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage @@ -145,7 +147,7 @@ $newline never timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field - { fieldParse = blank $ parseTime . unpack + { fieldParse = blank parseTime , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never @@ -239,29 +241,51 @@ parseDate = maybe (Left MsgInvalidDay) Right replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) -parseTime :: String -> Either FormMessage TimeOfDay -parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) = - parseTimeHelper (h1, h2, m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) = - let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12 - in parseTimeHelper (h1', h2', m1, m2, '0', '0') -parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) = - parseTimeHelper (h1, h2, m1, m2, s1, s2) -parseTime _ = Left MsgInvalidTimeFormat +parseTime :: Text -> Either FormMessage TimeOfDay +parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either FormMessage TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2] - | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2] - | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2] - | otherwise = Right $ TimeOfDay h m s +timeParser :: Parser TimeOfDay +timeParser = do + skipSpace + h <- hour + _ <- char ':' + m <- minsec MsgInvalidMinute + hasSec <- (char ':' >> return True) <|> return False + s <- if hasSec then minsec MsgInvalidSecond else return 0 + skipSpace + isPM <- + (string "am" >> return (Just False)) <|> + (string "AM" >> return (Just False)) <|> + (string "pm" >> return (Just True)) <|> + (string "PM" >> return (Just True)) <|> + return Nothing + h' <- + case isPM of + Nothing -> return h + Just x + | h <= 0 || h > 12 -> fail $ show $ MsgInvalidHour $ pack $ show h + | h == 12 -> return $ if x then 12 else 0 + | otherwise -> return $ h + (if x then 12 else 0) + skipSpace + endOfInput + return $ TimeOfDay h' m s where - h = read [h1, h2] -- FIXME isn't this a really bad idea? - m = read [m1, m2] - s = fromInteger $ read [s1, s2] + hour = do + x <- digit + y <- (return <$> digit) <|> return [] + let xy = x : y + let i = read xy + if i < 0 || i >= 24 + then fail $ show $ MsgInvalidHour $ pack xy + else return i + minsec msg = do + x <- digit + y <- digit <|> fail (show $ msg $ pack [x]) + let xy = [x, y] + let i = read xy + if i < 0 || i >= 60 + then fail $ show $ msg $ pack xy + else return i emailField :: RenderMessage master FormMessage => Field sub master Text emailField = Field diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index 8cd47115..d444166b 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -151,3 +151,4 @@ data FormMessage = MsgInvalidInteger Text | MsgBoolYes | MsgBoolNo | MsgDelete + deriving (Show, Eq, Read) diff --git a/yesod-form/test/main.hs b/yesod-form/test/main.hs new file mode 100644 index 00000000..5cbde19f --- /dev/null +++ b/yesod-form/test/main.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.HUnit +import Test.Hspec.Monadic +import Test.Hspec.HUnit () +import Data.Time (TimeOfDay (TimeOfDay)) +import Data.Text (pack) + +import Yesod.Form.Fields (parseTime) +import Yesod.Form.Types + +main :: IO () +main = hspec $ + describe "parseTime" $ mapM_ (\(s, e) -> it s $ parseTime (pack s) @?= e) + [ ("01:00:00", Right $ TimeOfDay 1 0 0) + , ("1:00", Right $ TimeOfDay 1 0 0) + , ("1:00 AM", Right $ TimeOfDay 1 0 0) + , ("1:00 am", Right $ TimeOfDay 1 0 0) + , ("1:00AM", Right $ TimeOfDay 1 0 0) + , ("1:00am", Right $ TimeOfDay 1 0 0) + , ("01:00:00am", Right $ TimeOfDay 1 0 0) + , ("01:00:00 am", Right $ TimeOfDay 1 0 0) + , ("01:00:00AM", Right $ TimeOfDay 1 0 0) + , ("01:00:00 AM", Right $ TimeOfDay 1 0 0) + , ("1:00:01", Right $ TimeOfDay 1 0 1) + , ("1:00:02 AM", Right $ TimeOfDay 1 0 2) + , ("1:00:04 am", Right $ TimeOfDay 1 0 4) + , ("1:00:64 am", Left $ MsgInvalidSecond "64") + , ("1:00:4 am", Left $ MsgInvalidSecond "4") + , ("0:00", Right $ TimeOfDay 0 0 0) + , ("12:00am", Right $ TimeOfDay 0 0 0) + , ("12:00pm", Right $ TimeOfDay 12 0 0) + , ("12:7pm", Left $ MsgInvalidMinute "7") + , ("23:47", Right $ TimeOfDay 23 47 0) + ] diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index bed5bd56..4733da89 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -7,7 +7,7 @@ maintainer: Michael Snoyman synopsis: Form handling support for Yesod Web Framework category: Web, Yesod stability: Stable -cabal-version: >= 1.6 +cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ description: Form handling support for Yesod Web Framework @@ -34,6 +34,7 @@ library , containers >= 0.2 , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 + , attoparsec >= 0.10 && < 0.11 exposed-modules: Yesod.Form Yesod.Form.Class @@ -54,6 +55,17 @@ library -- FIXME Yesod.Helpers.Crud ghc-options: -Wall +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + build-depends: base + , yesod-form + , time + , hspec + , HUnit + , text + source-repository head type: git location: https://github.com/yesodweb/yesod From c005bc0aec49ded404e3ec5c58d66119a9206ff2 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Jul 2012 16:26:32 +0300 Subject: [PATCH 152/250] Fix a warning --- yesod-form/Yesod/Form/Fields.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 1d051dbc..8845f13d 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -94,7 +94,7 @@ import Control.Arrow ((&&&)) import Control.Applicative ((<$>), (<|>)) -import Data.Attoparsec.Text +import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly) defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage From 128a9bd1d4cbfa9284db0f958631346d43073dc7 Mon Sep 17 00:00:00 2001 From: Robert Date: Fri, 13 Jul 2012 10:08:59 -0500 Subject: [PATCH 153/250] Additional tests on 12 am/pm variants. --- yesod-form/test/main.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/yesod-form/test/main.hs b/yesod-form/test/main.hs index 5cbde19f..3b0a8edc 100644 --- a/yesod-form/test/main.hs +++ b/yesod-form/test/main.hs @@ -28,7 +28,13 @@ main = hspec $ , ("1:00:4 am", Left $ MsgInvalidSecond "4") , ("0:00", Right $ TimeOfDay 0 0 0) , ("12:00am", Right $ TimeOfDay 0 0 0) + , ("12:59:59am", Right $ TimeOfDay 0 59 59) + , ("12:59:60am", Left $ MsgInvalidSecond "60") + , ("12:60:59am", Left $ MsgInvalidMinute "60) , ("12:00pm", Right $ TimeOfDay 12 0 0) + , ("12:59:59pm", Right $ TimeOfDay 12 59 59) + , ("12:59:60pm", Right $ MsgInvalidSecond "60") + , ("12:60:59pm", Right $ MsgInvalidMinute "60") , ("12:7pm", Left $ MsgInvalidMinute "7") , ("23:47", Right $ TimeOfDay 23 47 0) ] From b9d589056792e0f01d7aed32af1bd17d2ae35c40 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 13 Jul 2012 18:37:42 +0300 Subject: [PATCH 154/250] Add a type signature --- yesod-form/Yesod/Form/Fields.hs | 1 + yesod-form/test/main.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 8845f13d..dffe8f94 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -278,6 +278,7 @@ timeParser = do if i < 0 || i >= 24 then fail $ show $ MsgInvalidHour $ pack xy else return i + minsec :: (Num a, Read a, Ord a) => (Text -> FormMessage) -> Parser a minsec msg = do x <- digit y <- digit <|> fail (show $ msg $ pack [x]) diff --git a/yesod-form/test/main.hs b/yesod-form/test/main.hs index 5cbde19f..8d02f1e9 100644 --- a/yesod-form/test/main.hs +++ b/yesod-form/test/main.hs @@ -24,6 +24,7 @@ main = hspec $ , ("1:00:01", Right $ TimeOfDay 1 0 1) , ("1:00:02 AM", Right $ TimeOfDay 1 0 2) , ("1:00:04 am", Right $ TimeOfDay 1 0 4) + , ("1:00:05 am", Right $ read "01:00:05") , ("1:00:64 am", Left $ MsgInvalidSecond "64") , ("1:00:4 am", Left $ MsgInvalidSecond "4") , ("0:00", Right $ TimeOfDay 0 0 0) From b4d1b2087c86345def0be27f839ca4731b1e5cba Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sat, 14 Jul 2012 21:54:52 +0300 Subject: [PATCH 155/250] Fix for missing Read instance on Fixed --- yesod-form/Yesod/Form/Fields.hs | 4 ++-- yesod-form/test/main.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index dffe8f94..51b6b5b8 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -278,7 +278,7 @@ timeParser = do if i < 0 || i >= 24 then fail $ show $ MsgInvalidHour $ pack xy else return i - minsec :: (Num a, Read a, Ord a) => (Text -> FormMessage) -> Parser a + minsec :: Num a => (Text -> FormMessage) -> Parser a minsec msg = do x <- digit y <- digit <|> fail (show $ msg $ pack [x]) @@ -286,7 +286,7 @@ timeParser = do let i = read xy if i < 0 || i >= 60 then fail $ show $ msg $ pack xy - else return i + else return $ fromIntegral (i :: Int) emailField :: RenderMessage master FormMessage => Field sub master Text emailField = Field diff --git a/yesod-form/test/main.hs b/yesod-form/test/main.hs index 42581522..eed2a71f 100644 --- a/yesod-form/test/main.hs +++ b/yesod-form/test/main.hs @@ -31,11 +31,11 @@ main = hspec $ , ("12:00am", Right $ TimeOfDay 0 0 0) , ("12:59:59am", Right $ TimeOfDay 0 59 59) , ("12:59:60am", Left $ MsgInvalidSecond "60") - , ("12:60:59am", Left $ MsgInvalidMinute "60) + , ("12:60:59am", Left $ MsgInvalidMinute "60") , ("12:00pm", Right $ TimeOfDay 12 0 0) , ("12:59:59pm", Right $ TimeOfDay 12 59 59) - , ("12:59:60pm", Right $ MsgInvalidSecond "60") - , ("12:60:59pm", Right $ MsgInvalidMinute "60") + , ("12:59:60pm", Left $ MsgInvalidSecond "60") + , ("12:60:59pm", Left $ MsgInvalidMinute "60") , ("12:7pm", Left $ MsgInvalidMinute "7") , ("23:47", Right $ TimeOfDay 23 47 0) ] From 6c834ec0cc0f76964ae6b5a70c0819fb7c5e6865 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 24 Jul 2012 10:38:05 +0300 Subject: [PATCH 156/250] Put getExtra in scaffolded Foundation.hs --- yesod/scaffold/Foundation.hs.cg | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/yesod/scaffold/Foundation.hs.cg b/yesod/scaffold/Foundation.hs.cg index 41f05973..ddbd07be 100644 --- a/yesod/scaffold/Foundation.hs.cg +++ b/yesod/scaffold/Foundation.hs.cg @@ -10,6 +10,7 @@ module Foundation , requireAuth , module Settings , module Model + , getExtra ) where import Prelude @@ -149,6 +150,10 @@ instance YesodAuth ~sitearg~ where instance RenderMessage ~sitearg~ FormMessage where renderMessage _ _ = defaultFormMessage +-- | Get the 'Extra' value, used to hold data from the settings.yml file. +getExtra :: Handler Extra +getExtra = fmap (appExtra . settings) getYesod + -- Note: previous versions of the scaffolding included a deliver function to -- send emails. Unfortunately, there are too many different options for us to -- give a reasonable default. Instead, the information is available on the From f91ff4fde2ee1dcfb8e8ebc48ce75477936c34bd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 24 Jul 2012 17:49:17 +0300 Subject: [PATCH 157/250] fullyEvaluateBody --- yesod-core/Yesod/Handler.hs | 27 ++++++++++++---- yesod-core/Yesod/Internal/Core.hs | 20 +++++++++++- .../test/YesodCoreTest/ErrorHandling.hs | 31 ++++++++++++++++++- 3 files changed, 70 insertions(+), 8 deletions(-) diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index 4640fba8..b0a357fd 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -146,6 +146,7 @@ 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 @@ -158,7 +159,7 @@ 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) +import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString) import Data.Text (Text) import Yesod.Message (RenderMessage (..)) @@ -394,8 +395,9 @@ runHandler :: HasReps c -> sub -> (Word64 -> FileUpload) -> (Loc -> LogLevel -> LogStr -> IO ()) + -> Bool -- ^ to eval body? -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' = +runHandler handler mrender sroute tomr master sub upload log' toEval = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of @@ -438,7 +440,10 @@ runHandler handler mrender sroute tomr master sub upload log' = case contents of HCContent status a -> do (ct, c) <- liftIO $ a cts - return $ YARPlain status (appEndo headers []) ct c finalSession + ec' <- if toEval then liftIO $ evaluateContent c else return (Right c) + case ec' of + Left e -> handleError e + Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession HCError e -> handleError e HCRedirect status loc -> do let hs = Header "Location" (encodeUtf8 loc) : appEndo headers [] @@ -458,6 +463,15 @@ runHandler handler mrender sroute tomr master sub upload log' = finalSession HCWai r -> return $ YARWai r +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 = YesodApp $ \_ _ _ session -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er @@ -792,6 +806,7 @@ handlerToYAR :: (HasReps a, HasReps b) -> sub -- ^ sub site foundation -> (Word64 -> FileUpload) -> (Loc -> LogLevel -> LogStr -> IO ()) + -> Bool -- ^ to eval body? -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a) @@ -800,11 +815,11 @@ handlerToYAR :: (HasReps a, HasReps b) -> SessionMap -> GHandler sub master b -> ResourceT IO YesodAppResult -handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = +handlerToYAR y s upload log' toEval toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where - ya = runHandler h render murl toMasterRoute y s upload log' - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' + ya = runHandler h render murl toMasterRoute y s upload log' toEval + eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' toEval types = httpAccept $ reqWaiRequest rr errorHandler' = localNoCurrent . errorHandler diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 0eb78497..0cd42b9c 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -343,6 +343,23 @@ $doctype 5 | size > 50000 = FileUploadDisk tempFileBackEnd | otherwise = FileUploadMemory lbsBackEnd + -- | Whether or not to fully evaluate response bodies before sending. + -- + -- By fully evaluating, you will be forcing the contents into memory, which + -- will negatively impact performance. However, it means that if any + -- exceptions are thrown from pure code, they will be caught before sending + -- the response to the client, resulting in a proper 500 error page instead + -- of just getting an empty response. + -- + -- In general, it's recommend to leave the default value in place. However, + -- if you have a route that generates large responses, and you are + -- confident that no exceptions are thrown from pure code, you can safely + -- turn this off for that route. + -- + -- Default: On for all routes. + fullyEvaluateBody :: a -> Route a -> Bool + fullyEvaluateBody _ _ = True + formatLogMessage :: IO ZonedDate -> Loc -> LogLevel @@ -415,7 +432,8 @@ defaultYesodRunner logger handler master sub murl toMasterRoute msb req let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session let ra = resolveApproot master req let log' = messageLogger master logger - yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute + toEval = maybe True (fullyEvaluateBody master) (fmap toMasterRoute murl) + yar <- handlerToYAR master sub (fileUpload master) log' toEval toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of (YARPlain _ _ ct _ newSess) -> do diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 66362c57..ae00b4c1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget @@ -11,6 +12,7 @@ import Network.Wai.Test import Text.Hamlet (hamlet) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 +import Control.Exception (SomeException, try) data App = App @@ -19,9 +21,13 @@ mkYesod "App" [parseRoutes| /not_found NotFoundR POST /first_thing FirstThingR POST /after_runRequestBody AfterRunRequestBodyR POST +/error-in-body ErrorInBodyR GET +/error-in-body-noeval ErrorInBodyNoEvalR GET |] -instance Yesod App +instance Yesod App where + fullyEvaluateBody _ ErrorInBodyNoEvalR = False + fullyEvaluateBody _ _ = True getHomeR :: Handler RepHtml getHomeR = do @@ -54,11 +60,19 @@ postAfterRunRequestBodyR = do _ <- error $ show $ fst x getHomeR +getErrorInBodyR = do + let foo = error "error in body 19328" :: String + defaultLayout [whamlet|#{foo}|] + +getErrorInBodyNoEvalR = getErrorInBodyR + errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" [ it "says not found" caseNotFound , it "says 'There was an error' before runRequestBody" caseBefore , it "says 'There was an error' after runRequestBody" caseAfter + , it "error in body == 500" caseErrorInBody + , it "error in body, no eval == 200" caseErrorInBodyNoEval ] runner :: Session () -> IO () @@ -98,3 +112,18 @@ caseAfter = runner $ do } assertStatus 500 res assertBodyContains "bin12345" res + +caseErrorInBody :: IO () +caseErrorInBody = runner $ do + res <- request defaultRequest { pathInfo = ["error-in-body"] } + assertStatus 500 res + assertBodyContains "error in body 19328" res + +caseErrorInBodyNoEval :: IO () +caseErrorInBodyNoEval = do + eres <- try $ runner $ do + _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] } + return () + case eres of + Left (_ :: SomeException) -> return () + Right _ -> error "Expected an exception" From 7c09b105b06376948855e35704f8f95ea36f2066 Mon Sep 17 00:00:00 2001 From: Mike Linksvayer Date: Tue, 24 Jul 2012 19:35:04 -0700 Subject: [PATCH 158/250] hamlet->shakespeare --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 295595a6..cb292bac 100644 --- a/README.md +++ b/README.md @@ -82,7 +82,7 @@ Our installer script now uses cabal-src-install when it is available. #### Cloning the repos ~~~ { .bash } -for repo in hamlet persistent wai yesod; do +for repo in shakespeare persistent wai yesod; do git clone http://github.com/yesodweb/$repo ( cd $repo @@ -94,7 +94,7 @@ done #### install all repos ~~~ { .bash } -for repo in hamlet persistent wai yesod; do +for repo in shakespeare persistent wai yesod; do ./scripts/install done ~~~ From c009067b11a112dfa22696924e9968b063316fd1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2012 08:54:43 +0300 Subject: [PATCH 159/250] DontFullyEvaluate (Felipe's code) --- yesod-core/Yesod/Content.hs | 15 +++++++++++ yesod-core/Yesod/Handler.hs | 27 ++++++++++--------- yesod-core/Yesod/Internal/Core.hs | 20 +------------- .../test/YesodCoreTest/ErrorHandling.hs | 8 +++--- 4 files changed, 34 insertions(+), 36 deletions(-) diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index b8ff28e0..d5827ea3 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -28,6 +28,8 @@ module Yesod.Content , typeOctet -- * Utilities , simpleContentType + -- * Evaluation strategy + , DontFullyEvaluate (..) -- * Representations , ChooseRep , HasReps (..) @@ -68,6 +70,7 @@ import Data.Conduit (Source, ResourceT, Flush) data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. | ContentSource (Source (ResourceT IO) (Flush Builder)) | ContentFile FilePath (Maybe FilePart) + | ContentDontEvaluate Content -- | Zero-length enumerator. emptyContent :: Content @@ -235,3 +238,15 @@ 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" + +-- | 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 + +instance ToContent a => ToContent (DontFullyEvaluate a) where + toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs index b0a357fd..21bb25e5 100644 --- a/yesod-core/Yesod/Handler.hs +++ b/yesod-core/Yesod/Handler.hs @@ -395,9 +395,8 @@ runHandler :: HasReps c -> sub -> (Word64 -> FileUpload) -> (Loc -> LogLevel -> LogStr -> IO ()) - -> Bool -- ^ to eval body? -> YesodApp -runHandler handler mrender sroute tomr master sub upload log' toEval = +runHandler handler mrender sroute tomr master sub upload log' = YesodApp $ \eh rr cts initSession -> do let toErrorHandler e = case fromException e of @@ -440,7 +439,7 @@ runHandler handler mrender sroute tomr master sub upload log' toEval = case contents of HCContent status a -> do (ct, c) <- liftIO $ a cts - ec' <- if toEval then liftIO $ evaluateContent c else return (Right c) + ec' <- liftIO $ evaluateContent c case ec' of Left e -> handleError e Right c' -> return $ YARPlain status (appEndo headers []) ct c' finalSession @@ -806,7 +805,6 @@ handlerToYAR :: (HasReps a, HasReps b) -> sub -- ^ sub site foundation -> (Word64 -> FileUpload) -> (Loc -> LogLevel -> LogStr -> IO ()) - -> Bool -- ^ to eval body? -> (Route sub -> Route master) -> (Route master -> [(Text, Text)] -> Text) -- route renderer -> (ErrorResponse -> GHandler sub master a) @@ -815,28 +813,31 @@ handlerToYAR :: (HasReps a, HasReps b) -> SessionMap -> GHandler sub master b -> ResourceT IO YesodAppResult -handlerToYAR y s upload log' toEval toMasterRoute render errorHandler rr murl sessionMap h = +handlerToYAR y s upload log' toMasterRoute render errorHandler rr murl sessionMap h = unYesodApp ya eh' rr types sessionMap where - ya = runHandler h render murl toMasterRoute y s upload log' toEval - eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' toEval + 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 = - case c of - ContentBuilder b mlen -> - let hs' = maybe finalHeaders finalHeaders' mlen - in W.ResponseBuilder s hs' b - ContentFile fp p -> W.ResponseFile s finalHeaders fp p - ContentSource body -> W.ResponseSource s finalHeaders body + 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' + httpAccept :: W.Request -> [ContentType] httpAccept = parseHttpAccept . fromMaybe mempty diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 0cd42b9c..0eb78497 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/yesod-core/Yesod/Internal/Core.hs @@ -343,23 +343,6 @@ $doctype 5 | size > 50000 = FileUploadDisk tempFileBackEnd | otherwise = FileUploadMemory lbsBackEnd - -- | Whether or not to fully evaluate response bodies before sending. - -- - -- By fully evaluating, you will be forcing the contents into memory, which - -- will negatively impact performance. However, it means that if any - -- exceptions are thrown from pure code, they will be caught before sending - -- the response to the client, resulting in a proper 500 error page instead - -- of just getting an empty response. - -- - -- In general, it's recommend to leave the default value in place. However, - -- if you have a route that generates large responses, and you are - -- confident that no exceptions are thrown from pure code, you can safely - -- turn this off for that route. - -- - -- Default: On for all routes. - fullyEvaluateBody :: a -> Route a -> Bool - fullyEvaluateBody _ _ = True - formatLogMessage :: IO ZonedDate -> Loc -> LogLevel @@ -432,8 +415,7 @@ defaultYesodRunner logger handler master sub murl toMasterRoute msb req let sessionMap = Map.fromList . filter ((/=) tokenKey . fst) $ session let ra = resolveApproot master req let log' = messageLogger master logger - toEval = maybe True (fullyEvaluateBody master) (fmap toMasterRoute murl) - yar <- handlerToYAR master sub (fileUpload master) log' toEval toMasterRoute + yar <- handlerToYAR master sub (fileUpload master) log' toMasterRoute (yesodRender master ra) errorHandler rr murl sessionMap h extraHeaders <- case yar of (YARPlain _ _ ct _ newSess) -> do diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index ae00b4c1..92171c41 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -25,9 +25,7 @@ mkYesod "App" [parseRoutes| /error-in-body-noeval ErrorInBodyNoEvalR GET |] -instance Yesod App where - fullyEvaluateBody _ ErrorInBodyNoEvalR = False - fullyEvaluateBody _ _ = True +instance Yesod App getHomeR :: Handler RepHtml getHomeR = do @@ -60,11 +58,13 @@ postAfterRunRequestBodyR = do _ <- error $ show $ fst x getHomeR +getErrorInBodyR :: Handler RepHtml getErrorInBodyR = do let foo = error "error in body 19328" :: String defaultLayout [whamlet|#{foo}|] -getErrorInBodyNoEvalR = getErrorInBodyR +getErrorInBodyNoEvalR :: Handler (DontFullyEvaluate RepHtml) +getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" From b0c6651ac60e832195f266a71e7ab0dc3b38bc90 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 25 Jul 2012 08:56:46 +0300 Subject: [PATCH 160/250] Strictness annotations on Content --- yesod-core/Yesod/Content.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-core/Yesod/Content.hs b/yesod-core/Yesod/Content.hs index d5827ea3..3276b412 100644 --- a/yesod-core/Yesod/Content.hs +++ b/yesod-core/Yesod/Content.hs @@ -67,10 +67,10 @@ import Data.String (IsString (fromString)) import Network.Wai (FilePart) import Data.Conduit (Source, ResourceT, Flush) -data Content = ContentBuilder Builder (Maybe Int) -- ^ The content and optional content length. - | ContentSource (Source (ResourceT IO) (Flush Builder)) - | ContentFile FilePath (Maybe FilePart) - | ContentDontEvaluate Content +data Content = ContentBuilder !Builder !(Maybe Int) -- ^ The content and optional content length. + | ContentSource !(Source (ResourceT IO) (Flush Builder)) + | ContentFile !FilePath !(Maybe FilePart) + | ContentDontEvaluate !Content -- | Zero-length enumerator. emptyContent :: Content From d1f9a30efa15cd53c35b6bfd25c6e8fbf885704e Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Wed, 25 Jul 2012 16:17:25 -0300 Subject: [PATCH 161/250] yesod-form: Use constTimeEq when checking XSRF token (fixes #388). --- yesod-form/Yesod/Form/Functions.hs | 7 ++++++- yesod-form/yesod-form.cabal | 1 + 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 6a2f2aea..abe5a56a 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -45,6 +45,7 @@ import Control.Arrow (second) import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST) import Control.Monad.Trans.Class (lift) import Control.Monad (liftM, join) +import Crypto.Classes (constTimeEq) #if MIN_VERSION_blaze_html(0, 5, 0) import Text.Blaze (Markup, toMarkup) #define Html Markup @@ -62,6 +63,7 @@ import Data.Monoid (mempty) import Data.Maybe (listToMaybe, fromMaybe) import Yesod.Message (RenderMessage (..)) import qualified Data.Map as Map +import qualified Data.Text.Encoding as TE import Control.Applicative ((<$>)) import Control.Arrow (first) @@ -197,9 +199,12 @@ $newline never let res' = case (res, env) of (FormSuccess{}, Just (params, _)) - | Map.lookup tokenKey params /= fmap return (reqToken req) -> + | not (Map.lookup tokenKey params === reqToken req) -> FormFailure [renderMessage m langs MsgCsrfWarning] _ -> res + where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2 + Nothing === Nothing = True -- ^ It's important to use constTimeEq + _ === _ = False -- in order to avoid timing attacks. return ((res', xml), enctype) -- | Similar to 'runFormPost', except it always ignore the currently available diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 4733da89..eee2f1d0 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -35,6 +35,7 @@ library , blaze-html >= 0.5 && < 0.6 , blaze-markup >= 0.5.1 && < 0.6 , attoparsec >= 0.10 && < 0.11 + , crypto-api >= 0.8 && < 0.11 exposed-modules: Yesod.Form Yesod.Form.Class From 00e12930c9010be0c494fd142e37199844232993 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 29 Jul 2012 14:23:35 +0300 Subject: [PATCH 162/250] yesod-platform 1.0.6 --- yesod-platform/to-cabal.hs | 2 +- yesod-platform/yesod-platform.cabal | 42 ++++++++++++++--------------- 2 files changed, 21 insertions(+), 23 deletions(-) diff --git a/yesod-platform/to-cabal.hs b/yesod-platform/to-cabal.hs index 2b78f94b..04d8d5a1 100644 --- a/yesod-platform/to-cabal.hs +++ b/yesod-platform/to-cabal.hs @@ -3,7 +3,7 @@ import Control.Applicative ((<$>)) main = do pkgs <- map (intercalate " == ") - . filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl"]) + . filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck"]) . map words . filter (not . null) . lines diff --git a/yesod-platform/yesod-platform.cabal b/yesod-platform/yesod-platform.cabal index 251202a2..abec01fd 100644 --- a/yesod-platform/yesod-platform.cabal +++ b/yesod-platform/yesod-platform.cabal @@ -1,5 +1,5 @@ name: yesod-platform -version: 1.0.5 +version: 1.0.6 license: MIT license-file: LICENSE author: Michael Snoyman @@ -14,9 +14,7 @@ homepage: http://www.yesodweb.com/ library build-depends: base >= 4 && < 5 - , HUnit == 1.2.4.3 - , QuickCheck == 2.5 - , SHA == 1.5.0.1 + , SHA == 1.5.1 , aeson == 0.6.0.2 , ansi-terminal == 0.5.5 , asn1-data == 0.6.1.3 @@ -24,9 +22,9 @@ library , attoparsec-conduit == 0.4.0.1 , attoparsec-enumerator == 0.3 , authenticate == 1.2.1.1 - , base-unicode-symbols == 0.2.2.3 + , base-unicode-symbols == 0.2.2.4 , base64-bytestring == 0.1.2.0 - , binary == 0.5.1.0 + , binary == 0.5.1.1 , blaze-builder == 0.3.1.0 , blaze-builder-conduit == 0.4.0.2 , blaze-html == 0.5.0.0 @@ -34,7 +32,7 @@ library , byteorder == 1.0.3 , case-insensitive == 0.4.0.1 , cereal == 0.3.5.2 - , certificate == 1.2.3 + , certificate == 1.2.4 , clientsession == 0.7.5 , conduit == 0.4.2 , cookie == 0.4.0 @@ -68,10 +66,10 @@ library , hxt-regex-xmlschema == 9.0.4 , hxt-unicode == 9.0.2 , language-javascript == 0.5.4 - , largeword == 1.0.1 - , lifted-base == 0.1.1 + , largeword == 1.0.2 + , lifted-base == 0.1.1.1 , mime-mail == 0.4.1.1 - , monad-control == 0.3.1.3 + , monad-control == 0.3.1.4 , network-conduit == 0.4.0.1 , path-pieces == 0.1.1 , pem == 0.1.1 @@ -87,23 +85,23 @@ library , resourcet == 0.3.3.1 , safe == 0.3.3 , semigroups == 0.8.3.2 - , shakespeare == 1.0.0.2 - , shakespeare-css == 1.0.1.2 + , shakespeare == 1.0.1 + , shakespeare-css == 1.0.1.3 , shakespeare-i18n == 1.0.0.2 - , shakespeare-js == 1.0.0.3 - , shakespeare-text == 1.0.0.2 + , shakespeare-js == 1.0.0.4 + , shakespeare-text == 1.0.0.3 , silently == 1.2.0.2 - , simple-sendfile == 0.2.4 + , simple-sendfile == 0.2.5 , skein == 0.1.0.7 , socks == 0.4.1 - , stm == 2.3 + , stm == 2.4 , stringsearch == 0.3.6.3 - , system-fileio == 0.3.8 + , system-fileio == 0.3.9 , system-filepath == 0.4.6 , tagged == 0.4.2.1 , tagsoup == 0.12.6 , tagstream-conduit == 0.3.2 - , tls == 0.9.5 + , tls == 0.9.8 , tls-extra == 0.4.6 , transformers-base == 0.4.1 , unix-compat == 0.3.0.1 @@ -115,7 +113,7 @@ library , void == 0.5.6 , wai == 1.2.0.3 , wai-app-static == 1.2.0.4 - , wai-extra == 1.2.0.5 + , wai-extra == 1.2.0.6 , wai-logger == 0.1.4 , wai-test == 1.2.0.2 , warp == 1.2.2 @@ -123,13 +121,13 @@ library , xml-types == 0.3.2 , xml2html == 0.1.2.3 , xss-sanitize == 0.3.2 - , yaml == 0.7.0.3 + , yaml == 0.7.0.4 , yesod == 1.0.1.6 , yesod-auth == 1.0.2.1 - , yesod-core == 1.0.1.2 + , yesod-core == 1.0.1.3 , yesod-default == 1.0.1.1 , yesod-form == 1.0.0.4 - , yesod-json == 1.0.0.1 + , yesod-json == 1.0.1.0 , yesod-persistent == 1.0.0.1 , yesod-routes == 1.0.1.2 , yesod-static == 1.0.0.3 From f9e858446b7fbe2f2dfeec924a2715862a51a651 Mon Sep 17 00:00:00 2001 From: Erlend Hamberg Date: Tue, 31 Jul 2012 23:25:17 +0300 Subject: [PATCH 163/250] Correct filename for getHomeR handler in template MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit When generating a project with `yesod init` and then issuing `yesod devel` to run it, the “Welcome to Yesod!” page says the getHomeR handler is in `Handler/Root.hs`, but this should have been `Handler/Home.hs`. --- yesod/scaffold/templates/homepage.hamlet.cg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod/scaffold/templates/homepage.hamlet.cg b/yesod/scaffold/templates/homepage.hamlet.cg index c40be5cd..e4f45803 100644 --- a/yesod/scaffold/templates/homepage.hamlet.cg +++ b/yesod/scaffold/templates/homepage.hamlet.cg @@ -6,7 +6,7 @@ You can also use this scaffolded site to explore some basic concepts.
  • This page was generated by the #{handlerName} handler in # - \Handler/Root.hs. + \Handler/Home.hs.
  • The #{handlerName} handler is set to generate your site's home screen in Routes file # config/routes From ad13b5969bd3947bcdd6f7002beb86a77dd8f799 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 31 Jul 2012 16:08:12 -0700 Subject: [PATCH 164/250] link to cabal-meta --- README.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index cb292bac..ee615efc 100644 --- a/README.md +++ b/README.md @@ -46,7 +46,9 @@ In your application folder, create a `sources.txt` file with the following conte `./` means build your app. The yesod repos will be cloned and placed in a `vendor` repo. Now run: `cabal-meta install`. If you use `cabal-dev`, run `cabal-meta --dev install` -You should be good now! +This should work almost all of the time. You can read more on [cabal-meta](https://github.com/yesodweb/cabal-meta) +If you aren't building from an application, remove the `./` and create a new directory for your sources.txt first. + Install conflicts are unfortunately common in Haskell development. If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken. You can prevent this by using sandbox tools. `cabal-dev` was already mentioned. From 8b9f86afad4f7b67ff6871c37fa3a78a1fb6c7d8 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 31 Jul 2012 16:52:40 -0700 Subject: [PATCH 165/250] more build cleanup instructions --- README.md | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index ee615efc..9cc868b7 100644 --- a/README.md +++ b/README.md @@ -52,13 +52,12 @@ If you aren't building from an application, remove the `./` and create a new dir Install conflicts are unfortunately common in Haskell development. If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken. You can prevent this by using sandbox tools. `cabal-dev` was already mentioned. -Another alternative is `virthualenv`. +Another alternative is `virthualenv`, now being renamed to `hsenv`. ### virthualenv -We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv) when hacking on Yesod from Linux. -This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages. +We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv)/[hsenv](https://github.com/Paczesiowa/hsenv) when hacking on Yesod from Linux. This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages. virthualenv will not work on Windows and maybe not Mac. Use cabal-dev instead @@ -79,9 +78,10 @@ Whenever you would use `cabal install` to install a local package, use `cabal-sr Our installer script now uses cabal-src-install when it is available. -### Building your changes to Yesod +### Cloning the repos -#### Cloning the repos +The above instructions for building the latest should work well. +But you can clone the repos without the help of cabal-meta: ~~~ { .bash } for repo in shakespeare persistent wai yesod; do @@ -93,7 +93,11 @@ for repo in shakespeare persistent wai yesod; do done ~~~~ -#### install all repos +### Building your changes to Yesod + +Yesod is composed of 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package. + +#### install package in all repos ~~~ { .bash } for repo in shakespeare persistent wai yesod; do @@ -101,14 +105,9 @@ for repo in shakespeare persistent wai yesod; do done ~~~ - -#### installing repo packages +#### Clean build (sometimes necessary) ~~~ { .bash } -# install and test all packages in a repo -./scripts/install - -# If things seem weird, you may need to do a clean. ./scripts/install --clean ~~~ From ec78ad0e5eda6eb242f11d324ea5439c113c7016 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Tue, 31 Jul 2012 17:35:31 -0700 Subject: [PATCH 166/250] add note about using a VM --- README.md | 37 ++++++++++++++++++++++--------------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index 9cc868b7..4995c2bf 100644 --- a/README.md +++ b/README.md @@ -11,18 +11,27 @@ An advanced web framework using the Haskell programming language. Featuring: * this is built in to the Haskell programming language (like Erlang) * handles a greater concurrent load than any other web application server -## Learn more: http://yesodweb.com/ +# Learn more: http://yesodweb.com/ -## Installation: http://www.yesodweb.com/page/quickstart +## Install the latests stable Yesod: http://www.yesodweb.com/page/quickstart cabal update && cabal install yesod -## Create a new project after installing +### Create a new project after installing yesod init Your application is a cabal package and you use `cabal` to install its dependencies. +# Installing & isolation + +Install conflicts are unfortunately common in Haskell development. +If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken. +You can prevent this by using sandbox tools: `cabal-dev` or `virthualenv`, now being renamed to `hsenv`. + +Isolating an entire project with a virtual machine is also a great idea, you just need some tools to help that process. +[Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it. + ## Using cabal-dev cabal-dev creates a sandboxed environment for an individual cabal package. @@ -30,6 +39,8 @@ Instead of using the `cabal` command, use the `cabal-dev` command which will use Use `yesod-devel --dev` when developing your application. + + ## Installing the latest development version from github for use with your application cabal update @@ -49,13 +60,9 @@ Now run: `cabal-meta install`. If you use `cabal-dev`, run `cabal-meta --dev ins This should work almost all of the time. You can read more on [cabal-meta](https://github.com/yesodweb/cabal-meta) If you aren't building from an application, remove the `./` and create a new directory for your sources.txt first. -Install conflicts are unfortunately common in Haskell development. -If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken. -You can prevent this by using sandbox tools. `cabal-dev` was already mentioned. -Another alternative is `virthualenv`, now being renamed to `hsenv`. -### virthualenv +## virthualenv We recommend using [virthualenv](http://hackage.haskell.org/package/virthualenv)/[hsenv](https://github.com/Paczesiowa/hsenv) when hacking on Yesod from Linux. This is optional, but prevents your custom build of Yesod from interfering with your currently installed cabal packages. @@ -67,7 +74,7 @@ virthualenv will not work on Windows and maybe not Mac. Use cabal-dev instead * cabal-dev can isolate multiple packages together by using the -s sandbox argument -### cabal-src +## cabal-src The cabal-src tool helps resolve dependency conflicts when installing local packages. This capability is already built in if you are using cabal-dev or cabal-meta. Otherwise install cabal-src with: @@ -78,7 +85,7 @@ Whenever you would use `cabal install` to install a local package, use `cabal-sr Our installer script now uses cabal-src-install when it is available. -### Cloning the repos +## Cloning the repos The above instructions for building the latest should work well. But you can clone the repos without the help of cabal-meta: @@ -93,11 +100,11 @@ for repo in shakespeare persistent wai yesod; do done ~~~~ -### Building your changes to Yesod +## Building your changes to Yesod Yesod is composed of 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package. -#### install package in all repos +### install package in all repos ~~~ { .bash } for repo in shakespeare persistent wai yesod; do @@ -105,18 +112,18 @@ for repo in shakespeare persistent wai yesod; do done ~~~ -#### Clean build (sometimes necessary) +### Clean build (sometimes necessary) ~~~ { .bash } ./scripts/install --clean ~~~ -#### Building individual packages +### Building individual packages +~~~ { .bash } # move to the individual package you are working on cd shakespeare-text -~~~ { .bash } # build and test the individual package cabal configure -ftest --enable-tests cabal build From 5ece1e96e4e5b7eba236497108c1c4a017e6d2f3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 1 Aug 2012 15:57:06 +0300 Subject: [PATCH 167/250] Rename blank to parseHelper (#354) --- yesod-form/Yesod/Form/Fields.hs | 26 +++++++++++++------------- yesod-form/Yesod/Form/Functions.hs | 19 +++++++++++++------ yesod-form/Yesod/Form/Jquery.hs | 6 +++--- 3 files changed, 29 insertions(+), 22 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index e0c8619c..77e09570 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -47,7 +47,7 @@ module Yesod.Form.Fields import Yesod.Form.Types import Yesod.Form.I18n.English -import Yesod.Form.Functions (blank) +import Yesod.Form.Functions (parseHelper) import Yesod.Handler (getMessageRender) import Yesod.Widget (toWidget, whamlet, GWidget) import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..)) @@ -103,7 +103,7 @@ defaultFormMessage = englishFormMessage intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i intField = Field - { fieldParse = blank $ \s -> + { fieldParse = parseHelper $ \s -> case Data.Text.Read.signed Data.Text.Read.decimal s of Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s @@ -119,7 +119,7 @@ $newline never doubleField :: RenderMessage master FormMessage => Field sub master Double doubleField = Field - { fieldParse = blank $ \s -> + { fieldParse = parseHelper $ \s -> case Data.Text.Read.double s of Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s @@ -133,7 +133,7 @@ $newline never dayField :: RenderMessage master FormMessage => Field sub master Day dayField = Field - { fieldParse = blank $ parseDate . unpack + { fieldParse = parseHelper $ parseDate . unpack , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never @@ -143,7 +143,7 @@ $newline never timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay timeField = Field - { fieldParse = blank parseTime + { fieldParse = parseHelper parseTime , fieldView = \theId name attrs val isReq -> toWidget [hamlet| $newline never @@ -158,7 +158,7 @@ $newline never htmlField :: RenderMessage master FormMessage => Field sub master Html htmlField = Field - { fieldParse = blank $ Right . preEscapedText . sanitizeBalance + { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| $newline never $# FIXME: There was a class="html" attribute, for what purpose? @@ -187,7 +187,7 @@ instance ToHtml Textarea where textareaField :: RenderMessage master FormMessage => Field sub master Textarea textareaField = Field - { fieldParse = blank $ Right . Textarea + { fieldParse = parseHelper $ Right . Textarea , fieldView = \theId name attrs val _isReq -> toWidget [hamlet| $newline never