From 276a9f13219b34b050a7e3676062e14cfb95d7a1 Mon Sep 17 00:00:00 2001 From: "Daniel Campoverde [alx741]" Date: Mon, 6 Feb 2017 16:15:38 -0500 Subject: [PATCH 001/124] Add and export defaultEmailLoginHandler --- yesod-auth/Yesod/Auth/Email.hs | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 0f4bd8fd..874c4fee 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -106,6 +106,7 @@ module Yesod.Auth.Email , loginLinkKey , setLoginLinkKey -- * Default handlers + , defaultEmailLoginHandler , defaultRegisterHandler , defaultForgotPasswordHandler , defaultSetPasswordHandler @@ -290,6 +291,17 @@ class ( YesodAuth site normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower + -- | Handler called to render the login page. + -- The default works fine, but you may want to override it in + -- order to have a different DOM. + -- + -- Default: 'defaultEmailLoginHandler'. + -- + -- @since: 1.2.6 + emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () + emailLoginHandler = defaultEmailLoginHandler + + -- | Handler called to render the registration page. The -- default works fine, but you may want to override it in -- order to have a different DOM. @@ -346,8 +358,11 @@ authEmail = getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getRegisterR = registerHandler -emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () -emailLoginHandler toParent = do +-- | Default implementation of 'emailLoginHandler'. +-- +-- @since 1.2.6 +defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () +defaultEmailLoginHandler toParent = do (widget, enctype) <- liftWidgetT $ generateFormPost loginForm [whamlet| @@ -402,6 +417,7 @@ emailLoginHandler toParent = do langs <- languages master <- getYesod return $ renderAuthMessage master langs msg + -- | Default implementation of 'registerHandler'. -- -- @since 1.2.6 From e83d01800293ed07142e11fa0ff06e112318208f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Feb 2017 07:01:17 +0200 Subject: [PATCH 002/124] Add missing --install-ghc --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index b94ecfe4..ae9cfa83 100644 --- a/.travis.yml +++ b/.travis.yml @@ -171,9 +171,9 @@ script: echo "apply-ghc-options: everything" >> stack.yaml # Use slightly less intensive options on OS X due to Travis timeouts - stack --no-terminal $ARGS test --fast --pedantic + stack --install-ghc --no-terminal $ARGS test --fast --pedantic else - stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic + stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic fi ;; cabal) From 305931f322dcbb038623af5a6b1f81839534c891 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Feb 2017 08:13:35 +0200 Subject: [PATCH 003/124] Not pedantic on OS X (since it applies to deps too) --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ae9cfa83..ebfcea75 100644 --- a/.travis.yml +++ b/.travis.yml @@ -171,7 +171,7 @@ script: echo "apply-ghc-options: everything" >> stack.yaml # Use slightly less intensive options on OS X due to Travis timeouts - stack --install-ghc --no-terminal $ARGS test --fast --pedantic + stack --install-ghc --no-terminal $ARGS test --fast else stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic fi From 86411d25f25257c499ade6a6353ec60e6de16b28 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Feb 2017 09:08:10 +0200 Subject: [PATCH 004/124] Silly typo --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index ebfcea75..ef2d8a0f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -154,9 +154,9 @@ install: - if [ -f configure.ac ]; then autoreconf -i; fi - | set -ex - if [ "$RESOLVER" = "--resolver nightly" ] + if [ "$ARGS" = "--resolver nightly" ] then - stack $RESOLVER solver --update-config + stack $ARGS solver --update-config fi set +ex From cdc6c8ae049cd6275ff1feffaa8b5178b8a2f00f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Feb 2017 11:20:31 +0200 Subject: [PATCH 005/124] Version bumps/changelog updates --- yesod-auth-oauth/ChangeLog.md | 4 ++++ yesod-auth-oauth/yesod-auth-oauth.cabal | 2 +- yesod-auth/ChangeLog.md | 1 + yesod-auth/yesod-auth.cabal | 2 +- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/yesod-bin.cabal | 2 +- yesod-core/ChangeLog.md | 5 +++++ yesod-core/yesod-core.cabal | 2 +- yesod-eventsource/ChangeLog.md | 4 +++- yesod-eventsource/yesod-eventsource.cabal | 2 +- yesod-form/ChangeLog.md | 4 ++++ yesod-form/yesod-form.cabal | 2 +- yesod-persistent/ChangeLog.md | 4 ++++ yesod-persistent/yesod-persistent.cabal | 2 +- yesod-static/ChangeLog.md | 5 +++++ yesod-static/yesod-static.cabal | 2 +- yesod-test/ChangeLog.md | 4 ++++ yesod-test/yesod-test.cabal | 2 +- yesod-websockets/ChangeLog.md | 4 ++++ yesod-websockets/yesod-websockets.cabal | 2 +- yesod/ChangeLog.md | 4 ++++ yesod/yesod.cabal | 2 +- 22 files changed, 53 insertions(+), 12 deletions(-) diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md index 8dd1ceac..fb5ca395 100644 --- a/yesod-auth-oauth/ChangeLog.md +++ b/yesod-auth-oauth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.2 + +* Fix warnings + ## 1.4.1 * change OAuth Twitter ID, screen_name → user_id [#1168](https://github.com/yesodweb/yesod/pull/1168) diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 791e7a30..34a5a1f6 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -1,5 +1,5 @@ name: yesod-auth-oauth -version: 1.4.1.1 +version: 1.4.2 license: BSD3 license-file: LICENSE author: Hiromi Ishii diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 22786b33..9f56492c 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -2,6 +2,7 @@ * Add Show instance for user credentials `Creds` * Export pid type for identifying plugin +* Fix warnings ## 1.4.16 diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index face7de3..5c552686 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.16 +version: 1.4.17 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 80be3276..12b7b3ca 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2 + +* Fix warnings + ## 1.5.1 * Add `--host` option to `yesod devel` diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 5577eaef..a21610bc 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.1 +version: 1.5.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index cb06ee5d..d694cfc2 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.32 + +* Fix warnings +* Route parsing handles CRLF line endings + ## 1.4.31 * Add `parseCheckJsonBody` and `requireCheckJsonBody` diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 5496a8d3..8fda2795 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.31 +version: 1.4.32 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-eventsource/ChangeLog.md b/yesod-eventsource/ChangeLog.md index 58406890..f7658231 100644 --- a/yesod-eventsource/ChangeLog.md +++ b/yesod-eventsource/ChangeLog.md @@ -1 +1,3 @@ -No changes logged yet +## 1.4.1 + +* Fix warnings diff --git a/yesod-eventsource/yesod-eventsource.cabal b/yesod-eventsource/yesod-eventsource.cabal index 591bb6d7..bb64a9e3 100644 --- a/yesod-eventsource/yesod-eventsource.cabal +++ b/yesod-eventsource/yesod-eventsource.cabal @@ -1,5 +1,5 @@ name: yesod-eventsource -version: 1.4.0.1 +version: 1.4.1 license: MIT license-file: LICENSE author: Felipe Lessa diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 58731e1c..39b13f4d 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.11 + +* Fix warnings + ## 1.4.10 * Fixed `identifyForm` to properly return `FormMissing` for empty forms. [#1072](https://github.com/yesodweb/yesod/issues/1072) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 9f8a31de..61dc4e35 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.10 +version: 1.4.11 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index 81161e3a..ebb2d8e2 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.2 + +* Fix warnings + ## 1.4.1.1 * Fix build failure with older persistent versions [#1324](https://github.com/yesodweb/yesod/issues/1324) diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index 99c99432..2d04725b 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,5 +1,5 @@ name: yesod-persistent -version: 1.4.1.1 +version: 1.4.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-static/ChangeLog.md b/yesod-static/ChangeLog.md index 48b51236..7d5c9d26 100644 --- a/yesod-static/ChangeLog.md +++ b/yesod-static/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.5.2 + +* Fix test case for CRLF line endings +* Fix warnings + ## 1.5.1.1 * Fix test suite compilation diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index c7321e9d..297cc452 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.5.1.1 +version: 1.5.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 1b135213..98ff81a4 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.5 + +* Fix warnings + ## 1.5.4.1 * Compilation fix for GHC 7.8 diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index fd1d90e6..7448e7ee 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.5.4.1 +version: 1.5.5 license: MIT license-file: LICENSE author: Nubis diff --git a/yesod-websockets/ChangeLog.md b/yesod-websockets/ChangeLog.md index b1dd21f3..74ece92f 100644 --- a/yesod-websockets/ChangeLog.md +++ b/yesod-websockets/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.2.6 + +* Fix warnings + ## 0.2.5 * Allow to start websockets with custom ConnectionOptions with `webSocketsOptions` and `webSocketsOptionsWith` diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 6c4d4740..81a9f147 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -1,5 +1,5 @@ name: yesod-websockets -version: 0.2.5 +version: 0.2.6 synopsis: WebSockets support for Yesod description: WebSockets support for Yesod homepage: https://github.com/yesodweb/yesod diff --git a/yesod/ChangeLog.md b/yesod/ChangeLog.md index a8608c7d..6799776d 100644 --- a/yesod/ChangeLog.md +++ b/yesod/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.5 + +* Fix warnings + ## 1.4.4 * Reduce dependencies diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 53e9ebe0..fdde1f0e 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.4.4 +version: 1.4.5 license: MIT license-file: LICENSE author: Michael Snoyman From e032785af93c7f12924b2e8fa15953104a05d5fa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Feb 2017 11:46:08 +0200 Subject: [PATCH 006/124] Another missing --install-ghc --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ef2d8a0f..6d1cec98 100644 --- a/.travis.yml +++ b/.travis.yml @@ -156,7 +156,7 @@ install: set -ex if [ "$ARGS" = "--resolver nightly" ] then - stack $ARGS solver --update-config + stack --install-ghc $ARGS solver --update-config fi set +ex From 4327dac8a760bae1de44fac128938e6398caf539 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 8 Feb 2017 13:35:31 +0200 Subject: [PATCH 007/124] For nightly, build cabal-install --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index 6d1cec98..9a2002f1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -156,6 +156,7 @@ install: set -ex if [ "$ARGS" = "--resolver nightly" ] then + stack --install-ghc $ARGS build cabal-install stack --install-ghc $ARGS solver --update-config fi set +ex From 797278243ea3d00d69d19b215c90998a681004ab Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 17 Feb 2017 00:18:17 +0530 Subject: [PATCH 008/124] Add and export getPostParams function --- yesod-core/Yesod/Core/Handler.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index fc58f53f..e1fae75d 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -31,6 +31,7 @@ module Yesod.Core.Handler , getsYesod , getUrlRender , getUrlRenderParams + , getPostParams , getCurrentRoute , getRequest , waiRequest @@ -339,6 +340,18 @@ getUrlRenderParams => m (Route (HandlerSite m) -> [(Text, Text)] -> Text) getUrlRenderParams = rheRender <$> askHandlerEnv +-- | Get all the post parameters passed to the handler. To also get +-- the submitted files (if any), you have to use 'runRequestBody' +-- instead of this function. +-- +-- @since 1.4.33 +getPostParams + :: MonadHandler m + => m [(Text, Text)] +getPostParams = do + reqBodyContent <- runRequestBody + return $ fst reqBodyContent + -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) From 470858f81cd9e5c84abb74de7bf7e27e2f822ec9 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 17 Feb 2017 00:21:31 +0530 Subject: [PATCH 009/124] Better Haddock rendering. Since -> @since --- yesod-core/Yesod/Core/Handler.hs | 84 ++++++++++++++++---------------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index e1fae75d..0afced9a 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -438,7 +438,7 @@ handlerToIO = -- Uses 'handlerToIO', liftResourceT, and resourceForkIO -- for correctness and efficiency -- --- Since 1.2.8 +-- @since 1.2.8 forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler -> HandlerT site IO () -> HandlerT site IO () @@ -630,7 +630,7 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent -- | Bypass remaining handler code and output the given JSON with the given -- status code. -- --- Since 1.4.18 +-- @since 1.4.18 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a #if MIN_VERSION_aeson(0, 11, 0) sendStatusJSON s v = sendResponseStatus s (toEncoding v) @@ -655,7 +655,7 @@ sendWaiResponse = handlerError . HCWai -- | Switch over to handling the current request with a WAI @Application@. -- --- Since 1.2.17 +-- @since 1.2.17 sendWaiApplication :: MonadHandler m => W.Application -> m b sendWaiApplication = handlerError . HCWaiApp @@ -663,7 +663,7 @@ sendWaiApplication = handlerError . HCWaiApp -- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw -- responses (e.g., Warp). -- --- Since 1.2.16 +-- @since 1.2.16 sendRawResponseNoConduit :: (MonadHandler m, MonadBaseControl IO m) => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) @@ -679,7 +679,7 @@ sendRawResponseNoConduit raw = control $ \runInIO -> -- WAI 2.1 or later, and a web server which supports raw responses (e.g., -- Warp). -- --- Since 1.2.7 +-- @since 1.2.7 sendRawResponse :: (MonadHandler m, MonadBaseControl IO m) => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) -> m a @@ -698,7 +698,7 @@ sendRawResponse raw = control $ \runInIO -> -- | Send a 304 not modified response immediately. This is a short-circuiting -- action. -- --- Since 1.4.4 +-- @since 1.4.4 notModified :: MonadHandler m => m a notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty @@ -778,7 +778,7 @@ setLanguage = setSession langKey -- Note that, while the data type used here is 'Text', you must provide only -- ASCII value to be HTTP compliant. -- --- Since 1.2.0 +-- @since 1.2.0 addHeader :: MonadHandler m => Text -> Text -> m () addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8 @@ -823,7 +823,7 @@ expiresAt = setHeader "Expires" . formatRFC1123 -- value is a value etag value, no sanity checking is performed by this -- function. -- --- Since 1.4.4 +-- @since 1.4.4 setEtag :: MonadHandler m => Text -> m () setEtag etag = do mmatch <- lookupHeader "if-none-match" @@ -869,7 +869,7 @@ deleteSession = modify . modSession . Map.delete -- | Clear all session variables. -- --- Since: 1.0.1 +-- @since: 1.0.1 clearSession :: MonadHandler m => m () clearSession = modify $ \x -> x { ghsSession = Map.empty } @@ -909,7 +909,7 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map k -- -- > redirect (NewsfeedR :#: storyId) -- --- Since 1.2.9. +-- @since 1.2.9. data Fragment a b = a :#: b deriving (Show, Typeable) instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where @@ -973,7 +973,7 @@ hamletToRepHtml = withUrlRenderer -- | Deprecated synonym for 'withUrlRenderer'. -- --- Since 1.2.0 +-- @since 1.2.0 giveUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output @@ -983,7 +983,7 @@ giveUrlRenderer = withUrlRenderer -- | Provide a URL rendering function to the given function and return the -- result. Useful for processing Shakespearean templates. -- --- Since 1.2.20 +-- @since 1.2.20 withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output @@ -1011,7 +1011,7 @@ getMessageRender = do -- -- See the original announcement: -- --- Since 1.2.0 +-- @since 1.2.0 cached :: (MonadHandler m, Typeable a) => m a -> m a @@ -1035,7 +1035,7 @@ cached action = do -- You can turn those parameters into a ByteString cache key. -- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. -- --- Since 1.4.0 +-- @since 1.4.0 cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a cachedBy k action = do cache <- ghsCacheBy <$> get @@ -1076,13 +1076,13 @@ lookup' a = map snd . filter (\x -> a == fst x) -- | Lookup a request header. -- --- Since 1.2.2 +-- @since 1.2.2 lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString) lookupHeader = fmap listToMaybe . lookupHeaders -- | Lookup a request header. -- --- Since 1.2.2 +-- @since 1.2.2 lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString] lookupHeaders key = do req <- waiRequest @@ -1091,7 +1091,7 @@ lookupHeaders key = do -- | Lookup basic authentication data from __Authorization__ header of -- request. Returns user name and password -- --- Since 1.4.9 +-- @since 1.4.9 lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text)) lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization") where @@ -1101,7 +1101,7 @@ lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization") -- | Lookup bearer authentication datafrom __Authorization__ header of -- request. Returns bearer token value -- --- Since 1.4.9 +-- @since 1.4.9 lookupBearerAuth :: (MonadHandler m) => m (Maybe Text) lookupBearerAuth = fmap (>>= getBR) (lookupHeader "Authorization") @@ -1175,7 +1175,7 @@ lookupCookies pn = do -- | Select a representation to send to the client based on the representations -- provided inside this do-block. Should be used together with 'provideRep'. -- --- Since 1.2.0 +-- @since 1.2.0 selectRep :: MonadHandler m => Writer.Writer (Endo [ProvidedRep m]) () -> m TypedContent @@ -1231,13 +1231,13 @@ selectRep w = do -- | Internal representation of a single provided representation. -- --- Since 1.2.0 +-- @since 1.2.0 data ProvidedRep m = ProvidedRep !ContentType !(m Content) -- | Provide a single representation to be used, based on the request of the -- client. Should be used together with 'selectRep'. -- --- Since 1.2.0 +-- @since 1.2.0 provideRep :: (Monad m, HasContentType a) => m a -> Writer.Writer (Endo [ProvidedRep m]) () @@ -1250,7 +1250,7 @@ provideRep handler = provideRepType (getContentType handler) handler -- -- > provideRepType "application/x-special-format" "This is the content" -- --- Since 1.2.0 +-- @since 1.2.0 provideRepType :: (Monad m, ToContent a) => ContentType -> m a @@ -1260,7 +1260,7 @@ provideRepType ct handler = -- | Stream in the raw request body without any parsing. -- --- Since 1.2.0 +-- @since 1.2.0 rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody = do req <- lift waiRequest @@ -1280,7 +1280,7 @@ fileSource = transPipe liftResourceT . fileSourceRaw -- -- > respond ct = return . TypedContent ct . toContent -- --- Since 1.2.0 +-- @since 1.2.0 respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent respond ct = return . TypedContent ct . toContent @@ -1292,7 +1292,7 @@ respond ct = return . TypedContent ct . toContent -- actions make no sense here. For example: short-circuit responses, setting -- headers, changing status codes, etc. -- --- Since 1.2.0 +-- @since 1.2.0 respondSource :: ContentType -> Source (HandlerT site IO) (Flush Builder) -> HandlerT site IO TypedContent @@ -1306,44 +1306,44 @@ respondSource ctype src = HandlerT $ \hd -> -- | In a streaming response, send a single chunk of data. This function works -- on most datatypes, such as @ByteString@ and @Html@. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder) sendChunk = yield . toFlushBuilder -- | In a streaming response, send a flush command, causing all buffered data -- to be immediately sent to the client. -- --- Since 1.2.0 +-- @since 1.2.0 sendFlush :: Monad m => Producer m (Flush Builder) sendFlush = yield Flush -- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder) sendChunkBS = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder) sendChunkLBS = sendChunk -- | Type-specialized version of 'sendChunk' for strict @Text@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder) sendChunkText = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder) sendChunkLazyText = sendChunk -- | Type-specialized version of 'sendChunk' for @Html@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml = sendChunk @@ -1387,7 +1387,7 @@ stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do -- | The default cookie name for the CSRF token ("XSRF-TOKEN"). -- --- Since 1.4.14 +-- @since 1.4.14 defaultCsrfCookieName :: S8.ByteString defaultCsrfCookieName = "XSRF-TOKEN" @@ -1395,7 +1395,7 @@ defaultCsrfCookieName = "XSRF-TOKEN" -- -- The cookie's path is set to @/@, making it valid for your whole website. -- --- Since 1.4.14 +-- @since 1.4.14 setCsrfCookie :: MonadHandler m => m () setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" } @@ -1403,7 +1403,7 @@ setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieN -- -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- --- Since 1.4.14 +-- @since 1.4.14 setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m () setCsrfCookieWithCookie cookie = do mCsrfToken <- reqToken <$> getRequest @@ -1411,14 +1411,14 @@ setCsrfCookieWithCookie cookie = do -- | The default header name for the CSRF token ("X-XSRF-TOKEN"). -- --- Since 1.4.14 +-- @since 1.4.14 defaultCsrfHeaderName :: CI S8.ByteString defaultCsrfHeaderName = "X-XSRF-TOKEN" -- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- --- Since 1.4.14 +-- @since 1.4.14 checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m () checkCsrfHeaderNamed headerName = do valid <- hasValidCsrfHeaderNamed headerName @@ -1426,7 +1426,7 @@ checkCsrfHeaderNamed headerName = do -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- --- Since 1.4.14 +-- @since 1.4.14 hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool hasValidCsrfHeaderNamed headerName = do mCsrfToken <- reqToken <$> getRequest @@ -1438,14 +1438,14 @@ hasValidCsrfHeaderNamed headerName = do -- | The default parameter name for the CSRF token ("_token") -- --- Since 1.4.14 +-- @since 1.4.14 defaultCsrfParamName :: Text defaultCsrfParamName = "_token" -- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- --- Since 1.4.14 +-- @since 1.4.14 checkCsrfParamNamed :: MonadHandler m => Text -> m () checkCsrfParamNamed paramName = do valid <- hasValidCsrfParamNamed paramName @@ -1453,7 +1453,7 @@ checkCsrfParamNamed paramName = do -- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- --- Since 1.4.14 +-- @since 1.4.14 hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool hasValidCsrfParamNamed paramName = do mCsrfToken <- reqToken <$> getRequest @@ -1464,7 +1464,7 @@ hasValidCsrfParamNamed paramName = do -- | Checks that a valid CSRF token is present in either the request headers or POST parameters. -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error. -- --- Since 1.4.14 +-- @since 1.4.14 checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m) => CI S8.ByteString -- ^ The header name to lookup the CSRF token -> Text -- ^ The POST parameter name to lookup the CSRF token From 6d7ba59e4b767355e0741e4c51a474140d9fb593 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 17 Feb 2017 00:22:57 +0530 Subject: [PATCH 010/124] Update changelog --- yesod-core/ChangeLog.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index d694cfc2..17a5d774 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.33 + +* Add 'getPostParams' in Yesod.Core.Handler +* Haddock rendering improved. + ## 1.4.32 * Fix warnings From c78ae95b3a21f8b9a1aef2112ad817425e2ade8c Mon Sep 17 00:00:00 2001 From: "Daniel Campoverde [alx741]" Date: Mon, 6 Feb 2017 17:20:55 -0500 Subject: [PATCH 011/124] Fix email auth module --- yesod-auth/Yesod/Auth/Email.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 874c4fee..020a1be0 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -298,7 +298,7 @@ class ( YesodAuth site -- Default: 'defaultEmailLoginHandler'. -- -- @since: 1.2.6 - emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () + emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () emailLoginHandler = defaultEmailLoginHandler @@ -534,7 +534,7 @@ defaultForgotPasswordHandler = do where forgotPasswordForm extra = do (emailRes, emailView) <- mreq emailField emailSettings Nothing - + let forgotPasswordRes = ForgotPasswordForm <$> emailRes let widget = do [whamlet| From c5ddf559371f6485a74406d0869793b901373e8e Mon Sep 17 00:00:00 2001 From: "Daniel Campoverde [alx741]" Date: Sat, 18 Feb 2017 14:52:23 -0500 Subject: [PATCH 012/124] Update emailLoginHandler 'since' version --- yesod-auth/Yesod/Auth/Email.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 020a1be0..f52e7c99 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -297,7 +297,7 @@ class ( YesodAuth site -- -- Default: 'defaultEmailLoginHandler'. -- - -- @since: 1.2.6 + -- @since 1.4.11 emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () emailLoginHandler = defaultEmailLoginHandler From ea5e1cca265c8496bc4fafd2cfd3a27909b3a8d8 Mon Sep 17 00:00:00 2001 From: "Daniel Campoverde [alx741]" Date: Sat, 18 Feb 2017 18:28:53 -0500 Subject: [PATCH 013/124] Update emailLoginHandler 'since' version --- yesod-auth/Yesod/Auth/Email.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index f52e7c99..aa76231a 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -297,7 +297,7 @@ class ( YesodAuth site -- -- Default: 'defaultEmailLoginHandler'. -- - -- @since 1.4.11 + -- @since 1.4.17 emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () emailLoginHandler = defaultEmailLoginHandler @@ -360,7 +360,7 @@ getRegisterR = registerHandler -- | Default implementation of 'emailLoginHandler'. -- --- @since 1.2.6 +-- @since 1.4.17 defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () defaultEmailLoginHandler toParent = do (widget, enctype) <- liftWidgetT $ generateFormPost loginForm From 9014192c66e90ba971a0a95decfe288b515772e7 Mon Sep 17 00:00:00 2001 From: "Daniel Campoverde [alx741]" Date: Sat, 18 Feb 2017 18:31:05 -0500 Subject: [PATCH 014/124] Update changelog --- yesod-auth/ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 9f56492c..27ae545c 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -3,6 +3,7 @@ * Add Show instance for user credentials `Creds` * Export pid type for identifying plugin * Fix warnings +* Allow for a custom Email Login DOM with `emailLoginHandler` ## 1.4.16 From ab7428b1be5cc23c92b86d04bd958dcd1ffcab97 Mon Sep 17 00:00:00 2001 From: Fabian Beuke Date: Sat, 25 Feb 2017 21:33:28 +0100 Subject: [PATCH 015/124] Update license to 2017 --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index d9f04179..b7cd0a96 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ +Copyright (c) 2017 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the From 3f9cbf2ff90eebb53e07f46eb03f986f128e8a5f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 27 Feb 2017 09:47:45 +0200 Subject: [PATCH 016/124] Switch to copyright year range #617 --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index b7cd0a96..fce2b738 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2017 Michael Snoyman, http://www.yesodweb.com/ +Copyright (c) 2012-2017 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the From b76d9c3090ecf85da19166b1ef518b9bd07f0d95 Mon Sep 17 00:00:00 2001 From: Isaac Elliott Date: Tue, 28 Feb 2017 17:50:20 +1000 Subject: [PATCH 017/124] Fixed spelling and wording for Yesod.Form.Functions.convertField's docs --- yesod-form/ChangeLog.md | 2 ++ yesod-form/Yesod/Form/Functions.hs | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 39b13f4d..0da6f50a 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,6 +1,8 @@ ## 1.4.11 * Fix warnings +* Fixed spelling errors and wording for `Yesod.Form.Functions.convertField`'s + documentation ## 1.4.10 diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 66787523..37d93f13 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -534,8 +534,8 @@ parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ -- | Since a 'Field' cannot be a 'Functor', it is not obvious how to "reuse" a Field -- on a @newtype@ or otherwise equivalent type. This function allows you to convert --- a @Field m a@ to a @Field m b@ assuming you provide a bidireccional --- convertion among the two, through the first two functions. +-- a @Field m a@ to a @Field m b@ assuming you provide a bidirectional +-- conversion between the two, through the first two functions. -- -- A simple example: -- From 55623b76f66b0d7ce2e0278539afc494ed3fe50f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 1 Mar 2017 08:53:13 +0200 Subject: [PATCH 018/124] Improve ChangeLog --- yesod-core/ChangeLog.md | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 17a5d774..7ee382e4 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,12 +1,9 @@ -## 1.4.33 - -* Add 'getPostParams' in Yesod.Core.Handler -* Haddock rendering improved. - ## 1.4.32 * Fix warnings * Route parsing handles CRLF line endings +* Add 'getPostParams' in Yesod.Core.Handler +* Haddock rendering improved. ## 1.4.31 From 4f30dfca1e480b8b34ce8b12d6b19b198bc68c97 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 5 Mar 2017 19:12:14 +0200 Subject: [PATCH 019/124] Use --no-nix-pure #1357 --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/Devel.hs | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 12b7b3ca..029f8857 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2.1 + +* Use `--no-nix-pure` [#1357](https://github.com/yesodweb/yesod/issues/1357) + ## 1.5.2 * Fix warnings diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 9b9e3443..0795fa2e 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -406,7 +406,8 @@ devel opts passThroughArgs = do ] -} let procDef = setStdin closed $ setEnv env' $ proc "stack" - [ "runghc" + [ "--no-nix-pure" -- https://github.com/yesodweb/yesod/issues/1357 + , "runghc" , "--" , develHsPath ] From 182b87e2d4fd27b00749a34e2fabb4a8699ca3fb Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Mar 2017 11:15:11 +0200 Subject: [PATCH 020/124] Version bump --- yesod-bin/yesod-bin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index a21610bc..5779fd45 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2 +version: 1.5.2.1 license: MIT license-file: LICENSE author: Michael Snoyman From 85496411f24a162a2a754e251a24d0b8eae6c230 Mon Sep 17 00:00:00 2001 From: Divam Date: Wed, 15 Mar 2017 11:54:45 +0900 Subject: [PATCH 021/124] Fix yesod-websockets/sample.hs example --- yesod-websockets/sample.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/yesod-websockets/sample.hs b/yesod-websockets/sample.hs index 84f88b2e..12e32ace 100644 --- a/yesod-websockets/sample.hs +++ b/yesod-websockets/sample.hs @@ -3,10 +3,10 @@ import Yesod.Core import Yesod.WebSockets import qualified Data.Text.Lazy as TL import Control.Monad (forever) -import Control.Monad.Trans.Reader import Control.Concurrent (threadDelay) import Data.Time -import Conduit +import Data.Conduit +import qualified Data.Conduit.List data App = App @@ -25,7 +25,7 @@ timeSource = forever $ do getHomeR :: Handler Html getHomeR = do webSockets $ race_ - (sourceWS $$ mapC TL.toUpper =$ sinkWSText) + (sourceWS $$ Data.Conduit.List.map TL.toUpper =$ sinkWSText) (timeSource $$ sinkWSText) defaultLayout $ toWidget @@ -43,6 +43,9 @@ getHomeR = do conn.onmessage = function(e) { document.write("

" + e.data + "

"); }; + conn.onclose = function () { + document.write("

Connection Closed

"); + }; |] main :: IO () From 039046e3558553ee96936f9c637cc50a72b532fd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 15 Mar 2017 06:42:00 +0200 Subject: [PATCH 022/124] Another Nix workaround (fixes #1359) --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/Devel.hs | 29 +++++++++++++++++++++++++---- yesod-bin/yesod-bin.cabal | 2 +- 3 files changed, 30 insertions(+), 5 deletions(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 029f8857..9a8c6990 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2.2 + +* I guess `--no-nix-pure` implies Nix... sigh [#1359](https://github.com/yesodweb/yesod/issues/1359) + ## 1.5.2.1 * Use `--no-nix-pure` [#1357](https://github.com/yesodweb/yesod/issues/1357) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 0795fa2e..4289317b 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -21,6 +21,7 @@ import qualified Data.Conduit.List as CL import Data.Default.Class (def) import Data.FileEmbed (embedFile) import qualified Data.Map as Map +import Data.Maybe (isJust) import qualified Data.Set as Set import Data.Streaming.Network (bindPortTCP, bindRandomPortTCP) @@ -362,9 +363,11 @@ devel opts passThroughArgs = do sayV "First successful build complete, running app" - -- We're going to set the PORT and DISPLAY_PORT variables - -- for the child below + -- We're going to set the PORT and DISPLAY_PORT variables for + -- the child below. Also need to know if the env program + -- exists. env <- fmap Map.fromList getEnvironment + hasEnv <- fmap isJust $ findExecutable "env" -- Keep looping forever, print any synchronous exceptions, -- and eventually die from an async exception from one of @@ -405,9 +408,27 @@ devel opts passThroughArgs = do , "Main.main" ] -} - let procDef = setStdin closed $ setEnv env' $ proc "stack" - [ "--no-nix-pure" -- https://github.com/yesodweb/yesod/issues/1357 + + -- Nix support in Stack doesn't pass along env vars by + -- default, so we use the env command. But if the command + -- isn't available, just set the env var. I'm sure this + -- will break _some_ combination of systems, but we'll + -- deal with that later. Previous issues: + -- + -- https://github.com/yesodweb/yesod/issues/1357 + -- https://github.com/yesodweb/yesod/issues/1359 + let procDef + | hasEnv = setStdin closed $ proc "stack" + [ "exec" + , "--" + , "env" + , "PORT=" ++ show newPort + , "DISPLAY_PORT=" ++ show (develPort opts) , "runghc" + , develHsPath + ] + | otherwise = setStdin closed $ setEnv env' $ proc "stack" + [ "runghc" , "--" , develHsPath ] diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 5779fd45..54eb1805 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2.1 +version: 1.5.2.2 license: MIT license-file: LICENSE author: Michael Snoyman From 6c7a40ea5b07d1bd64a07ff3e975973dc72dc225 Mon Sep 17 00:00:00 2001 From: James Parker Date: Wed, 22 Mar 2017 17:16:03 -0400 Subject: [PATCH 023/124] Adds curly brackets to route parser. --- yesod-core/Yesod/Routes/Parse.hs | 41 +++++++++++++++++++++----- yesod-core/test/RouteSpec.hs | 4 ++- yesod-core/test/YesodCoreTest/Links.hs | 4 +++ 3 files changed, 41 insertions(+), 8 deletions(-) diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs index 580f23d6..0a7428f7 100644 --- a/yesod-core/Yesod/Routes/Parse.hs +++ b/yesod-core/Yesod/Routes/Parse.hs @@ -13,7 +13,7 @@ module Yesod.Routes.Parse ) where import Language.Haskell.TH.Syntax -import Data.Char (isUpper) +import Data.Char (isUpper, isSpace) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Yesod.Routes.TH @@ -86,7 +86,7 @@ resourcesFromString = spaces = takeWhile (== ' ') thisLine (others, remainder) = parse indent otherLines' (this, otherLines') = - case takeWhile (not . isPrefixOf "--") $ words thisLine of + case takeWhile (not . isPrefixOf "--") $ splitSpaces thisLine of (pattern:rest0) | Just (constr:rest) <- stripColonLast rest0 , Just attrs <- mapM parseAttr rest -> @@ -102,6 +102,26 @@ resourcesFromString = [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine +-- | Splits a string by spaces, as long as the spaces are not enclosed by curly brackets (not recursive). +splitSpaces :: String -> [String] +splitSpaces "" = [] +splitSpaces str = + let (rest, piece) = parse $ dropWhile isSpace str in + piece:(splitSpaces rest) + + where + parse :: String -> ( String, String) + parse ('{':s) = fmap ('{':) $ parseBracket s + parse (c:s) | isSpace c = (s, []) + parse (c:s) = fmap (c:) $ parse s + parse "" = ("", "") + + parseBracket :: String -> ( String, String) + parseBracket ('{':_) = error $ "Invalid resource line (nested curly bracket): " ++ str + parseBracket ('}':s) = fmap ('}':) $ parse s + parseBracket (c:s) = fmap (c:) $ parseBracket s + parseBracket "" = error $ "Invalid resource line (unclosed curly bracket): " ++ str + piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool) piecesFromStringCheck s0 = (pieces, mmulti, check) @@ -181,7 +201,7 @@ parseTypeTree :: String -> Maybe TypeTree parseTypeTree orig = toTypeTree pieces where - pieces = filter (not . null) $ splitOn '-' $ addDashes orig + pieces = filter (not . null) $ splitOn (\c -> c == '-' || c == ' ') $ addDashes orig addDashes [] = [] addDashes (x:xs) = front $ addDashes xs @@ -194,7 +214,7 @@ parseTypeTree orig = _:y -> x : splitOn c y [] -> [x] where - (x, y') = break (== c) s + (x, y') = break c s data TypeTree = TTTerm String | TTApp TypeTree TypeTree @@ -237,9 +257,9 @@ ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) -pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) -pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652 -pieceFromString ('#':x) = Right $ (True, Dynamic x) +pieceFromString ('#':'!':x) = Right $ (False, dynamicPieceFromString x) +pieceFromString ('!':'#':x) = Right $ (False, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652 +pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x) pieceFromString ('*':'!':x) = Left (False, x) pieceFromString ('+':'!':x) = Left (False, x) @@ -252,3 +272,10 @@ pieceFromString ('+':x) = Left (True, x) pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x) + +dynamicPieceFromString :: String -> Piece String +dynamicPieceFromString str@('{':x) = case break (== '}') x of + (s, "}") -> Dynamic s + _ -> error $ "Invalid path piece: " ++ str +dynamicPieceFromString x = Dynamic x +-- JP: Should we check if there are curly brackets or other invalid characters? diff --git a/yesod-core/test/RouteSpec.hs b/yesod-core/test/RouteSpec.hs index f746a2de..283119e2 100644 --- a/yesod-core/test/RouteSpec.hs +++ b/yesod-core/test/RouteSpec.hs @@ -322,7 +322,7 @@ main = hspec $ do it "hierarchy" $ do routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child") hierarchy - describe "parseRouteTyoe" $ do + describe "parseRouteType" $ do let success s t = it s $ parseTypeTree s @?= Just t failure s = it s $ parseTypeTree s @?= Nothing success "Int" $ TTTerm "Int" @@ -334,6 +334,8 @@ main = hspec $ do success "[Int]" $ TTList $ TTTerm "Int" success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" + success "Foo Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar") + success "Foo Bar Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" getRootR :: Text getRootR = pack "this is the root" diff --git a/yesod-core/test/YesodCoreTest/Links.hs b/yesod-core/test/YesodCoreTest/Links.hs index 2089026f..f195368d 100644 --- a/yesod-core/test/YesodCoreTest/Links.hs +++ b/yesod-core/test/YesodCoreTest/Links.hs @@ -25,6 +25,7 @@ mkYesod "Y" [parseRoutes| /route-test-2/*Vector-String RT2 GET /route-test-3/*Vector-(Maybe-Int) RT3 GET /route-test-4/#(Foo-Int-Int) RT4 GET +/route-test-4-spaces/#{Foo Int Int} RT4Spaces GET |] data Vector a = Vector @@ -64,6 +65,9 @@ getRT3 _ = return () getRT4 :: Foo Int Int -> Handler () getRT4 _ = return () +getRT4Spaces :: Foo Int Int -> Handler () +getRT4Spaces _ = return () + linksTest :: Spec linksTest = describe "Test.Links" $ do it "linkToHome" case_linkToHome From 52d4a32217c19bd8f8107422527b0868bed219a6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Mar 2017 11:40:27 +0200 Subject: [PATCH 024/124] Add curl for AppVeyor --- appveyor.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/appveyor.yml b/appveyor.yml index 8f05d2cf..d544676d 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -1,6 +1,9 @@ build: off before_test: +# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found +- set PATH=C:\Program Files\Git\mingw64\bin;%PATH% + - curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386 - 7z x stack.zip stack.exe From de9f5bc4c9e8001215ff5f0bb257e73bf388ec2a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 26 Mar 2017 18:14:40 +0300 Subject: [PATCH 025/124] Version bump for #1363 --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 7ee382e4..d23ec260 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.33 + +* Adds curly brackets to route parser. [#1363](https://github.com/yesodweb/yesod/pull/1363) + ## 1.4.32 * Fix warnings diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 8fda2795..ade5c86e 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.32 +version: 1.4.33 license: MIT license-file: LICENSE author: Michael Snoyman From adf89bcf8423df59722d6705779577d2b206ad0a Mon Sep 17 00:00:00 2001 From: James Parker Date: Thu, 23 Mar 2017 22:39:41 -0400 Subject: [PATCH 026/124] Contexts can be parsed and included in instances. Standalone deriving is used when a context is provided. Type variables can be included in routes/TH. --- yesod-core/Yesod/Core/Internal/TH.hs | 78 +++++++++++++++++++---- yesod-core/Yesod/Routes/Parse.hs | 3 +- yesod-core/Yesod/Routes/TH/ParseRoute.hs | 8 ++- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 17 +++-- yesod-core/Yesod/Routes/TH/RouteAttrs.hs | 8 ++- 5 files changed, 93 insertions(+), 21 deletions(-) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 207137c4..20a1dcfa 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Internal.TH where import Prelude hiding (exp) @@ -15,12 +16,16 @@ import Language.Haskell.TH.Syntax import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () -import Data.List (foldl') +import Data.Char (isLower) +import Data.List (foldl', uncons) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (replicateM, void) import Data.Either (partitionEithers) +import Text.Parsec (parse, many1, many, eof, try, (<|>), option, sepBy1) +import Text.Parsec.Token (symbol) +import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Yesod.Routes.TH import Yesod.Routes.Parse @@ -55,8 +60,40 @@ mkYesodSubData name = mkYesodDataGeneral name True mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do - let (name':rest) = words name - fst <$> mkYesodGeneral name' (fmap Left rest) isSub return res + let (name', rest, cxt) = case parse parseName "" name of + Left err -> error $ show err + Right a -> a + fst <$> mkYesodGeneral' cxt name' (fmap Left rest) isSub return res + + where + parseName = do + cxt <- option [] parseContext + name' <- parseWord + args <- many parseWord + spaces + eof + return ( name', args, cxt) + + parseWord = do + spaces + many1 alphaNum + + parseContext = try $ do + cxts <- parseParen parseContexts + spaces + _ <- string "=>" + return cxts + + parseParen p = do + spaces + _ <- char '(' + r <- p + spaces + _ <- char ')' + return r + + parseContexts = + sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] @@ -80,7 +117,17 @@ mkYesodGeneral :: String -- ^ foundation type -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) -mkYesodGeneral namestr args isSub f resS = do +mkYesodGeneral = mkYesodGeneral' [] + +mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. + -> String -- ^ foundation type + -> [Either String [String]] -- ^ arguments for the type + -> Bool -- ^ is this a subsite + -> (Exp -> Q Exp) -- ^ unwrap handler + -> [ResourceTree String] + -> Q([Dec],[Dec]) +mkYesodGeneral' appCxt' namestr args isSub f resS = do + let appCxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest) appCxt' mname <- lookupTypeName namestr arity <- case mname of Just name -> do @@ -105,10 +152,15 @@ mkYesodGeneral namestr args isSub f resS = do vns <- replicateM (arity - length mtys) $ newName "t" -- Base type (site type with variables) let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $ - foldr (\arg (xs,n:ns,cs) -> + foldr (\arg (xs,vns',cs) -> case arg of - Left t -> ( ConT (mkName t):xs, n:ns, cs ) - Right ts -> ( VarT n :xs, ns + Left t@(h:_) | isLower h -> + ( VarT (mkName t):xs, vns', cs ) + Left t -> + ( ConT (mkName t):xs, vns', cs ) + Right ts -> + let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in + ( VarT n : xs, ns , fmap (\t -> #if MIN_VERSION_template_haskell(2,10,0) AppT (ConT $ mkName t) (VarT n) @@ -119,10 +171,10 @@ mkYesodGeneral namestr args isSub f resS = do ) ([],vns,[]) args site = foldl' AppT (ConT name) argtypes res = map (fmap parseType) resS - renderRouteDec <- mkRenderRouteInstance site res - routeAttrsDec <- mkRouteAttrsInstance site res + renderRouteDec <- mkRenderRouteInstance' appCxt site res + routeAttrsDec <- mkRouteAttrsInstance' appCxt site res dispatchDec <- mkDispatchInstance site cxt f res - parse <- mkParseRouteInstance site res + parseRoute <- mkParseRouteInstance' appCxt site res let rname = mkName $ "resources" ++ namestr eres <- lift resS let resourcesDec = @@ -130,7 +182,7 @@ mkYesodGeneral namestr args isSub f resS = do , FunD rname [Clause [] (NormalB eres) []] ] let dataDec = concat - [ [parse] + [ [parseRoute] , renderRouteDec , [routeAttrsDec] , resourcesDec @@ -138,6 +190,10 @@ mkYesodGeneral namestr args isSub f resS = do ] return (dataDec, dispatchDec) + where + nameToType t@(h:_) | isLower h = VarT $ mkName t + nameToType t = ConT $ mkName t + mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs index 0a7428f7..2f376023 100644 --- a/yesod-core/Yesod/Routes/Parse.hs +++ b/yesod-core/Yesod/Routes/Parse.hs @@ -13,7 +13,7 @@ module Yesod.Routes.Parse ) where import Language.Haskell.TH.Syntax -import Data.Char (isUpper, isSpace) +import Data.Char (isUpper, isLower, isSpace) import Language.Haskell.TH.Quote import qualified System.IO as SIO import Yesod.Routes.TH @@ -252,6 +252,7 @@ toTypeTree orig = do gos' (front . (t:)) xs' ttToType :: TypeTree -> Type +ttToType (TTTerm s@(h:_)) | isLower h = VarT $ mkName s ttToType (TTTerm s) = ConT $ mkName s ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t diff --git a/yesod-core/Yesod/Routes/TH/ParseRoute.hs b/yesod-core/Yesod/Routes/TH/ParseRoute.hs index 69318a30..f5ee972a 100644 --- a/yesod-core/Yesod/Routes/TH/ParseRoute.hs +++ b/yesod-core/Yesod/Routes/TH/ParseRoute.hs @@ -3,6 +3,7 @@ module Yesod.Routes.TH.ParseRoute ( -- ** ParseRoute mkParseRouteInstance + , mkParseRouteInstance' ) where import Yesod.Routes.TH.Types @@ -12,7 +13,10 @@ import Yesod.Routes.Class import Yesod.Routes.TH.Dispatch mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec -mkParseRouteInstance typ ress = do +mkParseRouteInstance = mkParseRouteInstance' [] + +mkParseRouteInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec +mkParseRouteInstance' cxt typ ress = do cls <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|\_ _ x _ -> x|] @@ -28,7 +32,7 @@ mkParseRouteInstance typ ress = do (map removeMethods ress) helper <- newName "helper" fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|] - return $ instanceD [] (ConT ''ParseRoute `AppT` typ) + return $ instanceD cxt (ConT ''ParseRoute `AppT` typ) [ FunD 'parseRoute $ return $ Clause [] (NormalB $ fixer `AppE` VarE helper) diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index eaa52295..95ad9bbc 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/Yesod/Routes/TH/RenderRoute.hs @@ -3,6 +3,7 @@ module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance , mkRenderRouteInstance' + , mkRenderRouteInstance' , mkRouteCons , mkRenderRouteClauses ) where @@ -12,6 +13,7 @@ import Yesod.Routes.TH.Types import Language.Haskell.TH (conT) #endif import Language.Haskell.TH.Syntax +import Data.Bits (xor) import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) @@ -156,18 +158,23 @@ mkRenderRouteInstance' cxt typ ress = do cls <- mkRenderRouteClauses ress (cons, decs) <- mkRouteCons ress #if MIN_VERSION_template_haskell(2,12,0) - did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT clazzes) + did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) #elif MIN_VERSION_template_haskell(2,11,0) - did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes + did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False) #else - let did = DataInstD [] ''Route [typ] cons clazzes + let did = DataInstD [] ''Route [typ] cons (clazzes False) #endif + let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls - ] : decs + ] + : sds ++ decs where - clazzes = [''Show, ''Eq, ''Read] + clazzes standalone = if standalone `xor` null cxt then + [''Show, ''Eq, ''Read] + else + [] #if MIN_VERSION_template_haskell(2,11,0) notStrict :: Bang diff --git a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs b/yesod-core/Yesod/Routes/TH/RouteAttrs.hs index 56e142e9..0348206a 100644 --- a/yesod-core/Yesod/Routes/TH/RouteAttrs.hs +++ b/yesod-core/Yesod/Routes/TH/RouteAttrs.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs ( mkRouteAttrsInstance + , mkRouteAttrsInstance' ) where import Yesod.Routes.TH.Types @@ -15,9 +16,12 @@ import Control.Applicative ((<$>)) #endif mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec -mkRouteAttrsInstance typ ress = do +mkRouteAttrsInstance = mkRouteAttrsInstance' [] + +mkRouteAttrsInstance' :: Cxt -> Type -> [ResourceTree a] -> Q Dec +mkRouteAttrsInstance' cxt typ ress = do clauses <- mapM (goTree id) ress - return $ instanceD [] (ConT ''RouteAttrs `AppT` typ) + return $ instanceD cxt (ConT ''RouteAttrs `AppT` typ) [ FunD 'routeAttrs $ concat clauses ] From 997714f4c2f39964acd636a3479e8fa48118b2b6 Mon Sep 17 00:00:00 2001 From: James Parker Date: Mon, 27 Mar 2017 02:42:47 -0400 Subject: [PATCH 027/124] Accept multiple argument types inside brackets --- yesod-core/Yesod/Core/Internal/TH.hs | 14 +++--------- yesod-core/Yesod/Routes/Parse.hs | 27 ++++++++++++++--------- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 1 - 3 files changed, 19 insertions(+), 23 deletions(-) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 20a1dcfa..565466bb 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -16,15 +16,13 @@ import Language.Haskell.TH.Syntax import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () -import Data.Char (isLower) import Data.List (foldl', uncons) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (replicateM, void) import Data.Either (partitionEithers) -import Text.Parsec (parse, many1, many, eof, try, (<|>), option, sepBy1) -import Text.Parsec.Token (symbol) +import Text.Parsec (parse, many1, many, eof, try, option, sepBy1) import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Yesod.Routes.TH @@ -154,10 +152,8 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do let (argtypes,cxt) = (\(ns,r,cs) -> (ns ++ fmap VarT r, cs)) $ foldr (\arg (xs,vns',cs) -> case arg of - Left t@(h:_) | isLower h -> - ( VarT (mkName t):xs, vns', cs ) Left t -> - ( ConT (mkName t):xs, vns', cs ) + ( nameToType t:xs, vns', cs ) Right ts -> let (n, ns) = maybe (error "mkYesodGeneral: Should be unreachable.") id $ uncons vns' in ( VarT n : xs, ns @@ -170,7 +166,7 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do ) ts ++ cs ) ) ([],vns,[]) args site = foldl' AppT (ConT name) argtypes - res = map (fmap parseType) resS + res = map (fmap (parseType . dropBracket)) resS renderRouteDec <- mkRenderRouteInstance' appCxt site res routeAttrsDec <- mkRouteAttrsInstance' appCxt site res dispatchDec <- mkDispatchInstance site cxt f res @@ -190,10 +186,6 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do ] return (dataDec, dispatchDec) - where - nameToType t@(h:_) | isLower h = VarT $ mkName t - nameToType t = ConT $ mkName t - mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh diff --git a/yesod-core/Yesod/Routes/Parse.hs b/yesod-core/Yesod/Routes/Parse.hs index 2f376023..e372fc0f 100644 --- a/yesod-core/Yesod/Routes/Parse.hs +++ b/yesod-core/Yesod/Routes/Parse.hs @@ -10,6 +10,8 @@ module Yesod.Routes.Parse , parseType , parseTypeTree , TypeTree (..) + , dropBracket + , nameToType ) where import Language.Haskell.TH.Syntax @@ -252,15 +254,18 @@ toTypeTree orig = do gos' (front . (t:)) xs' ttToType :: TypeTree -> Type -ttToType (TTTerm s@(h:_)) | isLower h = VarT $ mkName s -ttToType (TTTerm s) = ConT $ mkName s +ttToType (TTTerm s) = nameToType s ttToType (TTApp x y) = ttToType x `AppT` ttToType y ttToType (TTList t) = ListT `AppT` ttToType t +nameToType :: String -> Type +nameToType t@(h:_) | isLower h = VarT $ mkName t +nameToType t = ConT $ mkName t + pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String) -pieceFromString ('#':'!':x) = Right $ (False, dynamicPieceFromString x) -pieceFromString ('!':'#':x) = Right $ (False, dynamicPieceFromString x) -- https://github.com/yesodweb/yesod/issues/652 -pieceFromString ('#':x) = Right $ (True, dynamicPieceFromString x) +pieceFromString ('#':'!':x) = Right $ (False, Dynamic $ dropBracket x) +pieceFromString ('!':'#':x) = Right $ (False, Dynamic $ dropBracket x) -- https://github.com/yesodweb/yesod/issues/652 +pieceFromString ('#':x) = Right $ (True, Dynamic $ dropBracket x) pieceFromString ('*':'!':x) = Left (False, x) pieceFromString ('+':'!':x) = Left (False, x) @@ -274,9 +279,9 @@ pieceFromString ('+':x) = Left (True, x) pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x) -dynamicPieceFromString :: String -> Piece String -dynamicPieceFromString str@('{':x) = case break (== '}') x of - (s, "}") -> Dynamic s - _ -> error $ "Invalid path piece: " ++ str -dynamicPieceFromString x = Dynamic x --- JP: Should we check if there are curly brackets or other invalid characters? +dropBracket :: String -> String +dropBracket str@('{':x) = case break (== '}') x of + (s, "}") -> s + _ -> error $ "Unclosed bracket ('{'): " ++ str +dropBracket x = x + diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index 95ad9bbc..3e703757 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/Yesod/Routes/TH/RenderRoute.hs @@ -3,7 +3,6 @@ module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance , mkRenderRouteInstance' - , mkRenderRouteInstance' , mkRouteCons , mkRenderRouteClauses ) where From 6b000ecfb4ff1106b928f11d441705f65e2f9fe1 Mon Sep 17 00:00:00 2001 From: James Parker Date: Mon, 27 Mar 2017 12:06:44 -0400 Subject: [PATCH 028/124] Version bump and fix for old versions of TH. --- yesod-core/ChangeLog.md | 5 +++++ yesod-core/Yesod/Core/Internal/TH.hs | 18 +++++++++++++++++- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 15 +++++++++++---- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 34 insertions(+), 6 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 7ee382e4..6ee1fdda 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.34 + +* Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365) +* Type variables can be included in routes. + ## 1.4.32 * Fix warnings diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 565466bb..8ee5b4e0 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -16,7 +16,11 @@ import Language.Haskell.TH.Syntax import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () +#if MIN_VERSION_base(4,8,0) import Data.List (foldl', uncons) +#else +import Data.List (foldl') +#endif #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif @@ -125,7 +129,13 @@ mkYesodGeneral' :: [[String]] -- ^ Appliction context. Used in Ren -> [ResourceTree String] -> Q([Dec],[Dec]) mkYesodGeneral' appCxt' namestr args isSub f resS = do - let appCxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest) appCxt' + let appCxt = fmap (\(c:rest) -> +#if MIN_VERSION_template_haskell(2,10,0) + foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest +#else + ClassP (mkName c) $ fmap nameToType rest +#endif + ) appCxt' mname <- lookupTypeName namestr arity <- case mname of Just name -> do @@ -186,6 +196,12 @@ mkYesodGeneral' appCxt' namestr args isSub f resS = do ] return (dataDec, dispatchDec) +#if !MIN_VERSION_base(4,8,0) + where + uncons (h:t) = Just (h,t) + uncons _ = Nothing +#endif + mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index 3e703757..594c4617 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/Yesod/Routes/TH/RenderRoute.hs @@ -12,7 +12,9 @@ import Yesod.Routes.TH.Types import Language.Haskell.TH (conT) #endif import Language.Haskell.TH.Syntax +#if MIN_VERSION_template_haskell(2,11,0) import Data.Bits (xor) +#endif import Data.Maybe (maybeToList) import Control.Monad (replicateM) import Data.Text (pack) @@ -158,22 +160,27 @@ mkRenderRouteInstance' cxt typ ress = do (cons, decs) <- mkRouteCons ress #if MIN_VERSION_template_haskell(2,12,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) + let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #elif MIN_VERSION_template_haskell(2,11,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False) -#else - let did = DataInstD [] ''Route [typ] cons (clazzes False) -#endif let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) +#else + let did = DataInstD [] ''Route [typ] cons clazzes' + let sds = [] +#endif return $ instanceD cxt (ConT ''RenderRoute `AppT` typ) [ did , FunD (mkName "renderRoute") cls ] : sds ++ decs where +#if MIN_VERSION_template_haskell(2,11,0) clazzes standalone = if standalone `xor` null cxt then - [''Show, ''Eq, ''Read] + clazzes' else [] +#endif + clazzes' = [''Show, ''Eq, ''Read] #if MIN_VERSION_template_haskell(2,11,0) notStrict :: Bang diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 8fda2795..ed364acc 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.32 +version: 1.4.34 license: MIT license-file: LICENSE author: Michael Snoyman From 757514c536afc5d9dedd984375ebe1c2a22b8c53 Mon Sep 17 00:00:00 2001 From: mingyu guo Date: Tue, 28 Mar 2017 20:40:05 +1030 Subject: [PATCH 029/124] Completed chineseMessage in Yesod.Auth.Message. Previously, most of the messages are using simplified characters, but the google translated parts are using traditional characters. I have fixed this as well. --- yesod-auth/Yesod/Auth/Message.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index a2020550..271f83f7 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -511,9 +511,9 @@ chineseMessage LoginOpenID = "用OpenID登录" chineseMessage LoginGoogle = "用Google帐户登录" chineseMessage LoginYahoo = "用Yahoo帐户登录" chineseMessage Email = "邮箱" -chineseMessage UserName = "用户名" -- FIXME by Google Translate "user name" +chineseMessage UserName = "用户名" chineseMessage Password = "密码" -chineseMessage CurrentPassword = "Current password" +chineseMessage CurrentPassword = "当前密码" chineseMessage Register = "注册" chineseMessage RegisterLong = "注册新帐户" chineseMessage EnterEmail = "输入你的邮箱地址，你将收到一封确认邮件。" @@ -547,11 +547,10 @@ chineseMessage ProvideIdentifier = "邮箱或用户名" chineseMessage SendPasswordResetEmail = "发送密码重置邮件" chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。" chineseMessage InvalidUsernamePass = "无效的用户名/密码组合" --- TODO -chineseMessage i@(IdentifierNotFound _) = englishMessage i -chineseMessage Logout = "註銷" -- FIXME by Google Translate -chineseMessage LogoutTitle = "註銷" -- FIXME by Google Translate -chineseMessage AuthError = "验证错误" -- FIXME by Google Translate +chineseMessage (IdentifierNotFound ident) = "邮箱/用户名不存在: " `mappend` ident +chineseMessage Logout = "注销" +chineseMessage LogoutTitle = "注销" +chineseMessage AuthError = "验证错误" czechMessage :: AuthMessage -> Text czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID" From db9b51cdf42c1ef657fbc5e0dfd3a6cf8ad9b7dc Mon Sep 17 00:00:00 2001 From: mingyu guo Date: Tue, 28 Mar 2017 20:59:48 +1030 Subject: [PATCH 030/124] Added Yesod.Form.I18n.Chinese --- yesod-form/Yesod/Form/I18n/Chinese.hs | 26 ++++++++++++++++++++++++++ yesod-form/yesod-form.cabal | 1 + 2 files changed, 27 insertions(+) create mode 100644 yesod-form/Yesod/Form/I18n/Chinese.hs diff --git a/yesod-form/Yesod/Form/I18n/Chinese.hs b/yesod-form/Yesod/Form/I18n/Chinese.hs new file mode 100644 index 00000000..5d85effc --- /dev/null +++ b/yesod-form/Yesod/Form/I18n/Chinese.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Form.I18n.Chinese where + +import Yesod.Form.Types (FormMessage (..)) +import Data.Monoid (mappend) +import Data.Text (Text) + +chineseFormMessage :: FormMessage -> Text +chineseFormMessage (MsgInvalidInteger t) = "无效的整数: " `Data.Monoid.mappend` t +chineseFormMessage (MsgInvalidNumber t) = "无效的数字: " `mappend` t +chineseFormMessage (MsgInvalidEntry t) = "无效的条目: " `mappend` t +chineseFormMessage MsgInvalidTimeFormat = "无效的时间, 必须符合HH:MM[:SS]格式" +chineseFormMessage MsgInvalidDay = "无效的日期, 必须符合YYYY-MM-DD格式" +chineseFormMessage (MsgInvalidUrl t) = "无效的链接: " `mappend` t +chineseFormMessage (MsgInvalidEmail t) = "无效的邮箱地址: " `mappend` t +chineseFormMessage (MsgInvalidHour t) = "无效的小时: " `mappend` t +chineseFormMessage (MsgInvalidMinute t) = "无效的分钟: " `mappend` t +chineseFormMessage (MsgInvalidSecond t) = "无效的秒: " `mappend` t +chineseFormMessage MsgCsrfWarning = "为了防备跨站请求伪造, 请确认表格提交." +chineseFormMessage MsgValueRequired = "此项必填" +chineseFormMessage (MsgInputNotFound t) = "输入找不到: " `mappend` t +chineseFormMessage MsgSelectNone = "<空>" +chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t +chineseFormMessage MsgBoolYes = "是" +chineseFormMessage MsgBoolNo = "否" +chineseFormMessage MsgDelete = "删除?" diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 61dc4e35..1d087185 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -68,6 +68,7 @@ library Yesod.Form.I18n.Russian Yesod.Form.I18n.Dutch Yesod.Form.I18n.Spanish + Yesod.Form.I18n.Chinese -- FIXME Yesod.Helpers.Crud ghc-options: -Wall From c1fa2645c04f49c6d74462f6d5e594e1a467abb2 Mon Sep 17 00:00:00 2001 From: Divam Date: Wed, 5 Apr 2017 10:07:09 +0900 Subject: [PATCH 031/124] Japanese message for Current password --- yesod-auth/Yesod/Auth/Message.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index a2020550..6127edf4 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -416,7 +416,7 @@ japaneseMessage LoginYahoo = "Yahooでログイン" japaneseMessage Email = "Eメール" japaneseMessage UserName = "ユーザー名" -- FIXME by Google Translate "user name" japaneseMessage Password = "パスワード" -japaneseMessage CurrentPassword = "Current password" +japaneseMessage CurrentPassword = "現在のパスワード" japaneseMessage Register = "登録" japaneseMessage RegisterLong = "新規アカウント登録" japaneseMessage EnterEmail = "メールアドレスを入力してください。確認メールが送られます" From d8919c2c2d050ddda505fe1f7b78d86f7d33b92a Mon Sep 17 00:00:00 2001 From: rkaminsk Date: Sun, 9 Apr 2017 02:44:39 +0200 Subject: [PATCH 032/124] remove value attribute from password field (#1374) remove value attribute from password field Fixes https://github.com/yesodweb/yesod/issues/1373 --- yesod-form/Yesod/Form/Fields.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 7bdeb516..8833b2fc 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -267,9 +267,9 @@ $newline never passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text passwordField = Field { fieldParse = parseHelper $ Right - , fieldView = \theId name attrs val isReq -> toWidget [hamlet| + , fieldView = \theId name attrs _ isReq -> toWidget [hamlet| $newline never - + |] , fieldEnctype = UrlEncoded } From b8d2647a6a649f1ed247f80562feb0612022597b Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Tue, 11 Apr 2017 20:30:55 +0300 Subject: [PATCH 033/124] Add assertNotEq --- yesod-test/ChangeLog.md | 5 +++++ yesod-test/Yesod/Test.hs | 12 ++++++++++++ yesod-test/yesod-test.cabal | 2 +- 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 98ff81a4..0245581e 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.5.6 + +* Add assertNotEq. +[#1375](https://github.com/yesodweb/yesod/pull/1375) + ## 1.5.5 * Fix warnings diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 93a05b99..79a62df5 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -86,6 +86,7 @@ module Yesod.Test -- * Assertions , assertEqual + , assertNotEq , assertEqualNoShow , assertEq @@ -335,6 +336,17 @@ assertEq m a b = "First argument: " ++ ppShow a ++ "\n" ++ "Second argument: " ++ ppShow b ++ "\n" +-- | Asserts that the two given values are not equal. +-- +-- In case they are equal, error mesasge includes the values. +-- +-- @since 1.5.6 +assertNotEq :: (Eq a, Show a) => String -> a -> a -> YesodExample site () +assertNotEq m a b = + liftIO $ HUnit.assertBool msg (a /= b) + where msg = "Assertion: " ++ m ++ "\n" ++ + "Both arguments: " ++ ppShow a ++ "\n" + {-# DEPRECATED assertEqual "Use assertEq instead" #-} assertEqual :: (Eq a) => String -> a -> a -> YesodExample site () assertEqual = assertEqualNoShow diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 7448e7ee..cd1dddc7 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.5.5 +version: 1.5.6 license: MIT license-file: LICENSE author: Nubis From 3229b7ad931cfe476c9569439ea7642a836e3467 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 12 Apr 2017 11:02:27 +0300 Subject: [PATCH 034/124] persistent 2.7 --- yesod-auth/yesod-auth.cabal | 4 ++-- yesod-persistent/yesod-persistent.cabal | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 5c552686..e6101841 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -37,8 +37,8 @@ library , unordered-containers , yesod-form >= 1.4 && < 1.5 , transformers >= 0.2.2 - , persistent >= 2.1 && < 2.7 - , persistent-template >= 2.1 && < 2.7 + , persistent >= 2.1 && < 2.8 + , persistent-template >= 2.1 && < 2.8 , http-client , http-conduit >= 2.1 , aeson >= 0.7 diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index 2d04725b..ed9a33ed 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -16,8 +16,8 @@ extra-source-files: README.md ChangeLog.md library build-depends: base >= 4 && < 5 , yesod-core >= 1.4.0 && < 1.5 - , persistent >= 2.1 && < 2.7 - , persistent-template >= 2.1 && < 2.7 + , persistent >= 2.1 && < 2.8 + , persistent-template >= 2.1 && < 2.8 , transformers >= 0.2.2 , blaze-builder , conduit From 01d5f02ceebeac293cfbfd173b6bc4a7e28d029a Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 12 Apr 2017 19:31:40 +0200 Subject: [PATCH 035/124] GHC 7.6 not supported --- 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 ade5c86e..73bd487d 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -21,7 +21,7 @@ extra-source-files: README.md library - build-depends: base >= 4.6 && < 5 + build-depends: base >= 4.7 && < 5 , time >= 1.1.4 , wai >= 3.0 , wai-extra >= 3.0.7 From fcb1b7f6b4f1e163852fab789e1d4877b5547c0b Mon Sep 17 00:00:00 2001 From: Dawei LIU Date: Mon, 17 Apr 2017 15:25:03 +0200 Subject: [PATCH 036/124] Fix minor doc typo --- yesod-form/Yesod/Form/Input.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-form/Yesod/Form/Input.hs b/yesod-form/Yesod/Form/Input.hs index 4591ac17..826b4c60 100644 --- a/yesod-form/Yesod/Form/Input.hs +++ b/yesod-form/Yesod/Form/Input.hs @@ -25,7 +25,7 @@ import Control.Arrow ((***)) type DText = [Text] -> [Text] -- | Type for a form which parses a value of type @a@ with the base monad @m@ --- (usually your @Handler@). Can can compose this using its @Applicative@ instance. +-- (usually your @Handler@). Can compose this using its @Applicative@ instance. newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) } instance Monad m => Functor (FormInput m) where fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e' From 878534a272e06fb65ea44a86a7558d6f07c9cfcf Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 20 Apr 2017 18:52:20 +0530 Subject: [PATCH 037/124] Fix race condition in yesod-bin Stack build process emittles line even after successful build process which leads to the overwriting of the appPortVar with -1. This leads it to a compile mode again. Pressing Return Key and rebuilding it again makes it go, but that's just a workaround I have to do every now and then to solve the actual issue. I'm using a `MVar` based locking solution for fixing the race condition introduced. --- yesod-bin/Devel.hs | 37 +++++++++++++++++++++++++++++++++++-- yesod-bin/yesod-bin.cabal | 2 +- 2 files changed, 36 insertions(+), 3 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 4289317b..b477557c 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -11,9 +12,12 @@ import Control.Applicative ((<|>)) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) import Control.Concurrent.STM +import Control.Concurrent.MVar +import System.IO import qualified Control.Exception.Safe as Ex import Control.Monad (forever, unless, void, when) +import Data.ByteString (ByteString, isInfixOf) import qualified Data.ByteString.Lazy as LB import Data.Conduit (($$), (=$)) import qualified Data.Conduit.Binary as CB @@ -222,6 +226,33 @@ checkDevelFile = then return x else loop xs +stackSuccessString :: ByteString +stackSuccessString = "ExitSuccess" + +stackFailureString :: ByteString +stackFailureString = "ExitFailure" + +data BuildOutput = Started + deriving (Show, Eq, Ord) + +makeEmptyMVar :: MVar a -> IO () +makeEmptyMVar mvar = do + isEmpty <- isEmptyMVar mvar + case isEmpty of + True -> return () + False -> takeMVar mvar >> return () + +updateAppPort :: ByteString -> MVar (BuildOutput) -> TVar Int -> IO () +updateAppPort bs mvar appPortVar = do + isEmpty <- isEmptyMVar mvar + let hasEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs + case (isEmpty,hasEnd) of + (True,False) -> do + putMVar mvar Started + atomically $ writeTVar appPortVar (-1 :: Int) + (_,False) -> return () + (_,True) -> makeEmptyMVar mvar + -- | Get the set of all flags available in the given cabal file getAvailableFlags :: D.GenericPackageDescription -> Set.Set String getAvailableFlags = @@ -283,6 +314,7 @@ devel opts passThroughArgs = do sayV = when (verbose opts) . sayString -- Leverage "stack build --file-watch" to do the build + runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO () runStackBuild appPortVar packageName availableFlags = do -- We call into this app for the devel-signal command myPath <- getExecutablePath @@ -316,7 +348,7 @@ devel opts passThroughArgs = do passThroughArgs sayV $ show procConfig - + mvar <- newEmptyMVar -- Monitor the stdout and stderr content from the build process. Any -- time some output comes, we invalidate the currently running app by -- changing the destination port for reverse proxying to -1. We also @@ -325,12 +357,13 @@ devel opts passThroughArgs = do withProcess_ procConfig $ \p -> do let helper getter h = getter p - $$ CL.iterM (\_ -> atomically $ writeTVar appPortVar (-1)) + $$ CL.iterM (\(str :: ByteString) -> updateAppPort str mvar appPortVar) =$ CB.sinkHandle h race_ (helper getStdout stdout) (helper getStderr stderr) -- Run the inner action with a TVar which will be set to True -- whenever the signal file is modified. + withChangedVar :: (TVar Bool -> IO a) -> IO a withChangedVar inner = withManager $ \manager -> do -- Variable indicating that the signal file has been changed. We -- reset it each time we handle the signal. diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 54eb1805..31f42fb6 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2.2 +version: 1.7 license: MIT license-file: LICENSE author: Michael Snoyman From c37283e300fd21374bfc3901ce1a2bf666667959 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Mon, 24 Apr 2017 20:39:20 +0530 Subject: [PATCH 038/124] Update Changelog and do version bump --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/yesod-bin.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 9a8c6990..2ffb0332 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2.3 + +* Fix race condition which leads dev server to stay in compilation mode. [#1380](https://github.com/yesodweb/yesod/issues/1380) + ## 1.5.2.2 * I guess `--no-nix-pure` implies Nix... sigh [#1359](https://github.com/yesodweb/yesod/issues/1359) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 31f42fb6..67d6392f 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.7 +version: 1.5.2.3 license: MIT license-file: LICENSE author: Michael Snoyman From 62d7a19149783f47ca8e392c216acaefc386d76a Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Mon, 24 Apr 2017 21:51:13 +0530 Subject: [PATCH 039/124] Fix warnings --- yesod-bin/Devel.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index b477557c..b7c0de28 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -13,7 +13,6 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) import Control.Concurrent.STM import Control.Concurrent.MVar -import System.IO import qualified Control.Exception.Safe as Ex import Control.Monad (forever, unless, void, when) From 706de891562ff9ec70c51a3d536ffb18a2a53c52 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 26 Apr 2017 19:37:59 +0530 Subject: [PATCH 040/124] Change logic to use TVar --- yesod-bin/Devel.hs | 42 ++++++++++++++++++++---------------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index b7c0de28..45cb4239 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -231,26 +231,24 @@ stackSuccessString = "ExitSuccess" stackFailureString :: ByteString stackFailureString = "ExitFailure" -data BuildOutput = Started - deriving (Show, Eq, Ord) - -makeEmptyMVar :: MVar a -> IO () -makeEmptyMVar mvar = do - isEmpty <- isEmptyMVar mvar - case isEmpty of - True -> return () - False -> takeMVar mvar >> return () - -updateAppPort :: ByteString -> MVar (BuildOutput) -> TVar Int -> IO () -updateAppPort bs mvar appPortVar = do - isEmpty <- isEmptyMVar mvar - let hasEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs - case (isEmpty,hasEnd) of - (True,False) -> do - putMVar mvar Started - atomically $ writeTVar appPortVar (-1 :: Int) - (_,False) -> return () - (_,True) -> makeEmptyMVar mvar +-- We need updateAppPort logic to prevent a race condition. +-- See https://github.com/yesodweb/yesod/issues/1380 +updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the + -- output from stack has + -- started. False indicate + -- that it hasn't started + -- yet. + -> TVar Int -> IO () +updateAppPort bs buildStarted appPortVar = do + hasStarted <- readTVarIO buildStarted + let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs + case (hasStarted, buildEnd) of + (False, False) -> do + atomically $ do + writeTVar appPortVar (-1 :: Int) + writeTVar buildStarted True + (True, False) -> return () + (_, True) -> atomically $ writeTVar buildStarted False -- | Get the set of all flags available in the given cabal file getAvailableFlags :: D.GenericPackageDescription -> Set.Set String @@ -347,7 +345,7 @@ devel opts passThroughArgs = do passThroughArgs sayV $ show procConfig - mvar <- newEmptyMVar + buildStarted <- newTVarIO False -- Monitor the stdout and stderr content from the build process. Any -- time some output comes, we invalidate the currently running app by -- changing the destination port for reverse proxying to -1. We also @@ -356,7 +354,7 @@ devel opts passThroughArgs = do withProcess_ procConfig $ \p -> do let helper getter h = getter p - $$ CL.iterM (\(str :: ByteString) -> updateAppPort str mvar appPortVar) + $$ CL.iterM (\(str :: ByteString) -> updateAppPort str buildStarted appPortVar) =$ CB.sinkHandle h race_ (helper getStdout stdout) (helper getStderr stderr) From 37c9d2599001b5e49635f4eea994524d4e115a61 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 26 Apr 2017 20:56:58 +0530 Subject: [PATCH 041/124] Add Debug flag --- yesod-bin/Devel.hs | 20 +++++++++++++++++--- yesod/yesod.cabal | 2 +- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 45cb4239..889f91c8 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -12,7 +12,6 @@ import Control.Applicative ((<|>)) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race_) import Control.Concurrent.STM -import Control.Concurrent.MVar import qualified Control.Exception.Safe as Ex import Control.Monad (forever, unless, void, when) @@ -145,6 +144,9 @@ reverseProxy opts appPortVar = do let proxyApp = waiProxyToSettings (const $ do appPort <- atomically $ readTVar appPortVar +#if DEBUG + print $ "revProxy: appPort " ++ (show appPort) +#endif return $ ReverseProxy.WPRProxyDest $ ProxyDest "127.0.0.1" appPort) @@ -244,11 +246,22 @@ updateAppPort bs buildStarted appPortVar = do let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs case (hasStarted, buildEnd) of (False, False) -> do +#if DEBUG + print "updated appPortVar to -1" +#endif atomically $ do writeTVar appPortVar (-1 :: Int) writeTVar buildStarted True - (True, False) -> return () - (_, True) -> atomically $ writeTVar buildStarted False + (True, False) -> do +#if DEBUG + print "ignored" +#endif + return () + (_, True) -> do +#if DEBUG + print "Reset buildStarted to False" +#endif + atomically $ writeTVar buildStarted False -- | Get the set of all flags available in the given cabal file getAvailableFlags :: D.GenericPackageDescription -> Set.Set String @@ -383,6 +396,7 @@ devel opts passThroughArgs = do inner changedVar -- Each time the library builds successfully, run the application + runApp :: TVar Int -> TVar Bool -> String -> IO b runApp appPortVar changedVar develHsPath = do -- Wait for the first change, indicating that the library -- has been built diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index fdde1f0e..b804714b 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.4.5 +version: 1.4.6 license: MIT license-file: LICENSE author: Michael Snoyman From 35e0095590ad3b372e3772e50b75e16f7062e20b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 26 Apr 2017 20:57:13 +0530 Subject: [PATCH 042/124] Add releavant flag in yesod-bin --- yesod-bin/yesod-bin.cabal | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 67d6392f..df53c4e8 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -18,11 +18,17 @@ extra-source-files: refreshing.html *.pem +flag debug + default: False + description: Print debugging info. + executable yesod if os(windows) cpp-options: -DWINDOWS if os(openbsd) ld-options: -Wl,-zwxneeded + if flag(debug) + cpp-options: -DDEBUG build-depends: base >= 4.3 && < 5 , parsec >= 2.1 && < 4 From 67eb728703ea773614b7f2d62bdd3e2236cb9d1f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 27 Apr 2017 17:08:12 +0530 Subject: [PATCH 043/124] Make updateAppPort as a single STM transaction --- yesod-bin/Devel.hs | 31 +++++++++---------------------- 1 file changed, 9 insertions(+), 22 deletions(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 889f91c8..22e6a515 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -128,6 +128,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO () reverseProxy opts appPortVar = do manager <- newManager $ managerSetProxy noProxy tlsManagerSettings let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")] + sayV = when (verbose opts) . sayString let onExc _ req | maybe False (("application/json" `elem`) . parseHttpAccept) (lookup "accept" $ requestHeaders req) = @@ -144,9 +145,7 @@ reverseProxy opts appPortVar = do let proxyApp = waiProxyToSettings (const $ do appPort <- atomically $ readTVar appPortVar -#if DEBUG - print $ "revProxy: appPort " ++ (show appPort) -#endif + sayV $ "revProxy: appPort " ++ (show appPort) return $ ReverseProxy.WPRProxyDest $ ProxyDest "127.0.0.1" appPort) @@ -240,28 +239,16 @@ updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the -- started. False indicate -- that it hasn't started -- yet. - -> TVar Int -> IO () + -> TVar Int -> STM () updateAppPort bs buildStarted appPortVar = do - hasStarted <- readTVarIO buildStarted + hasStarted <- readTVar buildStarted let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs case (hasStarted, buildEnd) of (False, False) -> do -#if DEBUG - print "updated appPortVar to -1" -#endif - atomically $ do - writeTVar appPortVar (-1 :: Int) - writeTVar buildStarted True - (True, False) -> do -#if DEBUG - print "ignored" -#endif - return () - (_, True) -> do -#if DEBUG - print "Reset buildStarted to False" -#endif - atomically $ writeTVar buildStarted False + writeTVar appPortVar (-1 :: Int) + writeTVar buildStarted True + (True, False) -> return () + (_, True) -> writeTVar buildStarted False -- | Get the set of all flags available in the given cabal file getAvailableFlags :: D.GenericPackageDescription -> Set.Set String @@ -367,7 +354,7 @@ devel opts passThroughArgs = do withProcess_ procConfig $ \p -> do let helper getter h = getter p - $$ CL.iterM (\(str :: ByteString) -> updateAppPort str buildStarted appPortVar) + $$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar)) =$ CB.sinkHandle h race_ (helper getStdout stdout) (helper getStderr stderr) From 10b5d4f8e267b853669a3e0178a51d85a3187ecb Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 27 Apr 2017 17:40:32 +0530 Subject: [PATCH 044/124] Remove debug option --- yesod-bin/yesod-bin.cabal | 4 ---- 1 file changed, 4 deletions(-) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index df53c4e8..1560c8b7 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -18,10 +18,6 @@ extra-source-files: refreshing.html *.pem -flag debug - default: False - description: Print debugging info. - executable yesod if os(windows) cpp-options: -DWINDOWS From 3350ca3d9adf13b0c37b638e79443ad0a6bec990 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 27 Apr 2017 17:49:21 +0530 Subject: [PATCH 045/124] Remove flag conditional --- yesod-bin/yesod-bin.cabal | 2 -- 1 file changed, 2 deletions(-) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 1560c8b7..67d6392f 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -23,8 +23,6 @@ executable yesod cpp-options: -DWINDOWS if os(openbsd) ld-options: -Wl,-zwxneeded - if flag(debug) - cpp-options: -DDEBUG build-depends: base >= 4.3 && < 5 , parsec >= 2.1 && < 4 From 5bb5e8948faccbaafc34dd7896e2d885a65b6cb4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 27 Apr 2017 18:03:39 +0530 Subject: [PATCH 046/124] Revert back yesod version --- yesod/yesod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index b804714b..fdde1f0e 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.4.6 +version: 1.4.5 license: MIT license-file: LICENSE author: Michael Snoyman From 13cea1e3f74b2040dbf6d110605a3744d51ba531 Mon Sep 17 00:00:00 2001 From: Steven Shaw Date: Thu, 4 May 2017 11:54:17 +1000 Subject: [PATCH 047/124] Fix Haddock formatting for staticFilesList --- yesod-static/Yesod/Static.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 1356f22d..168bbbf8 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -246,7 +246,7 @@ staticFiles dir = mkStaticFiles dir -- files @\"static\/js\/jquery.js\"@ and -- @\"static\/css\/normalize.css\"@, you would use: -- --- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"] +-- > staticFilesList "static" ["js/jquery.js", "css/normalize.css"] -- -- This can be useful when you have a very large number of static -- files, but only need to refer to a few of them from Haskell. From 56b09eef9309f2610377eb20365ff584e3694f0c Mon Sep 17 00:00:00 2001 From: James Haver II Date: Fri, 12 May 2017 00:13:07 +0800 Subject: [PATCH 048/124] Add WaiSubsiteWithAuth --- yesod-core/Yesod/Core/Class/Dispatch.hs | 11 ++++++++++- yesod-core/Yesod/Core/Dispatch.hs | 1 + yesod-core/Yesod/Core/Types.hs | 10 ++++++++++ 3 files changed, 21 insertions(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index 7f52b9fb..b68340ea 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -10,7 +10,7 @@ import Yesod.Routes.Class import qualified Network.Wai as W import Yesod.Core.Types import Yesod.Core.Content -import Yesod.Core.Handler (stripHandlerT) +import Yesod.Core.Handler (sendWaiApplication, stripHandlerT) import Yesod.Core.Class.Yesod import Yesod.Core.Class.Handler @@ -28,6 +28,15 @@ instance YesodSubDispatch WaiSubsite master where where WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv +instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where + yesodSubDispatch YesodSubRunnerEnv {..} req = + ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req + where + base = stripHandlerT handlert ysreGetSub ysreToParentRoute route + route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) [] + WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv + handlert = sendWaiApplication $ set + -- | A helper function for creating YesodSubDispatch instances, used by the -- internal generated code. This function has been exported since 1.4.11. -- It promotes a subsite handler to a wai application. diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 17674268..d13a154d 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -34,6 +34,7 @@ module Yesod.Core.Dispatch , defaultMiddlewaresNoLogging -- * WAI subsites , WaiSubsite (..) + , WaiSubsiteWithAuth (..) , subHelper ) where diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index fa86a6f5..38194b4f 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -178,6 +178,8 @@ type Texts = [Text] -- | Wrap up a normal WAI application as a Yesod subsite. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } +newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } + data RunHandlerEnv site = RunHandlerEnv { rheRender :: !(Route site -> [(Text, Text)] -> Text) , rheRoute :: !(Maybe (Route site)) @@ -560,6 +562,14 @@ instance RenderRoute WaiSubsite where instance ParseRoute WaiSubsite where parseRoute (x, y) = Just $ WaiSubsiteRoute x y +instance RenderRoute WaiSubsiteWithAuth where + data Route WaiSubsiteWithAuth = WaiSubsiteWithAuthRoute [Text] [(Text,Text)] + deriving (Show, Eq, Read, Ord) + renderRoute (WaiSubsiteWithAuthRoute ps qs) = (ps,qs) + +instance ParseRoute WaiSubsiteWithAuth where + parseRoute (x, y) = Just $ WaiSubsiteWithAuthRoute x y + data Logger = Logger { loggerSet :: !LoggerSet , loggerDate :: !DateCacheGetter From 5ee51262debc2c317ecfcefaa200f9bb1ab71b3c Mon Sep 17 00:00:00 2001 From: James Haver II Date: Fri, 12 May 2017 01:04:13 +0800 Subject: [PATCH 049/124] Update ChangeLog and Hackage comments --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/Yesod/Core/Types.hs | 5 ++++- yesod-core/yesod-core.cabal | 2 +- 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index d23ec260..7cfee692 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.34 + +* Add `WaiSubsiteWithAuth`. [#1394](https://github.com/yesodweb/yesod/pull/1394) + ## 1.4.33 * Adds curly brackets to route parser. [#1363](https://github.com/yesodweb/yesod/pull/1363) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index 38194b4f..5067c480 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -175,9 +175,12 @@ type BottomOfHeadAsync master type Texts = [Text] --- | Wrap up a normal WAI application as a Yesod subsite. +-- | Wrap up a normal WAI application as a Yesod subsite. Ignore parent site's middleware and isAuthorized. newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } +-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized. +-- +-- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } data RunHandlerEnv site = RunHandlerEnv diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 73bd487d..bbd637c2 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.33 +version: 1.4.34 license: MIT license-file: LICENSE author: Michael Snoyman From 5721f65ebfb3f05830832133c6f27f15e1bf4fe4 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 14 May 2017 00:24:12 +0300 Subject: [PATCH 050/124] Version bumps --- yesod-auth/ChangeLog.md | 4 ++++ yesod-auth/yesod-auth.cabal | 2 +- yesod-form/ChangeLog.md | 4 ++++ yesod-form/yesod-form.cabal | 2 +- 4 files changed, 10 insertions(+), 2 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 27ae545c..b8ff2a13 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.17.1 + +* Some translation fixes + ## 1.4.17 * Add Show instance for user credentials `Creds` diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index e6101841..71c928c9 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.17 +version: 1.4.17.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 0da6f50a..3fa52a16 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.12 + +* Password field does not remember its previous value + ## 1.4.11 * Fix warnings diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 1d087185..617ada59 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.11 +version: 1.4.12 license: MIT license-file: LICENSE author: Michael Snoyman From 92849d863c6b352701e44f00f7e4923d97b796bd Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 08:18:39 +0530 Subject: [PATCH 051/124] Port to cryptonite --- yesod-auth/Yesod/Auth/Email.hs | 6 +++--- yesod-auth/Yesod/PasswordStore.hs | 15 +++++++++------ 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index aa76231a..0c6aa34d 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -117,9 +117,8 @@ import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form import qualified Yesod.PasswordStore as PS - import Control.Applicative ((<$>), (<*>)) -import qualified Crypto.Hash.MD5 as H +import qualified Crypto.Hash as H import qualified Crypto.Nonce as Nonce import Data.ByteString.Base16 as B16 import Data.Text (Text) @@ -134,6 +133,7 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) import Data.Maybe (isJust, isNothing, fromJust) +import Data.ByteArray (convert) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -811,7 +811,7 @@ saltPass = fmap (decodeUtf8With lenientDecode) saltPass' :: String -> String -> String saltPass' salt pass = - salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ H.hash $ TE.encodeUtf8 $ T.pack $ salt ++ pass) + salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ convert (H.hash (TE.encodeUtf8 $ T.pack $ salt ++ pass) :: H.Digest H.MD5)) isValidPass :: Text -- ^ cleartext password -> SaltedPass -- ^ salted password diff --git a/yesod-auth/Yesod/PasswordStore.hs b/yesod-auth/Yesod/PasswordStore.hs index 9408b7bc..9e32a48e 100755 --- a/yesod-auth/Yesod/PasswordStore.hs +++ b/yesod-auth/Yesod/PasswordStore.hs @@ -102,16 +102,14 @@ module Yesod.PasswordStore ( importSalt -- :: ByteString -> Salt ) where - +import qualified Crypto.MAC.HMAC as CH import qualified Crypto.Hash as CH -import qualified Crypto.Hash.SHA256 as H import qualified Data.ByteString.Char8 as B import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Binary as Binary import Control.Monad import Control.Monad.ST -import Data.Byteable (toBytes) import Data.STRef import Data.Bits import Data.ByteString.Char8 (ByteString) @@ -120,6 +118,7 @@ import System.IO import System.Random import Data.Maybe import qualified Control.Exception +import Data.ByteArray (convert) --------------------- -- Cryptographic base @@ -134,14 +133,18 @@ import qualified Control.Exception -- matches. pbkdf1 :: ByteString -> Salt -> Int -> ByteString pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1) - where first_hash = H.finalize $ H.init `H.update` password `H.update` salt + where + first_hash = + convert $ + ((CH.hashFinalize $ CH.hashInit `CH.hashUpdate` password `CH.hashUpdate` salt) :: CH.Digest CH.SHA256) + -- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0 -- or more. If the number of rounds specified is 0, the ByteString will be -- returned unmodified. hashRounds :: ByteString -> Int -> ByteString hashRounds (!bs) 0 = bs -hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1) +hashRounds bs rounds = hashRounds (convert (CH.hash bs :: CH.Digest CH.SHA256)) (rounds - 1) -- | Computes the hmacSHA256 of the given message, with the given 'Salt'. hmacSHA256 :: ByteString @@ -151,7 +154,7 @@ hmacSHA256 :: ByteString -> ByteString -- ^ The encoded message hmacSHA256 secret msg = - toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256) + convert (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256) -- | PBKDF2 key-derivation function. -- For details see @http://tools.ietf.org/html/rfc2898@. From f1fb571427feeca93547bfd2e921bf740b8a5227 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 08:18:53 +0530 Subject: [PATCH 052/124] Make relevant changes to cabal file for yesod-auth --- yesod-auth/yesod-auth.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 71c928c9..18330036 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -27,7 +27,8 @@ library , wai >= 1.4 , template-haskell , base16-bytestring - , cryptohash + , cryptonite + , memory , random >= 1.0.0.2 , text >= 0.7 , mime-mail >= 0.3 From 8f5b0bc2389c9711c63fad5a2dac8cf8e80ca789 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 08:43:29 +0530 Subject: [PATCH 053/124] Do version bump and add Changelog Partially addresses #1397 --- yesod-auth/ChangeLog.md | 4 ++++ yesod-auth/yesod-auth.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index b8ff2a13..fdfbfeea 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.17.2 + +* Move to cryptonite from cryptohash + ## 1.4.17.1 * Some translation fixes diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 18330036..a50db32a 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.17.1 +version: 1.4.17.2 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From cc1fa4219224096f4885ced37f30af34f0a358dd Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 09:46:04 +0530 Subject: [PATCH 054/124] Update travis to use ghc-8.0.2 instead of 8.0.1 --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 9a2002f1..fcafa250 100644 --- a/.travis.yml +++ b/.travis.yml @@ -54,8 +54,8 @@ matrix: compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - env: BUILD=cabal GHCVER=8.0.1 CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 8.0.1" - addons: {apt: {packages: [cabal-install-head,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + compiler: ": #GHC 8.0.2" + addons: {apt: {packages: [cabal-install-1.24.2.0,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. From d56485c3d346169e6320187cb8bac41d496e1628 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 09:46:44 +0530 Subject: [PATCH 055/124] Cryptonite --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index 03dfba42..0a596b78 100644 --- a/stack.yaml +++ b/stack.yaml @@ -23,6 +23,7 @@ extra-deps: - persistent-2.5 - persistent-sqlite-2.5 - cookie-0.4.2 +- cryptonite-0.23 - conduit-extra-1.1.14 - streaming-commons-0.1.16 From 4ba2fc8494547c15aa1156dfa1a8228bc2d64d5d Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 09:50:47 +0530 Subject: [PATCH 056/124] Add foundation to stack.yaml --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index 0a596b78..b3eb41d3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,6 +24,7 @@ extra-deps: - persistent-sqlite-2.5 - cookie-0.4.2 - cryptonite-0.23 +- foundation-0.0.9 - conduit-extra-1.1.14 - streaming-commons-0.1.16 From 36a98bc4ab210a695c6ca050d7314a6d5cced1da Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 12:06:36 +0530 Subject: [PATCH 057/124] Add memory to stack yaml for lts-2 --- stack.yaml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index b3eb41d3..cef0c7b5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.23 +resolver: lts-2.12 packages: - ./yesod-core - ./yesod-static @@ -25,6 +25,7 @@ extra-deps: - cookie-0.4.2 - cryptonite-0.23 - foundation-0.0.9 +- memory-0.14.5 - conduit-extra-1.1.14 - streaming-commons-0.1.16 From 635470f7500b31e24ec94e634f2ef5ba61569748 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 13:32:35 +0530 Subject: [PATCH 058/124] Change cabal install version --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index fcafa250..72ccdc49 100644 --- a/.travis.yml +++ b/.travis.yml @@ -55,7 +55,7 @@ matrix: addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - env: BUILD=cabal GHCVER=8.0.1 CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #GHC 8.0.2" - addons: {apt: {packages: [cabal-install-1.24.2.0,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. From 37452896d2a77108189d5489d94da4e4397a5d89 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 18 May 2017 19:17:55 +0530 Subject: [PATCH 059/124] Try fixing travis error --- .travis.yml | 2 +- stack.yaml | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 72ccdc49..ee1a40b9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -53,7 +53,7 @@ matrix: - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #GHC 7.10.3" addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=8.0.1 CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 + - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} diff --git a/stack.yaml b/stack.yaml index cef0c7b5..88e1062b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-2.12 +resolver: lts-6.23 packages: - ./yesod-core - ./yesod-static @@ -26,6 +26,14 @@ extra-deps: - cryptonite-0.23 - foundation-0.0.9 - memory-0.14.5 +- hfsevents-0.1.6 +- x509-1.6.5 +- x509-store-1.6.2 +- x509-system-1.6.4 +- x509-validation-1.6.5 +- tls-1.3.8 +- Win32-notify-0.3.0.1 + - conduit-extra-1.1.14 - streaming-commons-0.1.16 From ec90f48d889e616cc16e93645d8daac5ce1261b2 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Sun, 21 May 2017 19:53:28 +0530 Subject: [PATCH 060/124] Fix lts-2 related errors --- stack.yaml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 88e1062b..57a79fa9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -33,7 +33,10 @@ extra-deps: - x509-validation-1.6.5 - tls-1.3.8 - Win32-notify-0.3.0.1 - +- asn1-parse-0.9.4 +- asn1-types-0.3.2 +- connection-0.2.8 +- socks-0.5.5 - conduit-extra-1.1.14 - streaming-commons-0.1.16 From ded136513c05c7fe747fed60baaf0469ca344ea0 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Tue, 6 Jun 2017 13:32:39 +0900 Subject: [PATCH 061/124] Add support to yesod-static for mapping unfingerprinted files to their fingerprinted equivalents --- yesod-static/Yesod/Static.hs | 55 ++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 3 deletions(-) diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 168bbbf8..9454e681 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -51,6 +51,8 @@ module Yesod.Static -- * Template Haskell helpers , staticFiles , staticFilesList + , staticFilesMap + , staticFilesMergeMap , publicFiles -- * Hashing , base64md5 @@ -62,6 +64,7 @@ module Yesod.Static ) where import System.Directory +import qualified System.FilePath as FP import Control.Monad import Data.FileEmbed (embedDir) @@ -273,6 +276,43 @@ staticFilesList dir fs = publicFiles :: FilePath -> Q [Dec] publicFiles dir = mkStaticFiles' dir False +-- | Similar to 'staticFilesList', but takes a manifest mapping +-- unmunged names to fingerprinted file names. +staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] +staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True + where + splitBoth (k, v) = (split k, split v) + mapList = M.toList m + split :: FilePath -> [String] + split [] = [] + split x = + let (a, b) = break (== '/') x + in a : split (drop 1 b) + +staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] +staticFilesMergeMap fp m = do + fs <- qRunIO $ getFileListPieces fp + let filesList = map FP.joinPath fs + mergedMapList = M.toList $ foldl' (checkedInsert invertedMap) m filesList + mkStaticFilesList' fp (map splitBoth mergedMapList) True + where + splitBoth (k, v) = (split k, split v) + swap (x, y) = (y, x) + mapList = M.toList m + invertedMap = M.fromList $ map swap mapList + split :: FilePath -> [String] + split [] = [] + split x = + let (a, b) = break (== '/') x + in a : split (drop 1 b) + checkedInsert + :: M.Map FilePath FilePath -- inverted dictionary + -> M.Map FilePath FilePath -- accumulating state + -> FilePath + -> M.Map FilePath FilePath + checkedInsert iDict st p = if M.member p iDict + then st + else M.insert p p st mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString) mkHashMap dir = do @@ -330,7 +370,16 @@ mkStaticFilesList -> [[String]] -- ^ list of files to create identifiers for -> Bool -- ^ append checksum query parameter -> Q [Dec] -mkStaticFilesList fp fs makeHash = do +mkStaticFilesList fp fs makeHash = mkStaticFilesList' fp (zip fs fs) makeHash + +mkStaticFilesList' + :: FilePath -- ^ static directory + -> [([String], [String])] -- ^ list of files to create identifiers for, where + -- the first argument of the tuple is the identifier + -- alias and the second is the actual file name + -> Bool -- ^ append checksum query parameter + -> Q [Dec] +mkStaticFilesList' fp fs makeHash = do concat `fmap` mapM mkRoute fs where replace' c @@ -338,8 +387,8 @@ mkStaticFilesList fp fs makeHash = do | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c | otherwise = '_' - mkRoute f = do - let name' = intercalate "_" $ map (map replace') f + mkRoute (alias, f) = do + let name' = intercalate "_" $ map (map replace') alias routeName = mkName $ case () of () From 274b5445a1ff1884fcb303c80e2a7bf2434ce9d5 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Wed, 7 Jun 2017 20:11:01 +0900 Subject: [PATCH 062/124] Code review fixes for #1404 --- yesod-static/ChangeLog.md | 5 +++++ yesod-static/Yesod/Static.hs | 12 +++++++++++- yesod-static/yesod-static.cabal | 2 +- 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/yesod-static/ChangeLog.md b/yesod-static/ChangeLog.md index 7d5c9d26..7afd4396 100644 --- a/yesod-static/ChangeLog.md +++ b/yesod-static/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.5.3 + +* Add `staticFilesMap` function +* Add `staticFilesMergeMap` function + ## 1.5.2 * Fix test case for CRLF line endings diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 9454e681..4d8d368e 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -276,8 +276,10 @@ staticFilesList dir fs = publicFiles :: FilePath -> Q [Dec] publicFiles dir = mkStaticFiles' dir False --- | Similar to 'staticFilesList', but takes a manifest mapping +-- | Similar to 'staticFilesList', but takes a mapping of -- unmunged names to fingerprinted file names. +-- +-- @since 1.5.3 staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True where @@ -289,6 +291,11 @@ staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True let (a, b) = break (== '/') x in a : split (drop 1 b) +-- | Similar to 'staticFilesMergeMap', but also generates identifiers +-- for all files in the specified directory that don't have a +-- fingerprinted version. +-- +-- @since 1.5.3 staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] staticFilesMergeMap fp m = do fs <- qRunIO $ getFileListPieces fp @@ -305,6 +312,9 @@ staticFilesMergeMap fp m = do split x = let (a, b) = break (== '/') x in a : split (drop 1 b) + -- We want to keep mappings for all files that are pre-fingerprinted, + -- so this function checks against all of the existing fingerprinted files and + -- only inserts a new mapping if it's not a fingerprinted file. checkedInsert :: M.Map FilePath FilePath -- inverted dictionary -> M.Map FilePath FilePath -- accumulating state diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 297cc452..9fe49537 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.5.2 +version: 1.5.3 license: MIT license-file: LICENSE author: Michael Snoyman From ee9ef1eac58f31f408864f2ca044eba33a4804e5 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Wed, 14 Jun 2017 13:40:44 -0400 Subject: [PATCH 063/124] add clickOn function (closes #1406) --- yesod-test/ChangeLog.md | 4 +++ yesod-test/Yesod/Test.hs | 11 ++++++++ yesod-test/Yesod/Test/TransversingCSS.hs | 36 +++++++++++++++++++----- yesod-test/test/main.hs | 12 ++++++++ yesod-test/yesod-test.cabal | 2 +- 5 files changed, 57 insertions(+), 8 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 0245581e..81fbda95 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.7 + +* Add clickOn + ## 1.5.6 * Add assertNotEq. diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 79a62df5..9dca90f6 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -62,6 +62,7 @@ module Yesod.Test , setRequestBody , RequestBuilder , setUrl + , clickOn -- *** Adding fields by label -- | Yesod can auto generate field names, so you are never sure what @@ -830,6 +831,16 @@ setUrl url' = do , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } +clickOn :: Yesod site => Query -> YesodExample site () +clickOn query = do + withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> + case findAttributeBySelector (simpleBody res) query "href" of + Left err -> failure $ query <> " did not parse: " <> T.pack (show err) + Right [[match]] -> get match + Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches) + + + -- | Simple way to set HTTP request body -- -- ==== __ Examples__ diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 658f30a0..bcf555a6 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -10,16 +10,16 @@ and it returns a list of the HTML fragments that matched the given query. Only a subset of the CSS spec is currently supported: * By tag name: /table td a/ - + * By class names: /.container .content/ * By Id: /#oneId/ * By attribute: /[hasIt]/, /[exact=match]/, /[contains*=text]/, /[starts^=with]/, /[ends$=with]/ - + * Union: /a, span, p/ - - * Immediate children: /div > p/ + + * Immediate children: /div > p/ * Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/ @@ -27,6 +27,7 @@ Only a subset of the CSS spec is currently supported: module Yesod.Test.TransversingCSS ( findBySelector, + findAttributeBySelector, HtmlLBS, Query, -- * For HXT hackers @@ -58,9 +59,30 @@ type HtmlLBS = L.ByteString -- -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String] -findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x) - Control.Applicative.<$> (Right $ fromDocument $ HD.parseLBS html) - Control.Applicative.<*> parseQuery query +findBySelector html query = + map (renderHtml . toHtml . node) <$> findCursorsBySelector html query + +-- | Perform a css 'Query' on 'Html'. Returns Either +-- +-- * Left: Query parse error. +-- +-- * Right: List of matching Cursors +findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor] +findCursorsBySelector html query = + runQuery (fromDocument $ HD.parseLBS html) + <$> parseQuery query + +-- | Perform a css 'Query' on 'Html'. Returns Either +-- +-- * Left: Query parse error. +-- +-- * Right: List of matching Cursors +-- +-- Since 1.5.7 +findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] +findAttributeBySelector html query attr = + map (laxAttribute attr) <$> findCursorsBySelector html query + -- Run a compiled query on Html, returning a list of matching Html fragments. runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor] diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index ff2cca7c..705e3532 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -34,6 +34,7 @@ import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) +import Control.Exception.Lifted(SomeException, try) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -169,6 +170,15 @@ main = hspec $ do addToken_ "body" statusIs 200 bodyEquals "12345" + yit "can follow a link via clickOn" $ do + get ("/htmlWithLink" :: Text) + clickOn "a#thelink" + statusIs 200 + + get ("/htmlWithLink" :: Text) + (bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink") + assertEq "bad link" (isLeft bad) True + ydescribe "utf8 paths" $ do yit "from path" $ do @@ -326,6 +336,8 @@ app = liteApp $ do onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon

" :: Text) + onStatic "htmlWithLink" $ dispatchTo $ + return ("A linkLink!" :: Text) onStatic "labels" $ dispatchTo $ return ("" :: Text) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index cd1dddc7..8e834f10 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.5.6 +version: 1.5.7 license: MIT license-file: LICENSE author: Nubis From 2a112b551688048eb9ebfbf8039564631742969f Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 15 Jun 2017 12:17:49 -0400 Subject: [PATCH 064/124] -Werror fixes --- yesod-test/Yesod/Test/TransversingCSS.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index bcf555a6..806fb285 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -42,7 +42,6 @@ where import Yesod.Test.CssQuery import qualified Data.Text as T -import Control.Applicative ((<$>), (<*>)) import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L @@ -78,7 +77,7 @@ findCursorsBySelector html query = -- -- * Right: List of matching Cursors -- --- Since 1.5.7 +-- @since 1.5.7 findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] findAttributeBySelector html query attr = map (laxAttribute attr) <$> findCursorsBySelector html query From 1bc30deee7d8d7c2a0d4e9d3a4b684ba0955da68 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 15 Jun 2017 13:30:58 -0400 Subject: [PATCH 065/124] import Control.Applicative for 7.8.4 --- yesod-test/Yesod/Test/TransversingCSS.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 806fb285..7ef7b6fc 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -42,6 +42,7 @@ where import Yesod.Test.CssQuery import qualified Data.Text as T +import qualified Control.Applicative import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L @@ -59,7 +60,7 @@ type HtmlLBS = L.ByteString -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String] findBySelector html query = - map (renderHtml . toHtml . node) <$> findCursorsBySelector html query + map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query -- | Perform a css 'Query' on 'Html'. Returns Either -- @@ -69,7 +70,7 @@ findBySelector html query = findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor] findCursorsBySelector html query = runQuery (fromDocument $ HD.parseLBS html) - <$> parseQuery query + Control.Applicative.<$> parseQuery query -- | Perform a css 'Query' on 'Html'. Returns Either -- @@ -80,7 +81,7 @@ findCursorsBySelector html query = -- @since 1.5.7 findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] findAttributeBySelector html query attr = - map (laxAttribute attr) <$> findCursorsBySelector html query + map (laxAttribute attr) Control.Applicative.<$> findCursorsBySelector html query -- Run a compiled query on Html, returning a list of matching Html fragments. From 7cd37db7c66357717b1c2630d191a3ca8c2cba59 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 15 Jun 2017 15:46:25 -0400 Subject: [PATCH 066/124] address review comments --- yesod-test/ChangeLog.md | 3 ++- yesod-test/Yesod/Test.hs | 7 +++++++ yesod-test/test/main.hs | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 81fbda95..2c1330d4 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,6 +1,7 @@ ## 1.5.7 -* Add clickOn +* Add clickOn. +[#1408](https://github.com/yesodweb/yesod/pull/1408) ## 1.5.6 diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 9dca90f6..37c7a10d 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -831,6 +831,13 @@ setUrl url' = do , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } + +-- | Click on a link defined by a CSS query +-- +-- ==== __ Examples__ +-- +-- > get "/foobar" +-- > clickOn "a#idofthelink" clickOn :: Yesod site => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 705e3532..0b2fe611 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -174,6 +174,7 @@ main = hspec $ do get ("/htmlWithLink" :: Text) clickOn "a#thelink" statusIs 200 + bodyEquals "Hello

Hello World

Hello Moon

" get ("/htmlWithLink" :: Text) (bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink") From c40d39dc5a7408dc958e86b4b12bc9a1e7c5675b Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Wed, 21 Jun 2017 15:12:03 -0400 Subject: [PATCH 067/124] one more since --- yesod-test/Yesod/Test.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 37c7a10d..6ef3c684 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -838,6 +838,8 @@ setUrl url' = do -- -- > get "/foobar" -- > clickOn "a#idofthelink" +-- +-- @since 1.5.7 clickOn :: Yesod site => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> From d5eb1ce0262767d2cd5c70f2eb0823d98ae38288 Mon Sep 17 00:00:00 2001 From: ncaq Date: Thu, 22 Jun 2017 10:05:39 +0900 Subject: [PATCH 068/124] fixed: yesod-form: textareaField: writeHtmlEscapedChar: convert "\r\n" to "
" --- yesod-form/Yesod/Form/Fields.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 8833b2fc..5fe98d77 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -226,6 +226,7 @@ instance ToHtml Textarea where . unTextarea where -- Taken from blaze-builder and modified with newline handling. + writeHtmlEscapedChar '\r' = mempty writeHtmlEscapedChar '\n' = writeByteString "
" writeHtmlEscapedChar c = B.writeHtmlEscapedChar c From 33471cbb2f57ab0b1a8fedcbb4c5cf1fafd61d90 Mon Sep 17 00:00:00 2001 From: ncaq Date: Thu, 22 Jun 2017 16:32:50 +0900 Subject: [PATCH 069/124] add changelog and version number --- yesod-form/ChangeLog.md | 4 ++++ yesod-form/yesod-form.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 3fa52a16..f1370845 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.13 + +* Fixed `textareaField` `writeHtmlEscapedChar` trim "\r" + ## 1.4.12 * Password field does not remember its previous value diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 617ada59..177653d9 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.12 +version: 1.4.13 license: MIT license-file: LICENSE author: Michael Snoyman From e19d220f61649ca39547f5e1880bc3d110d9f0c1 Mon Sep 17 00:00:00 2001 From: ncaq Date: Fri, 23 Jun 2017 08:54:36 +0900 Subject: [PATCH 070/124] fixed: import Data.Monoid for old ghc --- yesod-form/Yesod/Form/Fields.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 5fe98d77..a8a537f0 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -106,6 +106,10 @@ import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, import Yesod.Persist.Core +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage From ec85ef735c9c350c5da4af4f1f1f4f9227106468 Mon Sep 17 00:00:00 2001 From: Josh Berman Date: Mon, 3 Jul 2017 06:44:25 -0400 Subject: [PATCH 071/124] Work with TH from GHC 8.2.1-rc2 --- yesod-core/Yesod/Routes/TH/RenderRoute.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/Yesod/Routes/TH/RenderRoute.hs index 594c4617..5177ef20 100644 --- a/yesod-core/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/Yesod/Routes/TH/RenderRoute.hs @@ -160,7 +160,7 @@ mkRenderRouteInstance' cxt typ ress = do (cons, decs) <- mkRouteCons ress #if MIN_VERSION_template_haskell(2,12,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) - let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) + let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) #elif MIN_VERSION_template_haskell(2,11,0) did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT (clazzes False) let sds = fmap (\t -> StandaloneDerivD cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) From 051339f3dcaca17844b923fe0b83ea46efbd0fc0 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:05:57 +0530 Subject: [PATCH 072/124] Add test code for HTTP headers properties --- yesod-core/test/YesodCoreTest/Header.hs | 62 +++++++++++++++++++++++++ 1 file changed, 62 insertions(+) create mode 100644 yesod-core/test/YesodCoreTest/Header.hs diff --git a/yesod-core/test/YesodCoreTest/Header.hs b/yesod-core/test/YesodCoreTest/Header.hs new file mode 100644 index 00000000..4a9f11dc --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Header.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, + TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} + +module YesodCoreTest.Header + ( headerTest + , Widget + , resourcesApp + ) where + +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as Map +import Data.Text (Text) +import Network.HTTP.Types (decodePathSegments, status200) +import Network.Wai +import Network.Wai.Test +import Test.Hspec +import Yesod.Core +import Yesod.Core.Handler + +data App = + App + +mkYesod + "App" + [parseRoutes| +/header1 Header1R GET +/header2 Header2R GET +|] + +instance Yesod App + +getHeader1R :: Handler RepPlain +getHeader1R = do + addHeader "hello" "world" + return $ RepPlain $ toContent ("header test" :: Text) + +getHeader2R :: Handler RepPlain +getHeader2R = do + addHeader "hello" "world" + replaceOrAddHeader "hello" "sibi" + return $ RepPlain $ toContent ("header test" :: Text) + +runner :: Session () -> IO () +runner f = toWaiApp App >>= runSession f + +addHeaderTest :: IO () +addHeaderTest = + runner $ do + res <- request defaultRequest {pathInfo = decodePathSegments "/header1"} + assertHeader "hello" "world" res + +multipleHeaderTest :: IO () +multipleHeaderTest = + runner $ do + res <- request defaultRequest {pathInfo = decodePathSegments "/header2"} + assertHeader "hello" "sibi" res + +headerTest :: Spec +headerTest = + describe "Test.Header" $ do + it "addHeader" addHeaderTest + it "multiple header" multipleHeaderTest From 301f4bc63027530a78eddbae9d27c153333cd3c4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:07:13 +0530 Subject: [PATCH 073/124] Expose YesodCoreTest.Header module --- yesod-core/yesod-core.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index ae9569f3..7702a336 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -150,6 +150,7 @@ test-suite tests YesodCoreTest.Auth YesodCoreTest.Cache YesodCoreTest.CleanPath + YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling YesodCoreTest.Exceptions From 839b56b032c388a92b0f07b80c07b13de7a8701c Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:10:54 +0530 Subject: [PATCH 074/124] Implement replaceOrAddHeader function --- yesod-core/Yesod/Core/Handler.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 0afced9a..4b580cc9 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -114,6 +114,7 @@ module Yesod.Core.Handler , deleteCookie , addHeader , setHeader + , replaceOrAddHeader , setLanguage -- ** Content caching and expiration , cacheSeconds @@ -787,6 +788,23 @@ setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} +replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () +replaceOrAddHeader a b = + let header = Header (encodeUtf8 a) (encodeUtf8 b) + in modify $ \g -> g {ghsHeaders = replaceHeader header (ghsHeaders g)} + where + sameHeaderName :: Header -> Header -> Bool + sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 + sameHeaderName _ _ = False + + replaceHeader :: Header -> Endo [Header] -> Endo [Header] + replaceHeader header endo = + let allHeaders :: [Header] = appEndo endo [] + in Endo + (\y -> + (header : y) ++ + filter (\x -> not (sameHeaderName x header)) allHeaders) + -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. cacheSeconds :: MonadHandler m => Int -> m () From 4e0b084df2119a90574b4e4a970835c696ead5ed Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:16:47 +0530 Subject: [PATCH 075/124] Enable test in YesodCoreTest --- yesod-core/test/YesodCoreTest.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 7c0db6fa..ebe1eef6 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -6,6 +6,7 @@ import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media import YesodCoreTest.Links +import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling @@ -27,6 +28,7 @@ import Test.Hspec specs :: Spec specs = do + headerTest cleanPathTest exceptionsTest widgetTest From 3cec499c85c297cf6452d75d9286047028f2c5b8 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:17:03 +0530 Subject: [PATCH 076/124] ScopedTypeVariables is also needed --- yesod-core/Yesod/Core/Handler.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 4b580cc9..9e6c1333 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- -- Module : Yesod.Handler From a31c27089322fb683088cc81ec2f32acd9ad32a8 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:24:57 +0530 Subject: [PATCH 077/124] Update Changelog and do verion bump of the package --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 3904cfa9..1b5e4882 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.36 + +* Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416) + ## 1.4.35 * Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 7702a336..e5c8bba2 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.35 +version: 1.4.36 license: MIT license-file: LICENSE author: Michael Snoyman From 8416bb65695a8e5581440275dd76ac17dc08f1a3 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 11:27:03 +0530 Subject: [PATCH 078/124] Add Haddock documentation for the added function --- yesod-core/Yesod/Core/Handler.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 9e6c1333..70f6d1e4 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -789,6 +789,13 @@ setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-} +-- | Replace an existing header with a new value or add a new header +-- if not present. +-- +-- Note that, while the data type used here is 'Text', you must provide only +-- ASCII value to be HTTP compliant. +-- +-- @since 1.4.36 replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () replaceOrAddHeader a b = let header = Header (encodeUtf8 a) (encodeUtf8 b) From 18951b0de7fdc4e99559ba75b34fc330a1eebd56 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 12:42:30 +0530 Subject: [PATCH 079/124] Update the replace logic to obey proper ordering --- yesod-core/Yesod/Core/Handler.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 70f6d1e4..e98fee17 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -809,9 +809,8 @@ replaceOrAddHeader a b = replaceHeader header endo = let allHeaders :: [Header] = appEndo endo [] in Endo - (\y -> - (header : y) ++ - filter (\x -> not (sameHeaderName x header)) allHeaders) + (\rest -> + header : filter (\x -> not (sameHeaderName x header)) allHeaders ++ rest) -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. From f3ed12ed81ecf9c13e0d3c05d7e990834835a56b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 12:43:16 +0530 Subject: [PATCH 080/124] Add additional test to make sure that header value is not lost --- yesod-core/test/YesodCoreTest/Header.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/yesod-core/test/YesodCoreTest/Header.hs b/yesod-core/test/YesodCoreTest/Header.hs index 4a9f11dc..aaf74a3a 100644 --- a/yesod-core/test/YesodCoreTest/Header.hs +++ b/yesod-core/test/YesodCoreTest/Header.hs @@ -25,6 +25,7 @@ mkYesod [parseRoutes| /header1 Header1R GET /header2 Header2R GET +/header3 Header3R GET |] instance Yesod App @@ -40,6 +41,14 @@ getHeader2R = do replaceOrAddHeader "hello" "sibi" return $ RepPlain $ toContent ("header test" :: Text) +getHeader3R :: Handler RepPlain +getHeader3R = do + addHeader "hello" "world" + addHeader "michael" "snoyman" + addHeader "yesod" "framework" + replaceOrAddHeader "yesod" "book" + return $ RepPlain $ toContent ("header test" :: Text) + runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f @@ -55,8 +64,17 @@ multipleHeaderTest = res <- request defaultRequest {pathInfo = decodePathSegments "/header2"} assertHeader "hello" "sibi" res +header3Test :: IO () +header3Test = do + runner $ do + res <- request defaultRequest { pathInfo = decodePathSegments "/header3"} + assertHeader "hello" "world" res + assertHeader "michael" "snoyman" res + assertHeader "yesod" "book" res + headerTest :: Spec headerTest = describe "Test.Header" $ do it "addHeader" addHeaderTest it "multiple header" multipleHeaderTest + it "persist headers" header3Test From 89fc6c46e2b558783b642752352ff55a0965e1f4 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Thu, 13 Jul 2017 16:29:08 +0530 Subject: [PATCH 081/124] Fix ordering logic in replaceHeader function --- yesod-core/Yesod/Core/Handler.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index e98fee17..1bda5fc6 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -798,19 +798,30 @@ setHeader = addHeader -- @since 1.4.36 replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () replaceOrAddHeader a b = - let header = Header (encodeUtf8 a) (encodeUtf8 b) - in modify $ \g -> g {ghsHeaders = replaceHeader header (ghsHeaders g)} + modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} where + repHeader = Header (encodeUtf8 a) (encodeUtf8 b) + sameHeaderName :: Header -> Header -> Bool sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 sameHeaderName _ _ = False - replaceHeader :: Header -> Endo [Header] -> Endo [Header] - replaceHeader header endo = + replaceIndividualHeader :: [Header] -> [Header] + replaceIndividualHeader [] = [repHeader] + replaceIndividualHeader xs = aux xs [] + where + aux [] acc = acc ++ [repHeader] + aux (x:xs') acc = + if sameHeaderName repHeader x + then acc ++ + [repHeader] ++ + (filter (\header -> not (sameHeaderName header repHeader)) xs') + else aux xs' (acc ++ [x]) + + replaceHeader :: Endo [Header] -> Endo [Header] + replaceHeader endo = let allHeaders :: [Header] = appEndo endo [] - in Endo - (\rest -> - header : filter (\x -> not (sameHeaderName x header)) allHeaders ++ rest) + in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest) -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds. From 617591aa4e04a3f2745c8e3cb8beacd917b4d39b Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 14 Jul 2017 13:44:21 +0530 Subject: [PATCH 082/124] Do case insensitive equality on header name --- yesod-core/Yesod/Core/Handler.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 1bda5fc6..3b1b50ed 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -208,7 +208,7 @@ import Control.Monad.Trans.Class (lift) import Data.Aeson (ToJSON(..)) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import Text.Blaze.Html.Renderer.Utf8 (renderHtml) @@ -803,7 +803,7 @@ replaceOrAddHeader a b = repHeader = Header (encodeUtf8 a) (encodeUtf8 b) sameHeaderName :: Header -> Header -> Bool - sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 + sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2) sameHeaderName _ _ = False replaceIndividualHeader :: [Header] -> [Header] From a58a4d88cd8a68d1cfa20d63772f03e572edb734 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Sebasti=C3=A1n=20Estrella?= Date: Tue, 18 Jul 2017 23:01:04 -0500 Subject: [PATCH 083/124] Add implicit param HasCallStack to assertions --- yesod-test/ChangeLog.md | 4 ++++ yesod-test/Yesod/Test.hs | 40 ++++++++++++++++++++++++------------- yesod-test/yesod-test.cabal | 2 +- 3 files changed, 31 insertions(+), 15 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 2c1330d4..41acb0c8 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.8 +* Added implicit parameter HasCallStack to assertions. +[#1421](https://github.com/yesodweb/yesod/pull/1421) + ## 1.5.7 * Add clickOn. diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 6ef3c684..06e1fa67 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -4,6 +4,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} {-| Yesod.Test is a pragmatic framework for testing web applications built @@ -150,6 +152,16 @@ import Data.Time.Clock (getCurrentTime) import Control.Applicative ((<$>)) import Text.Show.Pretty (ppShow) import Data.Monoid (mempty) +#if MIN_VERSION_base(4,9,0) +import GHC.Stack (HasCallStack) +#elif MIN_VERSION_base(4,8,1) +import GHC.Stack (CallStack) +type HasCallStack = (?callStack :: CallStack) +#else +import GHC.Exts (Constraint) +type HasCallStack = (() :: Constraint) +#endif + -- | The state used in a single test case defined using 'yit' -- @@ -330,7 +342,7 @@ htmlQuery = htmlQuery' yedResponse [] -- In case they are not equal, error mesasge includes the two values. -- -- @since 1.5.2 -assertEq :: (Eq a, Show a) => String -> a -> a -> YesodExample site () +assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site () assertEq m a b = liftIO $ HUnit.assertBool msg (a == b) where msg = "Assertion: " ++ m ++ "\n" ++ @@ -342,24 +354,24 @@ assertEq m a b = -- In case they are equal, error mesasge includes the values. -- -- @since 1.5.6 -assertNotEq :: (Eq a, Show a) => String -> a -> a -> YesodExample site () +assertNotEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site () assertNotEq m a b = liftIO $ HUnit.assertBool msg (a /= b) where msg = "Assertion: " ++ m ++ "\n" ++ "Both arguments: " ++ ppShow a ++ "\n" {-# DEPRECATED assertEqual "Use assertEq instead" #-} -assertEqual :: (Eq a) => String -> a -> a -> YesodExample site () +assertEqual :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site () assertEqual = assertEqualNoShow -- | Asserts that the two given values are equal. -- -- @since 1.5.2 -assertEqualNoShow :: (Eq a) => String -> a -> a -> YesodExample site () +assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample site () assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b) -- | Assert the last response status is as expected. -statusIs :: Int -> YesodExample site () +statusIs :: HasCallStack => Int -> YesodExample site () statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat [ "Expected status was ", show number @@ -367,7 +379,7 @@ statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> ] -- | Assert the given header key/value pair was returned. -assertHeader :: CI BS8.ByteString -> BS8.ByteString -> YesodExample site () +assertHeader :: HasCallStack => CI BS8.ByteString -> BS8.ByteString -> YesodExample site () assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> failure $ T.pack $ concat @@ -387,7 +399,7 @@ assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> ] -- | Assert the given header was not included in the response. -assertNoHeader :: CI BS8.ByteString -> YesodExample site () +assertNoHeader :: HasCallStack => CI BS8.ByteString -> YesodExample site () assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> return () @@ -400,14 +412,14 @@ assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> -- | Assert the last response is exactly equal to the given text. This is -- useful for testing API responses. -bodyEquals :: String -> YesodExample site () +bodyEquals :: HasCallStack => String -> YesodExample site () bodyEquals text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $ (simpleBody res) == encodeUtf8 (TL.pack text) -- | Assert the last response has the given text. The check is performed using the response -- body in full text form. -bodyContains :: String -> YesodExample site () +bodyContains :: HasCallStack => String -> YesodExample site () bodyContains text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $ (simpleBody res) `contains` text @@ -415,7 +427,7 @@ bodyContains text = withResponse $ \ res -> -- | Assert the last response doesn't have the given text. The check is performed using the response -- body in full text form. -- @since 1.5.3 -bodyNotContains :: String -> YesodExample site () +bodyNotContains :: HasCallStack => String -> YesodExample site () bodyNotContains text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $ not $ contains (simpleBody res) text @@ -425,7 +437,7 @@ contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a) -- | Queries the HTML using a CSS selector, and all matched elements must contain -- the given string. -htmlAllContain :: Query -> String -> YesodExample site () +htmlAllContain :: HasCallStack => Query -> String -> YesodExample site () htmlAllContain query search = do matches <- htmlQuery query case matches of @@ -437,7 +449,7 @@ htmlAllContain query search = do -- element contains the given string. -- -- Since 0.3.5 -htmlAnyContain :: Query -> String -> YesodExample site () +htmlAnyContain :: HasCallStack => Query -> String -> YesodExample site () htmlAnyContain query search = do matches <- htmlQuery query case matches of @@ -450,7 +462,7 @@ htmlAnyContain query search = do -- inverse of htmlAnyContains). -- -- Since 1.2.2 -htmlNoneContain :: Query -> String -> YesodExample site () +htmlNoneContain :: HasCallStack => Query -> String -> YesodExample site () htmlNoneContain query search = do matches <- htmlQuery query case DL.filter (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) of @@ -460,7 +472,7 @@ htmlNoneContain query search = do -- | Performs a CSS query on the last response and asserts the matched elements -- are as many as expected. -htmlCount :: Query -> Int -> YesodExample site () +htmlCount :: HasCallStack => Query -> Int -> YesodExample site () htmlCount query count = do matches <- fmap DL.length $ htmlQuery query liftIO $ flip HUnit.assertBool (matches == count) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 8e834f10..528ee130 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.5.7 +version: 1.5.8 license: MIT license-file: LICENSE author: Nubis From 06ca675bb6783b740f84082d3d965ebfa6bf0f41 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 20 Jul 2017 13:58:15 +0300 Subject: [PATCH 084/124] Version bump --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 3904cfa9..9673ee14 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.35.1 + +* TH fix for GHC 8.2 + ## 1.4.35 * Contexts can be included in generated TH instances. [1365](https://github.com/yesodweb/yesod/issues/1365) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index ae9569f3..1f058c5d 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.35 +version: 1.4.35.1 license: MIT license-file: LICENSE author: Michael Snoyman From 087f4d20923e822529f2a21673d434207f5ce9f5 Mon Sep 17 00:00:00 2001 From: Elliott Sales de Andrade Date: Sat, 22 Jul 2017 22:58:23 -0400 Subject: [PATCH 085/124] Convert yesod-static to cryptonite. --- stack.yaml | 1 + yesod-static/Yesod/Static.hs | 6 +++--- yesod-static/yesod-static.cabal | 10 ++++++---- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/stack.yaml b/stack.yaml index 57a79fa9..91401c44 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,6 +24,7 @@ extra-deps: - persistent-sqlite-2.5 - cookie-0.4.2 - cryptonite-0.23 +- cryptonite-conduit-0.2.0 - foundation-0.0.9 - memory-0.14.5 - hfsevents-0.1.6 diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 4d8d368e..636bd333 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -81,7 +81,7 @@ import Crypto.Hash (MD5, Digest) import Control.Monad.Catch (MonadThrow) import Control.Monad.Trans.State -import qualified Data.Byteable as Byteable +import qualified Data.ByteArray as ByteArray import qualified Data.ByteString.Base64 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -420,7 +420,7 @@ mkStaticFilesList' fp fs makeHash = do base64md5File :: FilePath -> IO String base64md5File = fmap (base64 . encode) . hashFile - where encode d = Byteable.toBytes (d :: Digest MD5) + where encode d = ByteArray.convert (d :: Digest MD5) base64md5 :: L.ByteString -> String base64md5 lbs = @@ -428,7 +428,7 @@ base64md5 lbs = $ runIdentity $ sourceList (L.toChunks lbs) $$ sinkHash where - encode d = Byteable.toBytes (d :: Digest MD5) + encode d = ByteArray.convert (d :: Digest MD5) base64 :: S.ByteString -> String base64 = map tr diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 9fe49537..ff266c0e 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -44,8 +44,9 @@ library , unix-compat >= 0.2 , conduit >= 0.5 , conduit-extra - , cryptohash-conduit >= 0.1 - , cryptohash >= 0.11 + , cryptonite-conduit >= 0.1 + , cryptonite >= 0.11 + , memory , data-default , mime-types >= 0.1 , hjsmin @@ -112,8 +113,9 @@ test-suite tests , http-types , unix-compat , conduit - , cryptohash-conduit - , cryptohash + , cryptonite-conduit + , cryptonite + , memory , data-default , mime-types , hjsmin From 42112add3cd06f9a707dc31866b66c194729b976 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 07:27:14 +0300 Subject: [PATCH 086/124] Version bump --- yesod-static/ChangeLog.md | 4 ++++ yesod-static/yesod-static.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-static/ChangeLog.md b/yesod-static/ChangeLog.md index 7afd4396..fdb162a8 100644 --- a/yesod-static/ChangeLog.md +++ b/yesod-static/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.3.1 + +* Switch to cryptonite + ## 1.5.3 * Add `staticFilesMap` function diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index ff266c0e..2a9c8506 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.5.3 +version: 1.5.3.1 license: MIT license-file: LICENSE author: Michael Snoyman From fefe8e0219799730bd6ceb3923f0448317102dbd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 09:34:15 +0300 Subject: [PATCH 087/124] Attempt to get Travis building again --- .travis.yml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/.travis.yml b/.travis.yml index ee1a40b9..480d440f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -119,6 +119,8 @@ matrix: allow_failures: - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" + - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 + - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 before_install: # Using compiler above sets CC to an invalid value, so unset it @@ -171,9 +173,15 @@ script: # Build dependencies with -O0 as well echo "apply-ghc-options: everything" >> stack.yaml + # Avoid OOM for building Cabal + stack --install-ghc --no-terminal $ARGS build Cabal --fast + # Use slightly less intensive options on OS X due to Travis timeouts stack --install-ghc --no-terminal $ARGS test --fast else + # Avoid OOM for building Cabal + stack --install-ghc --no-terminal $ARGS build Cabal --fast + stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic fi ;; From 8e367bda3d53b6c4ae342fc2183ce7fb9c0707ac Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 10:31:51 +0300 Subject: [PATCH 088/124] Bump to LTS 8 --- .travis.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.travis.yml b/.travis.yml index 480d440f..01050e7f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -81,8 +81,8 @@ matrix: compiler: ": #stack 7.10.3" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-7" - compiler: ": #stack 8.0.1" + - env: BUILD=stack ARGS="--resolver lts-8" + compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} # Nightly builds are allowed to fail @@ -108,8 +108,8 @@ matrix: compiler: ": #stack 7.10.3 osx" os: osx - - env: BUILD=stack ARGS="--resolver lts-7" - compiler: ": #stack 8.0.1 osx" + - env: BUILD=stack ARGS="--resolver lts-8" + compiler: ": #stack 8.0.2 osx" os: osx - env: BUILD=stack ARGS="--resolver nightly" From 626719ce285d91386141902b48174fecf7bcb9f0 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 11:10:47 +0300 Subject: [PATCH 089/124] Fix some version issues --- stack.yaml | 4 ++-- yesod-auth-oauth/yesod-auth-oauth.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index 91401c44..74ce3c0c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-6.23 +resolver: lts-8.12 packages: - ./yesod-core - ./yesod-static @@ -16,7 +16,7 @@ packages: # Needed for LTS 2 extra-deps: -- wai-app-static-3.1.4.1 +- wai-app-static-3.1.6.1 - http-api-data-0.2 - yaml-0.8.17 - nonce-1.0.2 diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 34a5a1f6..c21ac9e1 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -21,7 +21,7 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 - build-depends: authenticate-oauth >= 1.5 && < 1.6 + build-depends: authenticate-oauth >= 1.5 && < 1.7 , bytestring >= 0.9.1.4 , yesod-core >= 1.4 && < 1.5 , yesod-auth >= 1.4 && < 1.5 From 4b34fe9c72c064699af13619153c04c4c8dab343 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 12:25:23 +0300 Subject: [PATCH 090/124] Fix deprecation warning for LTS 8 --- yesod-auth/Yesod/Auth/GoogleEmail2.hs | 4 ++++ yesod-core/Yesod/Core/Content.hs | 10 +++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index 57db613e..577e86a7 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -74,7 +74,11 @@ import Control.Monad.IO.Class (MonadIO) import qualified Crypto.Nonce as Nonce import Data.Aeson ((.:?)) import qualified Data.Aeson as A +#if MIN_VERSION_aeson(1,0,0) +import qualified Data.Aeson.Text as A +#else import qualified Data.Aeson.Encode as A +#endif import Data.Aeson.Parser (json') import Data.Aeson.Types (FromJSON (parseJSON), parseEither, parseMaybe, withObject, withText) diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs index faab94ce..1313a1ea 100644 --- a/yesod-core/Yesod/Core/Content.hs +++ b/yesod-core/Yesod/Core/Content.hs @@ -66,7 +66,8 @@ import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J -#if MIN_VERSION_aeson(0, 7, 0) +#if MIN_VERSION_aeson(1, 0, 0) +#elif MIN_VERSION_aeson(0, 7, 0) import Data.Aeson.Encode (encodeToTextBuilder) #else import Data.Aeson.Encode (fromValue) @@ -242,6 +243,11 @@ instance ToContent a => ToContent (DontFullyEvaluate a) where toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a instance ToContent J.Value where +#if MIN_VERSION_aeson(1, 0, 0) + toContent = flip ContentBuilder Nothing + . J.fromEncoding + . J.toEncoding +#else toContent = flip ContentBuilder Nothing . Blaze.fromLazyText . toLazyText @@ -251,6 +257,8 @@ instance ToContent J.Value where . fromValue #endif +#endif + #if MIN_VERSION_aeson(0, 11, 0) instance ToContent J.Encoding where toContent = flip ContentBuilder Nothing . J.fromEncoding From fff8f8ff5f5f05ebf0b69274cff17fb3a4e51a56 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 13:04:40 +0300 Subject: [PATCH 091/124] Reduce extra-deps, drop LTS 2 and 3 --- .travis.yml | 17 ----------------- stack.yaml | 32 -------------------------------- 2 files changed, 49 deletions(-) diff --git a/.travis.yml b/.travis.yml index 01050e7f..ab790d0b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -69,14 +69,6 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-2" - compiler: ": #stack 7.8.4" - addons: {apt: {packages: [libgmp-dev]}} - - - env: BUILD=stack ARGS="--resolver lts-3" - compiler: ": #stack 7.10.2" - addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-6" compiler: ": #stack 7.10.3" addons: {apt: {packages: [libgmp-dev]}} @@ -95,15 +87,6 @@ matrix: compiler: ": #stack default osx" os: osx - # Travis includes an OS X which is incompatible with GHC 7.8.4 - #- env: BUILD=stack ARGS="--resolver lts-2" - # compiler: ": #stack 7.8.4 osx" - # os: osx - - - env: BUILD=stack ARGS="--resolver lts-3" - compiler: ": #stack 7.10.2 osx" - os: osx - - env: BUILD=stack ARGS="--resolver lts-6" compiler: ": #stack 7.10.3 osx" os: osx diff --git a/stack.yaml b/stack.yaml index 74ce3c0c..213e9db3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,35 +13,3 @@ packages: - ./yesod - ./yesod-eventsource - ./yesod-websockets - -# Needed for LTS 2 -extra-deps: -- wai-app-static-3.1.6.1 -- http-api-data-0.2 -- yaml-0.8.17 -- nonce-1.0.2 -- persistent-2.5 -- persistent-sqlite-2.5 -- cookie-0.4.2 -- cryptonite-0.23 -- cryptonite-conduit-0.2.0 -- foundation-0.0.9 -- memory-0.14.5 -- hfsevents-0.1.6 -- x509-1.6.5 -- x509-store-1.6.2 -- x509-system-1.6.4 -- x509-validation-1.6.5 -- tls-1.3.8 -- Win32-notify-0.3.0.1 -- asn1-parse-0.9.4 -- asn1-types-0.3.2 -- connection-0.2.8 -- socks-0.5.5 - -- conduit-extra-1.1.14 -- streaming-commons-0.1.16 -- typed-process-0.1.0.0 -- say-0.1.0.0 -- safe-exceptions-0.1.4.0 -- blaze-markup-0.7.1.0 From 5b18bf0c09077019b67b4d6052fb3bccb16ddc7d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 16:28:58 +0300 Subject: [PATCH 092/124] Always use solver on Travis --- .travis.yml | 7 ++----- yesod-form/yesod-form.cabal | 2 +- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index ab790d0b..ee5e3d0b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -139,11 +139,8 @@ install: - if [ -f configure.ac ]; then autoreconf -i; fi - | set -ex - if [ "$ARGS" = "--resolver nightly" ] - then - stack --install-ghc $ARGS build cabal-install - stack --install-ghc $ARGS solver --update-config - fi + stack --install-ghc $ARGS build cabal-install + stack --install-ghc $ARGS solver --update-config set +ex script: diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 177653d9..7c8d05a1 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -24,7 +24,7 @@ library , yesod-persistent >= 1.4 && < 1.5 , time >= 1.1.4 , shakespeare >= 2.0 - , persistent + , persistent >= 2.5 , template-haskell , transformers >= 0.2.2 , data-default From ada76a96361584bce2de4fd091bc39eeeb8bb62a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 16:45:47 +0300 Subject: [PATCH 093/124] Revert "Always use solver on Travis" This reverts commit 5b18bf0c09077019b67b4d6052fb3bccb16ddc7d. --- .travis.yml | 7 +++++-- yesod-form/yesod-form.cabal | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index ee5e3d0b..ab790d0b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -139,8 +139,11 @@ install: - if [ -f configure.ac ]; then autoreconf -i; fi - | set -ex - stack --install-ghc $ARGS build cabal-install - stack --install-ghc $ARGS solver --update-config + if [ "$ARGS" = "--resolver nightly" ] + then + stack --install-ghc $ARGS build cabal-install + stack --install-ghc $ARGS solver --update-config + fi set +ex script: diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 7c8d05a1..177653d9 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -24,7 +24,7 @@ library , yesod-persistent >= 1.4 && < 1.5 , time >= 1.1.4 , shakespeare >= 2.0 - , persistent >= 2.5 + , persistent , template-haskell , transformers >= 0.2.2 , data-default From a17779b12d5561c8efe4feadf99b2a412314211a Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 23 Jul 2017 16:53:12 +0300 Subject: [PATCH 094/124] Fix persistent < 2.5 code --- 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 a8a537f0..05b4574d 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -76,7 +76,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..)) #if MIN_VERSION_persistent(2,5,0) import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend, PersistQueryRead) #else -import Database.Persist (Entity (..), SqlType (SqlString)) +import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend) #endif import Text.HTML.SanitizeXSS (sanitizeBalance) import Control.Monad (when, unless) From 19ff5c2006469ec82206bc6c4b7ac62f6ec2cb23 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Fri, 28 Jul 2017 16:58:11 +0530 Subject: [PATCH 095/124] Fix warning in test code --- yesod-core/test/YesodCoreTest/Header.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/yesod-core/test/YesodCoreTest/Header.hs b/yesod-core/test/YesodCoreTest/Header.hs index aaf74a3a..75d038c8 100644 --- a/yesod-core/test/YesodCoreTest/Header.hs +++ b/yesod-core/test/YesodCoreTest/Header.hs @@ -7,15 +7,12 @@ module YesodCoreTest.Header , resourcesApp ) where -import Data.ByteString.Lazy (ByteString) -import qualified Data.Map as Map import Data.Text (Text) -import Network.HTTP.Types (decodePathSegments, status200) +import Network.HTTP.Types (decodePathSegments) import Network.Wai import Network.Wai.Test import Test.Hspec import Yesod.Core -import Yesod.Core.Handler data App = App @@ -67,11 +64,11 @@ multipleHeaderTest = header3Test :: IO () header3Test = do runner $ do - res <- request defaultRequest { pathInfo = decodePathSegments "/header3"} + res <- request defaultRequest {pathInfo = decodePathSegments "/header3"} assertHeader "hello" "world" res assertHeader "michael" "snoyman" res assertHeader "yesod" "book" res - + headerTest :: Spec headerTest = describe "Test.Header" $ do From a4eee3093040f5421ae19a41b9fb7490c1f1b2d3 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 31 Jul 2017 09:54:56 +0300 Subject: [PATCH 096/124] Cabal 2.0 support --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/Devel.hs | 17 ++++++++++++++++- yesod-bin/yesod-bin.cabal | 2 +- 3 files changed, 21 insertions(+), 2 deletions(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 2ffb0332..e80cf419 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2.4 + +* Cabal 2.0 support + ## 1.5.2.3 * Fix race condition which leads dev server to stay in compilation mode. [#1380](https://github.com/yesodweb/yesod/issues/1380) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 22e6a515..07899f7d 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -255,7 +255,11 @@ getAvailableFlags :: D.GenericPackageDescription -> Set.Set String getAvailableFlags = Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags where +#if MIN_VERSION_Cabal(2, 0, 0) + unFlagName = D.unFlagName +#else unFlagName (D.FlagName fn) = fn +#endif -- | This is the main entry point. Run the devel server. devel :: DevelOpts -- ^ command line options @@ -276,9 +280,20 @@ devel opts passThroughArgs = do #else cabal <- D.findPackageDesc "." #endif + +#if MIN_VERSION_Cabal(1, 20, 0) + gpd <- D.readGenericPackageDescription D.normal cabal +#else gpd <- D.readPackageDescription D.normal cabal +#endif + let pd = D.packageDescription gpd - D.PackageIdentifier (D.PackageName packageName) _version = D.package pd + D.PackageIdentifier packageNameWrapped _version = D.package pd +#if MIN_VERSION_Cabal(2, 0, 0) + packageName = D.unPackageName packageNameWrapped +#else + D.PackageName packageName = packageNameWrapped +#endif -- Which file contains the code to run develHsPath <- checkDevelFile diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 67d6392f..068e2ff9 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2.3 +version: 1.5.2.4 license: MIT license-file: LICENSE author: Michael Snoyman From 3b8ca1d3d1ed3978799bf52db62a7b5175d261a6 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 4 Aug 2017 08:12:55 +0300 Subject: [PATCH 097/124] Bad CPP --- yesod-bin/Devel.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 07899f7d..18de9347 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -281,7 +281,7 @@ devel opts passThroughArgs = do cabal <- D.findPackageDesc "." #endif -#if MIN_VERSION_Cabal(1, 20, 0) +#if MIN_VERSION_Cabal(2, 0, 0) gpd <- D.readGenericPackageDescription D.normal cabal #else gpd <- D.readPackageDescription D.normal cabal From 854f82305901a138b04c4bd8f56177ba8cf03f95 Mon Sep 17 00:00:00 2001 From: GyuYong Jung Date: Tue, 18 Jul 2017 22:46:29 +0900 Subject: [PATCH 098/124] add `src/` to file path if Haskell source files in `src` Fixes #1413 --- yesod-bin/AddHandler.hs | 28 +++++++++++++++++++++------- 1 file changed, 21 insertions(+), 7 deletions(-) diff --git a/yesod-bin/AddHandler.hs b/yesod-bin/AddHandler.hs index 0721f94e..e925661f 100644 --- a/yesod-bin/AddHandler.hs +++ b/yesod-bin/AddHandler.hs @@ -5,9 +5,13 @@ import Prelude hiding (readFile) import System.IO (hFlush, stdout) import Data.Char (isLower, toLower, isSpace) import Data.List (isPrefixOf, isSuffixOf, stripPrefix) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as TIO +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) +import Distribution.Verbosity (normal) import System.Directory (getDirectoryContents, doesFileExist) import Control.Monad (unless) @@ -31,7 +35,7 @@ cmdLineArgsError = "You have to specify a route name if you want to add handler addHandler :: Maybe String -> Maybe String -> [String] -> IO () addHandler (Just route) pat met = do cabal <- getCabal - checked <- checkRoute route + checked <- checkRoute route cabal let routePair = case checked of Left err@EmptyRoute -> (error . show) err Left err@RouteCaseError -> (error . show) err @@ -54,7 +58,7 @@ addHandlerInteractive = do putStr "Name of route (without trailing R): " hFlush stdout name <- getLine - checked <- checkRoute name + checked <- checkRoute name cabal case checked of Left err@EmptyRoute -> (error . show) err Left err@RouteCaseError -> print err >> routeInput @@ -75,7 +79,9 @@ addHandlerInteractive = do addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO () addHandlerFiles cabal (name, handlerFile) pattern methods = do - modify "Application.hs" $ fixApp name + src <- getSrcDir cabal + let applicationFile = concat [src, "/Application.hs"] + modify applicationFile $ fixApp name modify cabal $ fixCabal name modify "config/routes" $ fixRoutes name pattern methods writeFile handlerFile $ mkHandler name pattern methods @@ -94,15 +100,16 @@ getCabal = do [] -> error "No cabal file found" _ -> error "Too many cabal files found" -checkRoute :: String -> IO (Either RouteError (String, FilePath)) -checkRoute name = +checkRoute :: String -> FilePath -> IO (Either RouteError (String, FilePath)) +checkRoute name cabal = case name of [] -> return $ Left EmptyRoute c:_ | isLower c -> return $ Left RouteCaseError | otherwise -> do -- Check that the handler file doesn't already exist - let handlerFile = concat ["Handler/", name, ".hs"] + src <- getSrcDir cabal + let handlerFile = concat [src, "/Handler/", name, ".hs"] exists <- doesFileExist handlerFile if exists then (return . Left . RouteExists) handlerFile @@ -214,3 +221,10 @@ mkHandler name pattern methods = unlines uncapitalize :: String -> String uncapitalize (x:xs) = toLower x : xs uncapitalize "" = "" + +getSrcDir :: FilePath -> IO FilePath +getSrcDir cabal = do + pd <- flattenPackageDescription <$> readPackageDescription normal cabal + let buildInfo = allBuildInfo pd + srcDirs = concatMap hsSourceDirs buildInfo + return $ fromMaybe "." $ listToMaybe srcDirs From 896ee9c644c4b627b607f748b3ce08ceb8598ebe Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 4 Aug 2017 16:30:58 +0300 Subject: [PATCH 099/124] Version bump and close #1413 --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/yesod-bin.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index e80cf419..01023a30 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2.5 + +* Support for `add-handler` when modules are in `src/` directory [#1413](https://github.com/yesodweb/yesod/issues/1413) + ## 1.5.2.4 * Cabal 2.0 support diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 068e2ff9..6b05720b 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2.4 +version: 1.5.2.5 license: MIT license-file: LICENSE author: Michael Snoyman From e3041aa17bbc2fab35a7a9a09deb4460c2c82456 Mon Sep 17 00:00:00 2001 From: Daniel Campoverde Date: Tue, 8 Aug 2017 11:03:09 -0500 Subject: [PATCH 100/124] Fix auth messages Spanish translation --- yesod-auth/Yesod/Auth/Message.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index 52fd669d..e0827204 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -174,7 +174,7 @@ spanishMessage LoginOpenID = "Entrar utilizando OpenID" spanishMessage LoginGoogle = "Entrar utilizando Google" spanishMessage LoginYahoo = "Entrar utilizando Yahoo" spanishMessage Email = "Correo electrónico" -spanishMessage UserName = "Nombre de Usuario" -- FIXME by Google Translate "user name" +spanishMessage UserName = "Nombre de Usuario" spanishMessage Password = "Contraseña" spanishMessage CurrentPassword = "Contraseña actual" spanishMessage Register = "Registrarse" @@ -205,9 +205,9 @@ spanishMessage PleaseProvideUsername = "Por favor escriba su nombre de usuario" spanishMessage PleaseProvidePassword = "Por favor escriba su contraseña" spanishMessage NoIdentifierProvided = "No ha indicado una cuenta de correo/nombre de usuario" spanishMessage InvalidEmailAddress = "La cuenta de correo es inválida" -spanishMessage PasswordResetTitle = "Contraseña actualizada" +spanishMessage PasswordResetTitle = "Actualización de contraseña" spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario" -spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado" +spanishMessage SendPasswordResetEmail = "Enviar correo de actualización de contraseña" spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo." spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida" -- TODO From 0f28604cfefd75337705dc1cacafa57eb0db1a16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Sebasti=C3=A1n=20Estrella?= Date: Mon, 21 Aug 2017 11:38:19 -0500 Subject: [PATCH 101/124] Reduce verbosity using Monadic Forms --- yesod-form/ChangeLog.md | 5 +++ yesod-form/Yesod/Form/Functions.hs | 60 +++++++++++++++++++++++++++++- yesod-form/Yesod/Form/Types.hs | 25 +++++++++++++ yesod-form/yesod-form.cabal | 2 +- yesod-test/test/main.hs | 21 +++++++++++ 5 files changed, 111 insertions(+), 2 deletions(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index f1370845..9b0d210b 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.14 + +* Added `WForm` to reduce the verbosity using monadic forms. +* Added `wreq` and `wopt` correspondent functions for `WForm`. + ## 1.4.13 * Fixed `textareaField` `writeHtmlEscapedChar` trim "\r" diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 37d93f13..ab1d613c 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -13,7 +13,12 @@ module Yesod.Form.Functions -- * Applicative/Monadic conversion , formToAForm , aFormToForm + , mFormToWForm + , wFormToAForm + , wFormToMForm -- * Fields to Forms + , wreq + , wopt , mreq , mopt , areq @@ -51,8 +56,9 @@ module Yesod.Form.Functions import Yesod.Form.Types import Data.Text (Text, pack) import Control.Arrow (second) -import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local) import Control.Monad.Trans.Class +import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST) +import Control.Monad.Trans.Writer (runWriterT, writer) import Control.Monad (liftM, join) import Data.Byteable (constEqBytes) import Text.Blaze (Markup, toMarkup) @@ -105,6 +111,58 @@ askFiles = do (x, _, _) <- ask return $ liftM snd x +-- | Converts a form field into monadic form 'WForm'. This field requires a +-- value and will return 'FormFailure' if left empty. +-- +-- @since 1.4.14 +wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) + => Field m a -- ^ form field + -> FieldSettings site -- ^ settings for this field + -> Maybe a -- ^ optional default value + -> WForm m (FormResult a) +wreq f fs = mFormToWForm . mreq f fs + +-- | Converts a form field into monadic form 'WForm'. This field is optional, +-- i.e. if filled in, it returns 'Just a', if left empty, it returns +-- 'Nothing'. Arguments are the same as for 'wreq' (apart from type of default +-- value). +-- +-- @since 1.4.14 +wopt :: (MonadHandler m, HandlerSite m ~ site) + => Field m a -- ^ form field + -> FieldSettings site -- ^ settings for this field + -> Maybe (Maybe a) -- ^ optional default value + -> WForm m (FormResult (Maybe a)) +wopt f fs = mFormToWForm . mopt f fs + +-- | Converts a monadic form 'WForm' into an applicative form 'AForm'. +-- +-- @since 1.4.14 +wFormToAForm :: MonadHandler m + => WForm m (FormResult a) -- ^ input form + -> AForm m a -- ^ output form +wFormToAForm = formToAForm . wFormToMForm + +-- | Converts a monadic form 'WForm' into another monadic form 'MForm'. +-- +-- @since 1.4.14 +wFormToMForm :: (MonadHandler m, HandlerSite m ~ site) + => WForm m a -- ^ input form + -> MForm m (a, [FieldView site]) -- ^ output form +wFormToMForm = mapRWST (fmap group . runWriterT) + where + group ((a, ints, enctype), views) = ((a, views), ints, enctype) + +-- | Converts a monadic form 'MForm' into another monadic form 'WForm'. +-- +-- @since 1.4.14 +mFormToWForm :: (MonadHandler m, HandlerSite m ~ site) + => MForm m (a, FieldView site) -- ^ input form + -> WForm m a -- ^ output form +mFormToWForm = mapRWST $ \f -> do + ((a, view), ints, enctype) <- lift f + writer ((a, ints, enctype), [view]) + -- | Converts a form field into monadic form. This field requires a value -- and will return 'FormFailure' if left empty. mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index c3d367c0..b41c7b1b 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -12,6 +12,7 @@ module Yesod.Form.Types , FileEnv , Ints (..) -- * Form + , WForm , MForm , AForm (..) -- * Build forms @@ -22,6 +23,7 @@ module Yesod.Form.Types ) where import Control.Monad.Trans.RWS (RWST) +import Control.Monad.Trans.Writer (WriterT) import Data.Text (Text) import Data.Monoid (Monoid (..)) import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue)) @@ -102,6 +104,29 @@ instance Show Ints where type Env = Map.Map Text [Text] type FileEnv = Map.Map Text [FileInfo] +-- | 'MForm' variant stacking a 'WriterT'. The following code example using a +-- monadic form 'MForm': +-- +-- > formToAForm $ do +-- > (field1F, field1V) <- mreq textField MsgField1 Nothing +-- > (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing +-- > (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing +-- > return +-- > ( MyForm <$> field1F <*> field2F <*> field3F +-- > , [field1V, field2V, field3V] +-- > ) +-- +-- Could be rewritten as follows using 'WForm': +-- +-- > wFormToAForm $ do +-- > field1F <- wreq textField MsgField1 Nothing +-- > field2F <- wreq (checkWith field1F textField) MsgField2 Nothing +-- > field3F <- wreq (checkWith field1F textField) MsgField3 Nothing +-- > return $ MyForm <$> field1F <*> field2F <*> field3F +-- +-- @since 1.4.14 +type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a + type MForm m a = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 177653d9..e9fba0bd 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.13 +version: 1.4.14 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 0b2fe611..67511ee9 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -150,6 +150,18 @@ main = hspec $ do addToken statusIs 200 bodyEquals "12345" + yit "labels WForm" $ do + get ("/wform" :: Text) + statusIs 200 + + request $ do + setMethod "POST" + setUrl ("/wform" :: Text) + byLabel "Some WLabel" "12345" + fileByLabel "Some WFile" "test/main.hs" "text/plain" + addToken + statusIs 200 + bodyEquals "12345" yit "finding html" $ do get ("/html" :: Text) statusIs 200 @@ -334,6 +346,15 @@ app = liteApp $ do case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget + onStatic "wform" $ dispatchTo $ do + ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do + field1F <- wreq textField "Some WLabel" Nothing + field2F <- wreq fileField "Some WFile" Nothing + + return $ (,) Control.Applicative.<$> field1F <*> field2F + case mfoo of + FormSuccess (foo, _) -> return $ toHtml foo + _ -> defaultLayout widget onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon

" :: Text) From 1e9427baeeee8e45b6f148f7bffb54d5a69f961f Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 22 Aug 2017 11:24:35 +0300 Subject: [PATCH 102/124] Version bump --- yesod-auth/ChangeLog.md | 4 ++++ yesod-auth/yesod-auth.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index fdfbfeea..dc96c5dd 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.17.3 + +* Some translation fixes + ## 1.4.17.2 * Move to cryptonite from cryptohash diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index a50db32a..75339439 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.17.2 +version: 1.4.17.3 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From 4f14b9b82d99a1e2318b0faf415c596df59fd5be Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 22 Aug 2017 11:25:51 +0300 Subject: [PATCH 103/124] Add a stricter lower bound --- yesod-test/yesod-test.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 528ee130..d2df283d 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -58,7 +58,7 @@ test-suite test , containers , html-conduit , yesod-core - , yesod-form + , yesod-form >= 1.4.14 , text , wai , lifted-base From f08944d888ca35898f9c233ace38f6aa727ea6b7 Mon Sep 17 00:00:00 2001 From: Jesse Kempf Date: Tue, 22 Aug 2017 13:09:33 -0700 Subject: [PATCH 104/124] Give FormResult an Alternative instance --- yesod-form/ChangeLog.md | 4 ++++ yesod-form/Yesod/Form/Types.hs | 14 +++++++++++++- yesod-form/yesod-form.cabal | 2 +- 3 files changed, 18 insertions(+), 2 deletions(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 9b0d210b..23425ea1 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.15 + +* Added `Alternative` instance to `FormResult` to simplify handling pages with multiple forms. + ## 1.4.14 * Added `WForm` to reduce the verbosity using monadic forms. diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index b41c7b1b..1aabcc68 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -30,7 +30,7 @@ import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue)) #define Html Markup #define ToHtml ToMarkup #define toHtml toMarkup -import Control.Applicative ((<$>), Applicative (..)) +import Control.Applicative ((<$>), Alternative (..), Applicative (..)) import Control.Monad (liftM) import Control.Monad.Trans.Class import Data.String (IsString (..)) @@ -45,6 +45,8 @@ import Data.Foldable -- -- The 'Applicative' instance will concatenate the failure messages in two -- 'FormResult's. +-- The 'Alternative' instance will choose 'FormFailure' before 'FormSuccess', +-- and 'FormMissing' last of all. data FormResult a = FormMissing | FormFailure [Text] | FormSuccess a @@ -80,6 +82,16 @@ instance Data.Traversable.Traversable FormResult where FormFailure errs -> pure (FormFailure errs) FormMissing -> pure FormMissing +-- | @since 1.4.15 +instance Alternative FormResult where + empty = FormMissing + + FormFailure e <|> _ = FormFailure e + _ <|> FormFailure e = FormFailure e + FormSuccess s <|> FormSuccess _ = FormSuccess s + FormMissing <|> result = result + result <|> FormMissing = result + -- | The encoding type required by a form. The 'ToHtml' instance produces values -- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index e9fba0bd..bc54653a 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.14 +version: 1.4.15 license: MIT license-file: LICENSE author: Michael Snoyman From 1569af55c74dba917ae03ac864979a03912bf147 Mon Sep 17 00:00:00 2001 From: GyuYong Jung Date: Sat, 26 Aug 2017 04:51:52 +0900 Subject: [PATCH 105/124] Add Korean translation --- yesod-auth/Yesod/Auth/Message.hs | 48 ++++++++++++++++++++++++++++ yesod-form/Yesod/Form/I18n/Korean.hs | 26 +++++++++++++++ yesod-form/yesod-form.cabal | 1 + 3 files changed, 75 insertions(+) create mode 100644 yesod-form/Yesod/Form/I18n/Korean.hs diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index e0827204..04d59c5e 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -19,6 +19,7 @@ module Yesod.Auth.Message , russianMessage , dutchMessage , danishMessage + , koreanMessage ) where import Data.Monoid (mappend, (<>)) @@ -784,3 +785,50 @@ danishMessage (IdentifierNotFound ident) = "Brugernavn findes ikke: " `mappend` danishMessage Logout = "Log ud" danishMessage LogoutTitle = "Log ud" danishMessage AuthError = "Fejl ved bekræftelse af identitet" + +koreanMessage :: AuthMessage -> Text +koreanMessage NoOpenID = "OpenID ID가 없습니다" +koreanMessage LoginOpenID = "OpenID로 로그인" +koreanMessage LoginGoogle = "Google로 로그인" +koreanMessage LoginYahoo = "Yahoo로 로그인" +koreanMessage Email = "이메일" +koreanMessage UserName = "사용자 이름" +koreanMessage Password = "비밀번호" +koreanMessage CurrentPassword = "현재 비밀번호" +koreanMessage Register = "등록" +koreanMessage RegisterLong = "새 계정 등록" +koreanMessage EnterEmail = "이메일 주소를 아래에 입력하시면 확인 이메일이 발송됩니다." +koreanMessage ConfirmationEmailSentTitle = "확인 이메일을 보냈습니다" +koreanMessage (ConfirmationEmailSent email) = + "확인 이메일을 " `mappend` + email `mappend` + "에 보냈습니다." +koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요." +koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다" +koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다." +koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다" +koreanMessage BadSetPass = "비밀번호를 설정하기 위해서는 로그인해야 합니다" +koreanMessage SetPassTitle = "비밀번호 설정" +koreanMessage SetPass = "새 비밀번호 설정" +koreanMessage NewPass = "새 비밀번호" +koreanMessage ConfirmPass = "확인" +koreanMessage PassMismatch = "비밀번호가 맞지 않습니다. 다시 시도해주세요." +koreanMessage PassUpdated = "비밀번호가 업데이트 되었습니다" +koreanMessage Facebook = "Facebook으로 로그인" +koreanMessage LoginViaEmail = "이메일로" +koreanMessage InvalidLogin = "잘못된 로그인입니다" +koreanMessage NowLoggedIn = "로그인했습니다" +koreanMessage LoginTitle = "로그인" +koreanMessage PleaseProvideUsername = "사용자 이름을 입력하세요" +koreanMessage PleaseProvidePassword = "비밀번호를 입력하세요" +koreanMessage NoIdentifierProvided = "이메일 주소나 사용자 이름이 입력되어 있지 않습니다" +koreanMessage InvalidEmailAddress = "이메일 주소가 잘못되었습니다" +koreanMessage PasswordResetTitle = "비밀번호 변경" +koreanMessage ProvideIdentifier = "이메일 주소나 사용자 이름" +koreanMessage SendPasswordResetEmail = "비밀번호 재설정 이메일 보내기" +koreanMessage PasswordResetPrompt = "이메일 주소나 사용자 이름을 아래에 입력하시면 비밀번호 재설정 이메일이 발송됩니다." +koreanMessage InvalidUsernamePass = "사용자 이름이나 비밀번호가 잘못되었습니다" +koreanMessage (IdentifierNotFound ident) = ident `mappend` "는 등록되어 있지 않습니다" +koreanMessage Logout = "로그아웃" +koreanMessage LogoutTitle = "로그아웃" +koreanMessage AuthError = "인증오류" diff --git a/yesod-form/Yesod/Form/I18n/Korean.hs b/yesod-form/Yesod/Form/I18n/Korean.hs new file mode 100644 index 00000000..212f298d --- /dev/null +++ b/yesod-form/Yesod/Form/I18n/Korean.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Form.I18n.Korean where + +import Yesod.Form.Types (FormMessage (..)) +import Data.Monoid (mappend) +import Data.Text (Text) + +koreanFormMessage :: FormMessage -> Text +koreanFormMessage (MsgInvalidInteger t) = "잘못된 정수입니다: " `Data.Monoid.mappend` t +koreanFormMessage (MsgInvalidNumber t) = "잘못된 숫자입니다: " `mappend` t +koreanFormMessage (MsgInvalidEntry t) = "잘못된 입력입니다: " `mappend` t +koreanFormMessage MsgInvalidTimeFormat = "잘못된 시간입니다. HH:MM[:SS] 형태로 입력하세요" +koreanFormMessage MsgInvalidDay = "잘못된 날짜입니다. YYYY-MM-DD 형태로 입력하세요" +koreanFormMessage (MsgInvalidUrl t) = "잘못된 URL입니다: " `mappend` t +koreanFormMessage (MsgInvalidEmail t) = "잘못된 이메일 주소입니다: " `mappend` t +koreanFormMessage (MsgInvalidHour t) = "잘못된 시간입니다: " `mappend` t +koreanFormMessage (MsgInvalidMinute t) = "잘못된 분입니다: " `mappend` t +koreanFormMessage (MsgInvalidSecond t) = "잘못된 초입니다: " `mappend` t +koreanFormMessage MsgCsrfWarning = "CSRF공격을 방지하기 위해 양식의 입력을 확인하세요." +koreanFormMessage MsgValueRequired = "값은 필수입니다" +koreanFormMessage (MsgInputNotFound t) = "입력을 찾을 수 없습니다: " `mappend` t +koreanFormMessage MsgSelectNone = "<없음>" +koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mappend` t +koreanFormMessage MsgBoolYes = "예" +koreanFormMessage MsgBoolNo = "아니오" +koreanFormMessage MsgDelete = "삭제하시겠습니까?" diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index bc54653a..cd8a55c3 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -69,6 +69,7 @@ library Yesod.Form.I18n.Dutch Yesod.Form.I18n.Spanish Yesod.Form.I18n.Chinese + Yesod.Form.I18n.Korean -- FIXME Yesod.Helpers.Crud ghc-options: -Wall From 59f073a41f701a2f4842f526d03bbcd60b4e5296 Mon Sep 17 00:00:00 2001 From: Paul Rouse Date: Tue, 29 Aug 2017 13:34:20 +0100 Subject: [PATCH 106/124] Pure move of Yesod.PasswordStore to Yesod.Auth.Util.PasswordStore --- yesod-auth/Yesod/{ => Auth/Util}/PasswordStore.hs | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename yesod-auth/Yesod/{ => Auth/Util}/PasswordStore.hs (100%) diff --git a/yesod-auth/Yesod/PasswordStore.hs b/yesod-auth/Yesod/Auth/Util/PasswordStore.hs similarity index 100% rename from yesod-auth/Yesod/PasswordStore.hs rename to yesod-auth/Yesod/Auth/Util/PasswordStore.hs From 464b05556822e904951851f715387f77a295490d Mon Sep 17 00:00:00 2001 From: Paul Rouse Date: Tue, 29 Aug 2017 13:40:32 +0100 Subject: [PATCH 107/124] Expose Yesod.Auth.Util.PasswordStore --- yesod-auth/ChangeLog.md | 4 ++++ yesod-auth/Yesod/Auth/Email.hs | 2 +- yesod-auth/Yesod/Auth/Util/PasswordStore.hs | 11 +++-------- yesod-auth/yesod-auth.cabal | 4 ++-- 4 files changed, 10 insertions(+), 11 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index dc96c5dd..2a529171 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.18 + +* Expose Yesod.Auth.Util.PasswordStore + ## 1.4.17.3 * Some translation fixes diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 0c6aa34d..44990a8e 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -116,7 +116,7 @@ import Yesod.Auth import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form -import qualified Yesod.PasswordStore as PS +import qualified Yesod.Auth.Util.PasswordStore as PS import Control.Applicative ((<$>), (<*>)) import qualified Crypto.Hash as H import qualified Crypto.Nonce as Nonce diff --git a/yesod-auth/Yesod/Auth/Util/PasswordStore.hs b/yesod-auth/Yesod/Auth/Util/PasswordStore.hs index 9e32a48e..7e093db1 100755 --- a/yesod-auth/Yesod/Auth/Util/PasswordStore.hs +++ b/yesod-auth/Yesod/Auth/Util/PasswordStore.hs @@ -1,13 +1,8 @@ {-# LANGUAGE OverloadedStrings, BangPatterns #-} {-# LANGUAGE CPP #-} -- | --- Module : Crypto.PasswordStore --- Copyright : (c) Peter Scott, 2011 --- License : BSD-style --- --- Maintainer : pjscott@iastate.edu --- Stability : experimental --- Portability : portable +-- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011, +-- and released under a BSD-style licence. -- -- Securely store hashed, salted passwords. If you need to store and verify -- passwords, there are many wrong ways to do it, most of them all too @@ -71,7 +66,7 @@ -- iteration count. This does not have a significant effect on security, but can -- be handy for compatibility with other code. -module Yesod.PasswordStore ( +module Yesod.Auth.Util.PasswordStore ( -- * Algorithms pbkdf1, -- :: ByteString -> Salt -> Int -> ByteString diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 75339439..839a41d3 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.17.3 +version: 1.4.18 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -77,8 +77,8 @@ library Yesod.Auth.GoogleEmail Yesod.Auth.GoogleEmail2 Yesod.Auth.Hardcoded + Yesod.Auth.Util.PasswordStore other-modules: Yesod.Auth.Routes - Yesod.PasswordStore ghc-options: -Wall source-repository head From 3c53acdad817539d836e4f3a0a7df9d073841965 Mon Sep 17 00:00:00 2001 From: Paul Rouse Date: Tue, 29 Aug 2017 18:49:21 +0100 Subject: [PATCH 108/124] Add "@since" comments for newly exposed Yesod.Auth.Util.PasswordStore --- yesod-auth/Yesod/Auth/Util/PasswordStore.hs | 51 +++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/yesod-auth/Yesod/Auth/Util/PasswordStore.hs b/yesod-auth/Yesod/Auth/Util/PasswordStore.hs index 7e093db1..1c754732 100755 --- a/yesod-auth/Yesod/Auth/Util/PasswordStore.hs +++ b/yesod-auth/Yesod/Auth/Util/PasswordStore.hs @@ -65,6 +65,8 @@ -- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact -- iteration count. This does not have a significant effect on security, but can -- be handy for compatibility with other code. +-- +-- @since 1.4.18 module Yesod.Auth.Util.PasswordStore ( @@ -126,6 +128,9 @@ import Data.ByteArray (convert) -- key should be stored in the password file. When a user wishes to authenticate -- a password, just pass it and the salt to this function, and see if the output -- matches. +-- +-- @since 1.4.18 +-- pbkdf1 :: ByteString -> Salt -> Int -> ByteString pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1) where @@ -156,6 +161,9 @@ hmacSHA256 secret msg = -- @32@ is the most common digest size for @SHA256@, and is -- what the algorithm internally uses. -- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak. +-- +-- @since 1.4.18 +-- pbkdf2 :: ByteString -> Salt -> Int -> ByteString pbkdf2 password (SaltBS salt) c = let hLen = 32 @@ -194,6 +202,9 @@ pbkdf2 password (SaltBS salt) c = -- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the -- system RNG as a fallback. This is the function used to generate salts by -- 'makePassword'. +-- +-- @since 1.4.18 +-- genSaltIO :: IO Salt genSaltIO = Control.Exception.catch genSaltDevURandom def @@ -247,6 +258,9 @@ writePwHash (strength, SaltBS salt, hash) = -- database. Generates a salt using high-quality randomness from -- @\/dev\/urandom@ or (if that is not available, for example on Windows) -- 'System.Random', which is included in the hashed output. +-- +-- @since 1.4.18 +-- makePassword :: ByteString -> Int -> IO ByteString makePassword = makePasswordWith pbkdf1 @@ -255,6 +269,8 @@ makePassword = makePasswordWith pbkdf1 -- -- >>> makePasswordWith pbkdf1 "password" 14 -- +-- @since 1.4.18 +-- makePasswordWith :: (ByteString -> Salt -> Int -> ByteString) -- ^ The algorithm to use (e.g. pbkdf1) -> ByteString @@ -271,6 +287,9 @@ makePasswordWith algorithm password strength = do -- Note that, unlike 'makePasswordWith', this function takes the @raw@ -- number of iterations. This means the user will need to specify a -- sensible value, typically @10000@ or @20000@. +-- +-- @since 1.4.18 +-- makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString) -- ^ A function modeling an algorithm (e.g. 'pbkdf1') -> (Int -> Int) @@ -291,6 +310,9 @@ makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash -- -- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14 -- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc=" +-- +-- @since 1.4.18 +-- makePasswordSalt :: ByteString -> Salt -> Int -> ByteString makePasswordSalt = makePasswordSaltWith pbkdf1 (2^) @@ -307,6 +329,8 @@ makePasswordSalt = makePasswordSaltWith pbkdf1 (2^) -- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..." -- > True -- +-- @since 1.4.18 +-- verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString) -- ^ A function modeling an algorithm (e.g. pbkdf1) -> (Int -> Int) @@ -323,6 +347,9 @@ verifyPasswordWith algorithm strengthModifier userInput pwHash = encode (algorithm userInput salt (strengthModifier strength)) == goodHash -- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm. +-- +-- @since 1.4.18 +-- verifyPassword :: ByteString -> ByteString -> Bool verifyPassword = verifyPasswordWith pbkdf1 (2^) @@ -336,6 +363,9 @@ verifyPassword = verifyPasswordWith pbkdf1 (2^) -- This function can be used to periodically update your password database when -- computers get faster, in order to keep up with Moore's law. This isn't hugely -- important, but it's a good idea. +-- +-- @since 1.4.18 +-- strengthenPassword :: ByteString -> Int -> ByteString strengthenPassword pwHash newstr = case readPwHash pwHash of @@ -350,6 +380,9 @@ strengthenPassword pwHash newstr = hash = decodeLenient hashB64 -- | Return the strength of a password hash. +-- +-- @since 1.4.18 +-- passwordStrength :: ByteString -> Int passwordStrength pwHash = case readPwHash pwHash of Nothing -> 0 @@ -363,12 +396,18 @@ passwordStrength pwHash = case readPwHash pwHash of -- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you -- really know what you're doing, you can create them from your own ByteString -- values with 'makeSalt'. +-- +-- @since 1.4.18 +-- newtype Salt = SaltBS ByteString deriving (Show, Eq, Ord) -- | Create a 'Salt' from a 'ByteString'. The input must be at least 8 -- characters, and can contain arbitrary bytes. Most users will not need to use -- this function. +-- +-- @since 1.4.18 +-- makeSalt :: ByteString -> Salt makeSalt = SaltBS . encode . check_length where check_length salt | B.length salt < 8 = @@ -377,17 +416,26 @@ makeSalt = SaltBS . encode . check_length -- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be -- base64-encoded. Most users will not need to use this function. +-- +-- @since 1.4.18 +-- exportSalt :: Salt -> ByteString exportSalt (SaltBS bs) = bs -- | Convert a raw 'ByteString' into a 'Salt'. -- Use this function with caution, since using a weak salt will result in a -- weak password. +-- +-- @since 1.4.18 +-- importSalt :: ByteString -> Salt importSalt = SaltBS -- | Is the format of a password hash valid? Attempts to parse a given password -- hash. Returns 'True' if it parses correctly, and 'False' otherwise. +-- +-- @since 1.4.18 +-- isPasswordFormatValid :: ByteString -> Bool isPasswordFormatValid = isJust . readPwHash @@ -395,6 +443,9 @@ isPasswordFormatValid = isJust . readPwHash -- generator. Returns the salt and the updated random number generator. This is -- meant to be used with 'makePasswordSalt' by people who would prefer to either -- use their own random number generator or avoid the 'IO' monad. +-- +-- @since 1.4.18 +-- genSaltRandom :: (RandomGen b) => b -> (Salt, b) genSaltRandom gen = (salt, newgen) where rands _ 0 = [] From 9edca8e3b5ec26e4b824ad28ba05792383a9640c Mon Sep 17 00:00:00 2001 From: Jesse Kempf Date: Wed, 30 Aug 2017 20:35:22 -0700 Subject: [PATCH 109/124] Correct Yesod-Auth's usage of "log in" vs "login" in English. "Log in" (two words) is a verb, indicating the action of, well, logging in. "Login" (one word) is a noun, indicating the credentials used to log in. --- yesod-auth/ChangeLog.md | 4 ++++ yesod-auth/Yesod/Auth/Message.hs | 10 +++++----- yesod-auth/yesod-auth.cabal | 2 +- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 2a529171..e661abc7 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.19 + +* Adjust English localization to distinguish between "log in" (verb) and "login" (noun) + ## 1.4.18 * Expose Yesod.Auth.Util.PasswordStore diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index 04d59c5e..b8e565a5 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -76,9 +76,9 @@ defaultMessage = englishMessage englishMessage :: AuthMessage -> Text englishMessage NoOpenID = "No OpenID identifier found" -englishMessage LoginOpenID = "Login via OpenID" -englishMessage LoginGoogle = "Login via Google" -englishMessage LoginYahoo = "Login via Yahoo" +englishMessage LoginOpenID = "Log in via OpenID" +englishMessage LoginGoogle = "Log in via Google" +englishMessage LoginYahoo = "Log in via Yahoo" englishMessage Email = "Email" englishMessage UserName = "User name" englishMessage Password = "Password" @@ -102,8 +102,8 @@ englishMessage NewPass = "New password" englishMessage ConfirmPass = "Confirm" englishMessage PassMismatch = "Passwords did not match, please try again" englishMessage PassUpdated = "Password updated" -englishMessage Facebook = "Login with Facebook" -englishMessage LoginViaEmail = "Login via email" +englishMessage Facebook = "Log in with Facebook" +englishMessage LoginViaEmail = "Log in via email" englishMessage InvalidLogin = "Invalid login" englishMessage NowLoggedIn = "You are now logged in" englishMessage LoginTitle = "Log In" diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 839a41d3..4d406329 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.18 +version: 1.4.19 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From fd872cff40d02bd0e12b85581e59907377dbdf34 Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Wed, 6 Sep 2017 10:08:45 +0900 Subject: [PATCH 110/124] Add support to yesod-core for weak etags --- yesod-core/ChangeLog.md | 4 ++ yesod-core/Yesod/Core/Handler.hs | 58 +++++++++++++++++++---- yesod-core/test/YesodCoreTest/Redirect.hs | 28 +++++++++-- yesod-core/yesod-core.cabal | 2 +- 4 files changed, 78 insertions(+), 14 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 9f946793..6e9d8d3e 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.37 + +* Add `setWeakEtag` function in Yesod.Core.Handler module. + ## 1.4.36 * Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 3b1b50ed..aaf7de3a 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -123,6 +123,7 @@ module Yesod.Core.Handler , alreadyExpired , expiresAt , setEtag + , setWeakEtag -- * Session , SessionMap , lookupSession @@ -851,12 +852,24 @@ alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT" expiresAt :: MonadHandler m => UTCTime -> m () expiresAt = setHeader "Expires" . formatRFC1123 +data Etag + = WeakEtag !S.ByteString + -- ^ Prefixed by W/ and surrounded in quotes. Signifies that contents are + -- semantically identical but make no guarantees about being bytewise identical. + | StrongEtag !S.ByteString + -- ^ Signifies that contents should be byte-for-byte identical if they match + -- the provided ETag + | InvalidEtag !S.ByteString + -- ^ Anything else that ends up in a header that expects an ETag but doesn't + -- properly follow the ETag format specified in RFC 7232, section 2.3 + deriving (Show, Eq) + -- | Check the if-none-match header and, if it matches the given value, return -- a 304 not modified response. Otherwise, set the etag header to the given -- value. -- -- Note that it is the responsibility of the caller to ensure that the provided --- value is a value etag value, no sanity checking is performed by this +-- value is a valid etag value, no sanity checking is performed by this -- function. -- -- @since 1.4.4 @@ -864,22 +877,49 @@ setEtag :: MonadHandler m => Text -> m () setEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch - if encodeUtf8 etag `elem` matches + if StrongEtag (encodeUtf8 etag) `elem` matches then notModified else addHeader "etag" $ T.concat ["\"", etag, "\""] --- | Parse an if-none-match field according to the spec. Does not parsing on --- weak matches, which are not supported by setEtag. -parseMatch :: S.ByteString -> [S.ByteString] +-- | Parse an if-none-match field according to the spec. +parseMatch :: S.ByteString -> [Etag] parseMatch = map clean . S.split W8._comma where - clean = stripQuotes . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace + clean = classify . fst . S.spanEnd W8.isSpace . S.dropWhile W8.isSpace - stripQuotes bs + classify bs | S.length bs >= 2 && S.head bs == W8._quotedbl && S.last bs == W8._quotedbl - = S.init $ S.tail bs - | otherwise = bs + = StrongEtag $ S.init $ S.tail bs + | S.length bs >= 4 && + S.head bs == W8._W && + S.index bs 1 == W8._slash && + S.index bs 2 == W8._quotedbl && + S.last bs == W8._quotedbl + = WeakEtag $ S.init $ S.drop 3 bs + | otherwise = InvalidEtag bs + +-- | Check the if-none-match header and, if it matches the given value, return +-- a 304 not modified response. Otherwise, set the etag header to the given +-- value. +-- +-- A weak etag is only expected to be semantically identical to the prior content, +-- but doesn't have to be byte-for-byte identical. Therefore it can be useful for +-- dynamically generated content that may be difficult to perform bytewise hashing +-- upon. +-- +-- Note that it is the responsibility of the caller to ensure that the provided +-- value is a valid etag value, no sanity checking is performed by this +-- function. +-- +-- @since 1.4.37 +setWeakEtag :: MonadHandler m => Text -> m () +setWeakEtag etag = do + mmatch <- lookupHeader "if-none-match" + let matches = maybe [] parseMatch mmatch + if WeakEtag (encodeUtf8 etag) `elem` matches + then notModified + else addHeader "etag" $ T.concat ["W/\"", etag, "\""] -- | Set a variable in the user's session. -- diff --git a/yesod-core/test/YesodCoreTest/Redirect.hs b/yesod-core/test/YesodCoreTest/Redirect.hs index d4e63932..b916d784 100644 --- a/yesod-core/test/YesodCoreTest/Redirect.hs +++ b/yesod-core/test/YesodCoreTest/Redirect.hs @@ -6,7 +6,7 @@ module YesodCoreTest.Redirect ) where import YesodCoreTest.YesodTest -import Yesod.Core.Handler (redirectWith, setEtag) +import Yesod.Core.Handler (redirectWith, setEtag, setWeakEtag) import qualified Network.HTTP.Types as H data Y = Y @@ -17,6 +17,7 @@ mkYesod "Y" [parseRoutes| /r307 R307 GET /rregular RRegular GET /etag EtagR GET +/weak-etag WeakEtagR GET |] instance Yesod Y where approot = ApprootStatic "http://test" app :: Session () -> IO () @@ -28,12 +29,13 @@ getRootR = return () postRootR :: Handler () postRootR = return () -getR301, getR303, getR307, getRRegular, getEtagR :: Handler () +getR301, getR303, getR307, getRRegular, getEtagR, getWeakEtagR :: Handler () getR301 = redirectWith H.status301 RootR getR303 = redirectWith H.status303 RootR getR307 = redirectWith H.status307 RootR getRRegular = redirect RootR getEtagR = setEtag "hello world" +getWeakEtagR = setWeakEtag "hello world" specs :: Spec specs = describe "Redirect" $ do @@ -82,7 +84,7 @@ specs = describe "Redirect" $ do { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "hello world")] } - assertStatus 304 res + assertStatus 200 res it "different if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] @@ -102,9 +104,27 @@ specs = describe "Redirect" $ do , requestHeaders = [("if-none-match", "\"foo\", \"hello world\"")] } assertStatus 304 res - it "ignore weak" $ app $ do + it "ignore weak when provided normal etag" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] } assertStatus 200 res + it "weak etag" $ app $ do + res <- request defaultRequest + { pathInfo = ["weak-etag"] + , requestHeaders = [("if-none-match", "\"foo\", W/\"hello world\"")] + } + assertStatus 304 res + it "different if-none-match for weak etag" $ app $ do + res <- request defaultRequest + { pathInfo = ["weak-etag"] + , requestHeaders = [("if-none-match", "W/\"foo\"")] + } + assertStatus 200 res + it "ignore strong when expecting weak" $ app $ do + res <- request defaultRequest + { pathInfo = ["weak-etag"] + , requestHeaders = [("if-none-match", "\"hello world\", W/\"foo\"")] + } + assertStatus 200 res diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index e5c8bba2..80794eb3 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.36 +version: 1.4.37 license: MIT license-file: LICENSE author: Michael Snoyman From c4ef7e1410db25226dd45e0de1111ebf7b7f2c22 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 6 Sep 2017 18:28:00 +0300 Subject: [PATCH 111/124] yesod-form version bump --- yesod-form/ChangeLog.md | 4 ++++ yesod-form/yesod-form.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 23425ea1..a941f21a 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.16 + +* Korean translation + ## 1.4.15 * Added `Alternative` instance to `FormResult` to simplify handling pages with multiple forms. diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index cd8a55c3..4f252938 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.15 +version: 1.4.16 license: MIT license-file: LICENSE author: Michael Snoyman From 05b2193e9fa49c429df62c2661af0086396660ef Mon Sep 17 00:00:00 2001 From: Ian Duncan Date: Fri, 8 Sep 2017 09:00:12 +0900 Subject: [PATCH 112/124] Code review fixes for #1444 --- yesod-core/Yesod/Core/Handler.hs | 6 +++++- yesod-core/test/YesodCoreTest/Redirect.hs | 4 +++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index aaf7de3a..94dd27dc 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -877,10 +877,14 @@ setEtag :: MonadHandler m => Text -> m () setEtag etag = do mmatch <- lookupHeader "if-none-match" let matches = maybe [] parseMatch mmatch - if StrongEtag (encodeUtf8 etag) `elem` matches + baseTag = encodeUtf8 etag + strongTag = StrongEtag baseTag + badTag = InvalidEtag baseTag + if any (\tag -> tag == strongTag || tag == badTag) matches then notModified else addHeader "etag" $ T.concat ["\"", etag, "\""] + -- | Parse an if-none-match field according to the spec. parseMatch :: S.ByteString -> [Etag] parseMatch = diff --git a/yesod-core/test/YesodCoreTest/Redirect.hs b/yesod-core/test/YesodCoreTest/Redirect.hs index b916d784..c922113a 100644 --- a/yesod-core/test/YesodCoreTest/Redirect.hs +++ b/yesod-core/test/YesodCoreTest/Redirect.hs @@ -79,12 +79,14 @@ specs = describe "Redirect" $ do res <- request defaultRequest { pathInfo = ["etag"] } assertStatus 200 res assertHeader "etag" "\"hello world\"" res + -- Note: this violates the RFC around ETag format, but is being left as is + -- out of concerns that it might break existing users with misbehaving clients. it "single, unquoted if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] , requestHeaders = [("if-none-match", "hello world")] } - assertStatus 200 res + assertStatus 304 res it "different if-none-match" $ app $ do res <- request defaultRequest { pathInfo = ["etag"] From 600d3073105197189661e25a1722289196a64b06 Mon Sep 17 00:00:00 2001 From: Cole Brown Date: Thu, 21 Sep 2017 16:02:18 -0400 Subject: [PATCH 113/124] Extend `YesodAuthEmail` to support extensible password hashing. This change introduces `hashAndSaltPassword` and `verifyPassword` to the `YesodAuthEmail` type class, allowing users to implement their own hashing schemes (i.e. to provide compatibility with an existing database). It also updates the default handlers to use these new functions when appropriate. The functions have default implementation such that behavior for legacy applications should not change. --- yesod-auth/ChangeLog.md | 5 ++++ yesod-auth/Yesod/Auth/Email.hs | 52 +++++++++++++++++++++++----------- yesod-auth/yesod-auth.cabal | 2 +- 3 files changed, 42 insertions(+), 17 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index e661abc7..f978cf10 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.4.20 + +* Extend `YesodAuthEmail` to support extensible password hashing via + `hashAndSaltPassword` and `verifyPassword` functions + ## 1.4.19 * Adjust English localization to distinguish between "log in" (verb) and "login" (noun) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 44990a8e..51cbea7c 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -4,7 +4,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables#-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | A Yesod plugin for Authentication via e-mail -- @@ -132,7 +132,7 @@ import Safe (readMay) import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) -import Data.Maybe (isJust, isNothing, fromJust) +import Data.Maybe (isJust) import Data.ByteArray (convert) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute @@ -203,6 +203,22 @@ class ( YesodAuth site -- @since 1.1.0 setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () + -- | Hash and salt a password + -- + -- Default: 'saltPass'. + -- + -- @since 1.4.20 + hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass + hashAndSaltPassword = liftIO . saltPass + + -- | Verify a password matches the stored password for the given account. + -- + -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'. + -- + -- @since 1.4.20 + verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool + verifyPassword plain salted = return $ isValidPass plain salted + -- | Verify the email address on the given account. -- -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@ @@ -620,12 +636,14 @@ postLoginR = do , emailCredsStatus <$> mecreds ) of (Just aid, Just email', Just True) -> do - mrealpass <- lift $ getPassword aid - case mrealpass of - Nothing -> return Nothing - Just realpass -> return $ if isValidPass pass realpass - then Just email' - else Nothing + mrealpass <- lift $ getPassword aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> do + passValid <- lift $ verifyPassword pass realpass + return $ if passValid + then Just email' + else Nothing _ -> return Nothing let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier case maid of @@ -753,14 +771,16 @@ postPasswordR = do then getThird jcreds else fcurrent mrealpass <- lift $ getPassword aid - case mrealpass of - Nothing -> + case (mrealpass, current) of + (Nothing, _) -> lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" - Just realpass - | isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass - | isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds - | otherwise -> - lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" + (_, Nothing) -> + loginErrorMessageI LoginR Msg.BadSetPass + (Just realpass, Just current') -> do + passValid <- lift $ verifyPassword current' realpass + if passValid + then confirmPassword aid tm jcreds + else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" where msgOk = Msg.PassUpdated @@ -787,7 +807,7 @@ postPasswordR = do case isSecure of Left e -> lift $ loginErrorMessage (tm setpassR) e Right () -> do - salted <- liftIO $ saltPass new + salted <- lift $ hashAndSaltPassword new y <- lift $ do setPassword aid salted deleteSession loginLinkKey diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 4d406329..196c2df9 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.19 +version: 1.4.20 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin From 42b94f5066071d222f164aece888aadc85e4b54e Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Thu, 2 Nov 2017 20:16:33 -0700 Subject: [PATCH 114/124] Add Github issue and PR templates, plus contributing guidelines * Closes #1450 --- .github/ISSUE_TEMPLATE.md | 29 ++++++++++++++++ .github/PULL_REQUEST_TEMPLATE.md | 14 ++++++++ CONTRIBUTING.md | 58 ++++++++++++++++++++++++++++++++ 3 files changed, 101 insertions(+) create mode 100644 .github/ISSUE_TEMPLATE.md create mode 100644 .github/PULL_REQUEST_TEMPLATE.md create mode 100644 CONTRIBUTING.md diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md new file mode 100644 index 00000000..b788b8ca --- /dev/null +++ b/.github/ISSUE_TEMPLATE.md @@ -0,0 +1,29 @@ + diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md new file mode 100644 index 00000000..c9839a31 --- /dev/null +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -0,0 +1,14 @@ +Before submitting your PR, check that you've: + +- [ ] Bumped the version number +- [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html) +- [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock + +After submitting your PR: + +- [ ] Update the Changelog.md file with a link to your PR +- [ ] Check that CI passes (or if it fails, for reasons unrelated to your change, like CI timeouts) + + \ No newline at end of file diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..cfa95b02 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,58 @@ +# Contributing + +Thanks for your interest in contributing to Yesod! This file has some tips for developing Yesod and getting a pull request accepted. + +## Development + +Yesod is a mega-repo that contains many Haskell packages, each in a different directory. All the subprojects can be developed with Stack, using `stack `, e.g. + +* `stack build yesod-form` +* `stack test yesod-auth` +* `stack haddock yesod-websockets` + +If you'd like to test your changes in a full-fledged Yesod app, you can use Stack to build against it, e.g.: + +``` +packages: +- '/path/to/this/repo/yesod-auth' +``` + +## Testing + +Tests are appreciated, but not required, for changes to Yesod. + +## Documentation + +All public APIs must be documented. Documenting private functions is optional, but may be nice depending on their complexity. Example documentation: + +``` +-- | Looks up the hidden input named "_token" and adds its value to the params. +-- +-- ==== __Examples__ +-- +-- > request $ do +-- > addToken_ "#formID" +-- +-- @since 1.5.4 +addToken_ :: Query -- ^ CSS selector that resolves to the @
@ containing the token. + -> RequestBuilder site () +``` + +Examples are appreciated, but not required, in documentation. Marking new APIs with `@since ` is required. + +## Versioning + +Yesod packages roughly follow the Haskell Package Versioning Policy, MAJOR.MAJOR.MINOR.PATCH + +* MAJOR - Used for massive changes in the library +* MAJOR - Used for smaller breaking changes, like removing functions or changed behavior of a function. +* MINOR - Used for new public APIs +* PATCH - Used for bug fixes and documentationc changes. + +If you feel there is ambiguity to a change (e.g. fixing a bug in a function, when people may be relying on the old broken behavior), you can ask in an issue or pull request. + +Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes. + +## Changelog + +After you submit a PR, update the subproject's Changelog.md file with a link to your PR From abc50deffe63bb1aa8e3b054624617f574acfde1 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 7 Nov 2017 06:03:59 +0200 Subject: [PATCH 115/124] Drop an upper bound --- yesod-bin/ChangeLog.md | 4 ++++ yesod-bin/yesod-bin.cabal | 4 ++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 01023a30..1380e9af 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.2.6 + +* Drop an upper bound + ## 1.5.2.5 * Support for `add-handler` when modules are in `src/` directory [#1413](https://github.com/yesodweb/yesod/issues/1413) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 6b05720b..cb8acaa0 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.2.5 +version: 1.5.2.6 license: MIT license-file: LICENSE author: Michael Snoyman @@ -33,7 +33,7 @@ executable yesod , template-haskell , directory >= 1.2.1 , Cabal >= 1.18 - , unix-compat >= 0.2 && < 0.5 + , unix-compat >= 0.2 , containers >= 0.2 , attoparsec >= 0.10 , http-types >= 0.7 From 2c59cb7dcdc837d4f60a763998b9e3e69d204ad4 Mon Sep 17 00:00:00 2001 From: Alex Greif Date: Wed, 8 Nov 2017 13:36:39 +0100 Subject: [PATCH 116/124] extend docs of defaultMaybeAuthId (#1453) * extend docs of defaultMaybeAuthId make more explicite that on each call a database access is done. This can be of relevance and sometimes redundant with other Handler functionality * Update Auth.hs --- yesod-auth/Yesod/Auth.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index dda8182f..73da816c 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -243,7 +243,8 @@ credsKey = "_ID" -- | Retrieves user credentials from the session, if user is authenticated. -- -- This function does /not/ confirm that the credentials are valid, see --- 'maybeAuthIdRaw' for more information. +-- 'maybeAuthIdRaw' for more information. The first call in a request +-- does a database request to make sure that the account is still in the database. -- -- Since 1.1.2 defaultMaybeAuthId From 7a4b2812c150dedb4a4350634bf45d8d5b04bd10 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Wed, 8 Nov 2017 22:32:15 -0800 Subject: [PATCH 117/124] Update contributing guidelines based of Snoyberg's "How to Send Me a PR" post --- CONTRIBUTING.md | 56 ++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 46 insertions(+), 10 deletions(-) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index cfa95b02..6914fa00 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -17,11 +17,39 @@ packages: - '/path/to/this/repo/yesod-auth' ``` -## Testing +## Coding Guidelines -Tests are appreciated, but not required, for changes to Yesod. +### Safety -## Documentation +Avoid partial functions. Even if you know the partial function is safe in your instance, partial functions require more reasoning from the programmer and are not resilient to refactoring. For the rare cases where a partial function is appropriate, a custom `error` should be used. + +### Style + +Keep coding style consistent with the rest of the file, but don't worry about style too much otherwise. PRs changing code style are viewed skeptically. + +### Dependencies + +Avoid adding unnecessary dependencies. If a dependency provides only a minor convenience for your implementation, it's probably better to skip it. + +If you do add a new dependency, try to support a wide range of versions of it. + +### Backwards Compatibility + +Backwards incompatible changes are viewed skeptically—best to ask in an issue to see if a particular backwards incompatible change would be approved. If possible keep backwards compatibility by adding new APIs and deprecating old ones. + +Keep backwards compatibility with old versions of dependencies when possible. + +## PR Guidelines + +### PR Scope + +As much as possible, keep separate changes in separate PRs. + +### Testing + +Tests are recommended, but not required. + +### Documentation All public APIs must be documented. Documenting private functions is optional, but may be nice depending on their complexity. Example documentation: @@ -38,21 +66,29 @@ addToken_ :: Query -- ^ CSS selector that resolves to the @@ containing th -> RequestBuilder site () ``` -Examples are appreciated, but not required, in documentation. Marking new APIs with `@since ` is required. +Examples are recommended, but not required, in documentation. Marking new APIs with `@since ` is required. -## Versioning +### Versioning -Yesod packages roughly follow the Haskell Package Versioning Policy, MAJOR.MAJOR.MINOR.PATCH +Yesod packages roughly follow the Haskell Package Versioning Policy style of MAJOR.MAJOR.MINOR.PATCH * MAJOR - Used for massive changes in the library -* MAJOR - Used for smaller breaking changes, like removing functions or changed behavior of a function. +* MAJOR - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. * MINOR - Used for new public APIs -* PATCH - Used for bug fixes and documentationc changes. +* PATCH - Used for bug fixes + +Documentation changes don't require a new version. If you feel there is ambiguity to a change (e.g. fixing a bug in a function, when people may be relying on the old broken behavior), you can ask in an issue or pull request. Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes. -## Changelog +In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a MAJOR breaking change. -After you submit a PR, update the subproject's Changelog.md file with a link to your PR +### Changelog + +After you submit a PR, update the subproject's Changelog.md file with the new version number and a link to your PR. If your PR does not need to bump the version number, include the change in an "Unreleased" section at the top. + +### Releases + +Releases should be done as soon as possible after a pull request is merged—don't be shy about reminding us to make a release if we forget. \ No newline at end of file From 3247237c444d9eeba7de812b29be2c11c1c27663 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Wed, 8 Nov 2017 22:43:51 -0800 Subject: [PATCH 118/124] Respond to @psibi's comments --- .github/ISSUE_TEMPLATE.md | 2 +- CONTRIBUTING.md | 13 +++++++------ 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md index b788b8ca..33b1bfd5 100644 --- a/.github/ISSUE_TEMPLATE.md +++ b/.github/ISSUE_TEMPLATE.md @@ -25,5 +25,5 @@ command -v yesod && yesod version ### Support -Please direct support questions to [Stack Overflow](https://stackoverflow.com/questions/tagged/yesod) or the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb). If you don't get a response there, or you suspect there may be a bug in Yesod causing your problem, you're welcome to ask here. +Please direct support questions to [Stack Overflow](https://stackoverflow.com/questions/tagged/yesod+haskell) or the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb). If you don't get a response there, or you suspect there may be a bug in Yesod causing your problem, you're welcome to ask here. --> diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 6914fa00..1b04caf8 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -70,12 +70,13 @@ Examples are recommended, but not required, in documentation. Marking new APIs w ### Versioning -Yesod packages roughly follow the Haskell Package Versioning Policy style of MAJOR.MAJOR.MINOR.PATCH +Yesod packages roughly follow the Haskell Package Versioning Policy style of A.B.C.[D] (MAJOR.MAJOR.MINOR.[PATCH]) -* MAJOR - Used for massive changes in the library -* MAJOR - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. -* MINOR - Used for new public APIs -* PATCH - Used for bug fixes +* A - Used for massive changes in the library. (Example: 1.2.3.4 becomes 2.0.0) +* B - Used for smaller breaking changes, like removing, renaming, or changing behavior of existing public API. (Example: 1.2.3.4 becomes 1.3.0) +* C - Used for new public APIs (Example: 1.2.3.4 becomes 1.2.4) +* D - Used for bug fixes (Example: 1.2.3.4 becomes 1.2.3.5). + * D is optional in the version number, so 2.0.0 is a valid version. Documentation changes don't require a new version. @@ -83,7 +84,7 @@ If you feel there is ambiguity to a change (e.g. fixing a bug in a function, whe Unlike in the Package Versioning Policy, deprecations are not counted as MAJOR changes. -In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a MAJOR breaking change. +In some cases, dropping compatibility with a major version of a dependency (e.g. changing from transformers >= 0.3 to transformers >= 0.4), is considered a breaking change. ### Changelog From 8208e3deac16b10d596b2d9a29728cca1d3fecb1 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Wed, 15 Nov 2017 11:32:59 -0800 Subject: [PATCH 119/124] Fix typo in Haddocks of assertEq --- yesod-test/Yesod/Test.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 06e1fa67..e359896b 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -339,7 +339,7 @@ htmlQuery = htmlQuery' yedResponse [] -- | Asserts that the two given values are equal. -- --- In case they are not equal, error mesasge includes the two values. +-- In case they are not equal, error message includes the two values. -- -- @since 1.5.2 assertEq :: (HasCallStack, Eq a, Show a) => String -> a -> a -> YesodExample site () From 33d320039947542038a93188f6847ad07acdf6ab Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Fri, 17 Nov 2017 14:28:20 -0500 Subject: [PATCH 120/124] Fix constraints on get404 and getBy404 The constraints on `get404` and `getBy404` were overly powerful. They were constrained by `PersistStore` and `PersistStoreUnique`, which is an alias for `PersistStoreWrite...`. These only need `PersistStoreRead...` to accomplish their job. --- yesod-persistent/Yesod/Persist/Core.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index aecef655..3f99833f 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -134,7 +134,7 @@ respondSourceDB ctype = respondSource ctype . runDBSource -- | Get the given entity by ID, or return a 404 not found if it doesn't exist. #if MIN_VERSION_persistent(2,5,0) -get404 :: (MonadIO m, PersistStore backend, PersistRecordBackend val backend) +get404 :: (MonadIO m, PersistStoreRead backend, PersistRecordBackend val backend) => Key val -> ReaderT backend m val #else @@ -151,7 +151,7 @@ get404 key = do -- | Get the given entity by unique key, or return a 404 not found if it doesn't -- exist. #if MIN_VERSION_persistent(2,5,0) -getBy404 :: (PersistUnique backend, PersistRecordBackend val backend, MonadIO m) +getBy404 :: (PersistUniqueRead backend, PersistRecordBackend val backend, MonadIO m) => Unique val -> ReaderT backend m (Entity val) #else From cfb8fd9b215c35f56a98146eae3a050e630accf5 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Fri, 17 Nov 2017 14:41:57 -0500 Subject: [PATCH 121/124] Version bump for get404 and getBy404 constraint changes. --- yesod-persistent/ChangeLog.md | 4 ++++ yesod-persistent/yesod-persistent.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index ebb2d8e2..a7343ed8 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.3 + +* Fix overly powerful constraints on get404 and getBy404. + ## 1.4.2 * Fix warnings diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index ed9a33ed..a2c255dd 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,5 +1,5 @@ name: yesod-persistent -version: 1.4.2 +version: 1.4.3 license: MIT license-file: LICENSE author: Michael Snoyman From 79ab662a8079cc38434aa84dca4047384ceff10e Mon Sep 17 00:00:00 2001 From: Josh Berman Date: Sun, 26 Nov 2017 11:52:37 +0200 Subject: [PATCH 122/124] Fix docs on `languages` set and `getMessageRender` to use it (#1325) --- yesod-core/ChangeLog.md | 3 +++ yesod-core/Yesod/Core/Handler.hs | 8 ++++---- yesod-core/yesod-core.cabal | 2 +- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 6e9d8d3e..85a3e3ad 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,3 +1,6 @@ +## 1.4.37.1 +* Fix documentation on `languages` function, update `getMessageRender` to use said function. [1325] (https://github.com/yesodweb/yesod/issues/1325) + ## 1.4.37 * Add `setWeakEtag` function in Yesod.Core.Handler module. diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 94dd27dc..b393a641 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -1079,7 +1079,7 @@ getMessageRender :: (MonadHandler m, RenderMessage (HandlerSite m) message) => m (message -> Text) getMessageRender = do env <- askHandlerEnv - l <- reqLangs <$> getRequest + l <- languages return $ renderMessage (rheSite env) l -- | Use a per-request cache to avoid performing the same action multiple times. @@ -1130,15 +1130,15 @@ cachedBy k action = do -- | Get the list of supported languages supplied by the user. -- --- Languages are determined based on the following three (in descending order +-- Languages are determined based on the following (in descending order -- of preference): -- +-- * The _LANG user session variable. +-- -- * The _LANG get parameter. -- -- * The _LANG cookie. -- --- * The _LANG user session variable. --- -- * Accept-Language HTTP header. -- -- Yesod will seek the first language from the returned list matched with languages supporting by your application. This language will be used to render i18n templates. diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 80794eb3..859b391a 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.37 +version: 1.4.37.1 license: MIT license-file: LICENSE author: Michael Snoyman From 6d6afcf8261f39b7de2c30381a1555afe345ffd3 Mon Sep 17 00:00:00 2001 From: Josh Berman Date: Sun, 26 Nov 2017 12:09:17 +0200 Subject: [PATCH 123/124] point changelog to PR not issue --- yesod-core/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 85a3e3ad..b24dc010 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,5 @@ ## 1.4.37.1 -* Fix documentation on `languages` function, update `getMessageRender` to use said function. [1325] (https://github.com/yesodweb/yesod/issues/1325) +* Fix documentation on `languages` function, update `getMessageRender` to use said function. [#1457] (https://github.com/yesodweb/yesod/pull/1457) ## 1.4.37 From 1275cce1af983e20f6015ac7e201d3a8783d0329 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Thu, 16 Nov 2017 23:03:16 -0800 Subject: [PATCH 124/124] Give better error messages when CSRF validation fails * This is important because historically these errors have tripped people up * Making security as easy as possible is important so that it doesn't just get turned off * Giving clear directions about where to get the CSRF token (a cookie) and where to send it (a header/param) is especially helpful to frontend developers not necessarily familiar with the backend codebase --- yesod-core/ChangeLog.md | 7 +++- yesod-core/Yesod/Core/Handler.hs | 59 ++++++++++++++++++++++++-------- yesod-core/yesod-core.cabal | 2 +- 3 files changed, 51 insertions(+), 17 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index b24dc010..43266e77 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,10 @@ +## 1.4.37.2 + +* Improve error messages for the CSRF checking functions [#1455](https://github.com/yesodweb/yesod/issues/1455) + ## 1.4.37.1 -* Fix documentation on `languages` function, update `getMessageRender` to use said function. [#1457] (https://github.com/yesodweb/yesod/pull/1457) + +* Fix documentation on `languages` function, update `getMessageRender` to use said function. [#1457](https://github.com/yesodweb/yesod/pull/1457) ## 1.4.37 diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index b393a641..9a340803 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -242,7 +242,7 @@ import Yesod.Core.Types import Yesod.Routes.Class (Route) import Blaze.ByteString.Builder (Builder) import Safe (headMay) -import Data.CaseInsensitive (CI) +import Data.CaseInsensitive (CI, original) import qualified Data.Conduit.List as CL import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO) import qualified System.PosixCompat.Files as PC @@ -1501,18 +1501,22 @@ defaultCsrfHeaderName = "X-XSRF-TOKEN" -- @since 1.4.14 checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m () checkCsrfHeaderNamed headerName = do - valid <- hasValidCsrfHeaderNamed headerName - unless valid (permissionDenied csrfErrorMessage) + (valid, mHeader) <- hasValidCsrfHeaderNamed' headerName + unless valid (permissionDenied $ csrfErrorMessage [CSRFHeader (decodeUtf8 $ original headerName) mHeader]) -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- -- @since 1.4.14 hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool -hasValidCsrfHeaderNamed headerName = do +hasValidCsrfHeaderNamed headerName = fst <$> hasValidCsrfHeaderNamed' headerName + +-- | Like 'hasValidCsrfHeaderNamed', but also returns the header value to be used in error messages. +hasValidCsrfHeaderNamed' :: MonadHandler m => CI S8.ByteString -> m (Bool, Maybe Text) +hasValidCsrfHeaderNamed' headerName = do mCsrfToken <- reqToken <$> getRequest mXsrfHeader <- lookupHeader headerName - return $ validCsrf mCsrfToken mXsrfHeader + return $ (validCsrf mCsrfToken mXsrfHeader, decodeUtf8 <$> mXsrfHeader) -- CSRF Parameter checking @@ -1528,18 +1532,22 @@ defaultCsrfParamName = "_token" -- @since 1.4.14 checkCsrfParamNamed :: MonadHandler m => Text -> m () checkCsrfParamNamed paramName = do - valid <- hasValidCsrfParamNamed paramName - unless valid (permissionDenied csrfErrorMessage) + (valid, mParam) <- hasValidCsrfParamNamed' paramName + unless valid (permissionDenied $ csrfErrorMessage [CSRFParam paramName mParam]) -- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- -- @since 1.4.14 hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool -hasValidCsrfParamNamed paramName = do +hasValidCsrfParamNamed paramName = fst <$> hasValidCsrfParamNamed' paramName + +-- | Like 'hasValidCsrfParamNamed', but also returns the param value to be used in error messages. +hasValidCsrfParamNamed' :: MonadHandler m => Text -> m (Bool, Maybe Text) +hasValidCsrfParamNamed' paramName = do mCsrfToken <- reqToken <$> getRequest mCsrfParam <- lookupPostParam paramName - return $ validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam) + return $ (validCsrf mCsrfToken (encodeUtf8 <$> mCsrfParam), mCsrfParam) -- | Checks that a valid CSRF token is present in either the request headers or POST parameters. -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error. @@ -1550,11 +1558,12 @@ checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m) -> Text -- ^ The POST parameter name to lookup the CSRF token -> m () checkCsrfHeaderOrParam headerName paramName = do - validHeader <- hasValidCsrfHeaderNamed headerName - validParam <- hasValidCsrfParamNamed paramName + (validHeader, mHeader) <- hasValidCsrfHeaderNamed' headerName + (validParam, mParam) <- hasValidCsrfParamNamed' paramName unless (validHeader || validParam) $ do - $logWarnS "yesod-core" csrfErrorMessage - permissionDenied csrfErrorMessage + let errorMessage = csrfErrorMessage $ [CSRFHeader (decodeUtf8 $ original headerName) mHeader, CSRFParam paramName mParam] + $logWarnS "yesod-core" errorMessage + permissionDenied errorMessage validCsrf :: Maybe Text -> Maybe S.ByteString -> Bool -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks. @@ -1562,5 +1571,25 @@ validCsrf (Just token) (Just param) = encodeUtf8 token `constEqBytes` param validCsrf Nothing _param = True validCsrf (Just _token) Nothing = False -csrfErrorMessage :: Text -csrfErrorMessage = "A valid CSRF token wasn't present in HTTP headers or POST parameters. Because the request could have been forged, it's been rejected altogether. Check the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection." +data CSRFExpectation = CSRFHeader Text (Maybe Text) -- Key/Value + | CSRFParam Text (Maybe Text) -- Key/Value + +csrfErrorMessage :: [CSRFExpectation] + -> Text -- ^ Error message +csrfErrorMessage expectedLocations = T.intercalate "\n" + [ "A valid CSRF token wasn't present. Because the request could have been forged, it's been rejected altogether." + , "If you're a developer of this site, these tips will help you debug the issue:" + , "- Read the Yesod.Core.Handler docs of the yesod-core package for details on CSRF protection." + , "- Check that your HTTP client is persisting cookies between requests, like a browser does." + , "- By default, the CSRF token is sent to the client in a cookie named " `mappend` (decodeUtf8 defaultCsrfCookieName) `mappend` "." + , "- The server is looking for the token in the following locations:\n" `mappend` T.intercalate "\n" (map csrfLocation expectedLocations) + ] + + where csrfLocation expected = case expected of + CSRFHeader k v -> T.intercalate " " [" - An HTTP header named", k, (formatValue v)] + CSRFParam k v -> T.intercalate " " [" - A POST parameter named", k, (formatValue v)] + + formatValue :: Maybe Text -> Text + formatValue maybeText = case maybeText of + Nothing -> "(which is not currently set)" + Just t -> T.concat ["(which has the current, incorrect value: '", t, "')"] diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 859b391a..c1d6f8a8 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.37.1 +version: 1.4.37.2 license: MIT license-file: LICENSE author: Michael Snoyman