diff --git a/.envrc b/.envrc new file mode 100644 index 00000000..3550a30f --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index 1bf32d17..c328b031 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -21,6 +21,8 @@ jobs: - "--resolver lts-12" - "--resolver lts-11" - "--stack-yaml stack-persistent-211.yaml" + - "--stack-yaml stack-persistent-212.yaml" + - "--stack-yaml stack-persistent-213.yaml" # Bugs in GHC make it crash too often to be worth running exclude: - os: windows-latest @@ -29,6 +31,8 @@ jobs: args: "--resolver lts-16" - os: windows-latest args: "--stack-yaml stack-persistent-211.yaml" + - os: windows-latest + args: "--stack-yaml stack-persistent-212.yaml" steps: - name: Clone project diff --git a/.gitignore b/.gitignore index 42e81982..8f84fbea 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ tarballs/ # OS X .DS_Store +*.yaml.lock diff --git a/demo/subsite/WikiRoutes.hs b/demo/subsite/WikiRoutes.hs index f22c0222..0e340449 100644 --- a/demo/subsite/WikiRoutes.hs +++ b/demo/subsite/WikiRoutes.hs @@ -21,7 +21,7 @@ data Wiki = Wiki } -- | A typeclass that all master sites that want a Wiki must implement. A --- master must be able to render form messages, as we use yesod-forms for +-- master must be able to render form messages, as we use yesod-form for -- processing user input. class (RenderMessage master FormMessage, Yesod master) => YesodWiki master where -- | Write protection. By default, no protection. diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..b486ac53 --- /dev/null +++ b/flake.lock @@ -0,0 +1,44 @@ +{ + "nodes": { + "flake-utils": { + "locked": { + "lastModified": 1619345332, + "narHash": "sha256-qHnQkEp1uklKTpx3MvKtY6xzgcqXDsz5nLilbbuL+3A=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "2ebf2558e5bf978c7fb8ea927dfaed8fefab2e28", + "type": "github" + }, + "original": { + "owner": "numtide", + "ref": "master", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1620323686, + "narHash": "sha256-+gfcE3YTGl+Osc8HzOUXSFO8/0PAK4J8ZxCXZ4hjXHI=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "dfacb8329b2236688b9a1e705116203a213b283a", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "master", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..c0b67a5f --- /dev/null +++ b/flake.nix @@ -0,0 +1,30 @@ +{ + inputs = { + nixpkgs = { + type = "github"; + owner = "NixOS"; + repo = "nixpkgs"; + ref = "master"; + }; + flake-utils = { + type = "github"; + owner = "numtide"; + repo = "flake-utils"; + ref = "master"; + }; + }; + + outputs = { self, nixpkgs, flake-utils, ... }: flake-utils.lib.eachDefaultSystem + (system: + let pkgs = import nixpkgs { + inherit system; + config.allowUnfree = true; + }; + in { + devShell = pkgs.mkShell { + name = "uni2work-yesod"; + nativeBuildInputs = with pkgs.haskellPackages; [ stack ]; + }; + } + ); +} diff --git a/nixpkgs.nix b/nixpkgs.nix new file mode 100644 index 00000000..4492a1c3 --- /dev/null +++ b/nixpkgs.nix @@ -0,0 +1,8 @@ +import ( + let + lock = builtins.fromJSON (builtins.readFile ./flake.lock); + in fetchTarball { + url = "https://api.github.com/repos/NixOS/nixpkgs/tarball/${lock.nodes.nixpkgs.locked.rev}"; + sha256 = lock.nodes.nixpkgs.locked.narHash; + } +) diff --git a/stack-persistent-212.yaml b/stack-persistent-212.yaml new file mode 100644 index 00000000..b4087765 --- /dev/null +++ b/stack-persistent-212.yaml @@ -0,0 +1,20 @@ +resolver: nightly-2021-03-31 +packages: +- ./yesod-core +- ./yesod-static +- ./yesod-persistent +- ./yesod-newsfeed +- ./yesod-form +- ./yesod-form-multi +- ./yesod-auth +- ./yesod-auth-oauth +- ./yesod-sitemap +- ./yesod-test +- ./yesod-bin +- ./yesod +- ./yesod-eventsource +- ./yesod-websockets +extra-deps: +- persistent-2.12.0.1 +- persistent-template-2.12.0.0 +- persistent-sqlite-2.12.0.0 diff --git a/stack-persistent-213.yaml b/stack-persistent-213.yaml new file mode 100644 index 00000000..c90d12e7 --- /dev/null +++ b/stack-persistent-213.yaml @@ -0,0 +1,23 @@ +resolver: nightly-2021-03-31 +packages: +- ./yesod-core +- ./yesod-static +- ./yesod-persistent +- ./yesod-newsfeed +- ./yesod-form +- ./yesod-form-multi +- ./yesod-auth +- ./yesod-auth-oauth +- ./yesod-sitemap +- ./yesod-test +- ./yesod-bin +- ./yesod +- ./yesod-eventsource +- ./yesod-websockets +extra-deps: +- lift-type-0.1.0.1 +- persistent-2.13.0.0 +- persistent-mysql-2.13.0.0 +- persistent-sqlite-2.13.0.0 +- persistent-postgresql-2.13.0.0 +- persistent-template-2.12.0.0 diff --git a/stack.nix b/stack.nix new file mode 100644 index 00000000..7e0942a5 --- /dev/null +++ b/stack.nix @@ -0,0 +1,14 @@ +{ ghc, nixpkgs ? import ./nixpkgs.nix }: + +let + # haskellPackages = import ./stackage.nix { inherit nixpkgs; }; + haskellPackages = pkgs.haskellPackages; + inherit (nixpkgs {}) pkgs; +in pkgs.haskell.lib.buildStackProject { + inherit ghc; + inherit (haskellPackages) stack; + name = "stackenv"; + buildInputs = with pkgs; + [ zlib + ]; +} diff --git a/stack.yaml b/stack.yaml index ae4dc8e1..01942d7b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,10 @@ nix: - packages: [zlib] + packages: [] + pure: false + shell-file: ./stack.nix + add-gc-roots: true -resolver: lts-15.5 +resolver: lts-16.31 packages: - ./yesod-core - ./yesod-static diff --git a/stack.yaml.lock b/stack.yaml.lock index b90ed2d5..c2221907 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 491372 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml - sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc - original: lts-15.5 + size: 534126 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 + original: lts-16.31 diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md index b7047210..9d5d5dbb 100644 --- a/yesod-auth-oauth/ChangeLog.md +++ b/yesod-auth-oauth/ChangeLog.md @@ -1,3 +1,9 @@ +# ChangeLog for yesod-auth-oauth + +## 1.6.0.3 + +* Allow yesod-form 1.7 + ## 1.6.0.2 * Remove unnecessary deriving of Typeable diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 8c1ee7f4..4d0faa5e 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-auth-oauth -version: 1.6.0.2 +version: 1.6.0.3 license: BSD3 license-file: LICENSE author: Hiromi Ishii @@ -22,7 +22,7 @@ library , unliftio , yesod-auth >= 1.6 && < 1.7 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 exposed-modules: Yesod.Auth.OAuth ghc-options: -Wall diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index fb9d5391..df6b5ab2 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,5 +1,13 @@ # ChangeLog for yesod-auth +## 1.6.10.3 + +* Relax bounds for yesod-form 1.7 + +## 1.6.10.2 + +* Relax bounds for persistent 2.12 + ## 1.6.10.1 * Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701) diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 21d24b18..18d30a8c 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: yesod-auth -version: 1.6.10.1 +version: 1.6.10.3 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -44,7 +44,7 @@ library , http-types , memory , nonce >= 1.0.2 && < 1.1 - , persistent >= 2.8 && < 2.12 + , persistent >= 2.8 , random >= 1.0.0.2 , safe , shakespeare @@ -57,7 +57,7 @@ library , unordered-containers , wai >= 1.4 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 , yesod-persistent >= 1.6 if flag(network-uri) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 80eac463..7fb76193 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,22 @@ # ChangeLog for yesod-core +## 1.6.20.2 + +* Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729) + +## 1.6.20.1 + +* Throw an error in `breadcrumbs` if the trail of breadcrumbs is circular. [#1727](https://github.com/yesodweb/yesod/issues/1727) + +## 1.6.20 + +* Generate CSRF tokens using a secure entropy source [#1726](https://github.com/yesodweb/yesod/pull/1726) +* Change semantics of `yreGen` and `defaultGen` + +## 1.6.19.0 + +* Change order of priority in `languages`[#1721](https://github.com/yesodweb/yesod/pull/1721) + ## 1.6.18.8 * Fix test suite for wai-extra change around vary header diff --git a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs index 1e956ff2..9773af1d 100644 --- a/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs +++ b/yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} module Yesod.Core.Class.Breadcrumbs where import Yesod.Core.Handler @@ -15,7 +16,7 @@ class YesodBreadcrumbs site where -- | Gets the title of the current page and the hierarchy of parent pages, -- along with their respective titles. -breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)]) +breadcrumbs :: (YesodBreadcrumbs site, Show (Route site), Eq (Route site)) => HandlerFor site (Text, [(Route site, Text)]) breadcrumbs = do x <- getCurrentRoute case x of @@ -26,6 +27,8 @@ breadcrumbs = do return (title, z) where go back Nothing = return back - go back (Just this) = do - (title, next) <- breadcrumb this - go ((this, title) : back) next + go back (Just this) + | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this + | otherwise = do + (title, next) <- breadcrumb this + go ((this, title) : back) next diff --git a/yesod-core/src/Yesod/Core/Dispatch.hs b/yesod-core/src/Yesod/Core/Dispatch.hs index 60779532..8a2501e6 100644 --- a/yesod-core/src/Yesod/Core/Dispatch.hs +++ b/yesod-core/src/Yesod/Core/Dispatch.hs @@ -46,6 +46,7 @@ import qualified Network.Wai as W import Data.ByteString.Lazy.Char8 () +import Data.Bits ((.|.), finiteBitSize, shiftL) import Data.Text (Text) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as BL @@ -59,7 +60,7 @@ import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run import Text.Read (readMaybe) import System.Environment (getEnvironment) -import qualified System.Random as Random +import System.Entropy (getEntropy) import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) @@ -92,8 +93,19 @@ toWaiAppPlain site = do , yreGetMaxExpires = getMaxExpires } +-- | Generate a random number uniformly distributed in the full range +-- of 'Int'. +-- +-- Note: Before 1.6.20, this generates pseudo-random number in an +-- unspecified range. The range size may not be a power of 2. Since +-- 1.6.20, this uses a secure entropy source and generates in the full +-- range of 'Int'. defaultGen :: IO Int -defaultGen = Random.getStdRandom Random.next +defaultGen = bsToInt <$> getEntropy bytes + where + bits = finiteBitSize (undefined :: Int) + bytes = div (bits + 7) 8 + bsToInt = S.foldl' (\v i -> shiftL v 8 .|. fromIntegral i) 0 -- | Pure low level function to construct WAI application. Usefull -- when you need not standard way to run your app, or want to embed it diff --git a/yesod-core/src/Yesod/Core/Handler.hs b/yesod-core/src/Yesod/Core/Handler.hs index 9e9c3823..191cf5fd 100644 --- a/yesod-core/src/Yesod/Core/Handler.hs +++ b/yesod-core/src/Yesod/Core/Handler.hs @@ -1226,10 +1226,10 @@ cacheBySet key value = do -- Languages are determined based on the following (in descending order -- of preference): -- --- * The _LANG user session variable. --- -- * The _LANG get parameter. -- +-- * The _LANG user session variable. +-- -- * The _LANG cookie. -- -- * Accept-Language HTTP header. @@ -1238,11 +1238,12 @@ cacheBySet key value = do -- If a matching language is not found the default language will be used. -- -- This is handled by parseWaiRequest (not exposed). +-- +-- __NOTE__: Before version @1.6.19.0@, this function prioritized the session +-- variable above all other sources. +-- languages :: MonadHandler m => m [Text] -languages = do - mlang <- lookupSession langKey - langs <- reqLangs <$> getRequest - return $ maybe id (:) mlang langs +languages = reqLangs <$> getRequest lookup' :: Eq a => a -> [(a, b)] -> [b] lookup' a = map snd . filter (\x -> a == fst x) diff --git a/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs index f3505b91..11bbf90b 100644 --- a/yesod-core/src/Yesod/Core/Internal/TH.hs +++ b/yesod-core/src/Yesod/Core/Internal/TH.hs @@ -107,9 +107,9 @@ mkYesodDispatch name = fmap snd . mkYesodWithParser name False return -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself? masterTypeSyns vs site = - [ TySynD (mkName "Handler") (fmap PlainTV vs) + [ TySynD (mkName "Handler") (fmap plainTV vs) $ ConT ''HandlerFor `AppT` site - , TySynD (mkName "Widget") (fmap PlainTV vs) + , TySynD (mkName "Widget") (fmap plainTV vs) $ ConT ''WidgetFor `AppT` site `AppT` ConT ''() ] diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index a33a4f5c..11a55f1a 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -196,7 +196,13 @@ data YesodRunnerEnv site = YesodRunnerEnv , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) , yreGen :: !(IO Int) - -- ^ Generate a random number + -- ^ Generate a random number uniformly distributed in the full + -- range of 'Int'. + -- + -- Note: Before 1.6.20, the default value generates pseudo-random + -- number in an unspecified range. The range size may not be a power + -- of 2. Since 1.6.20, the default value uses a secure entropy source + -- and generates in the full range of 'Int'. , yreGetMaxExpires :: !(IO Text) } diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index e9f42851..591f86a7 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -12,6 +12,7 @@ import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache import YesodCoreTest.ParameterizedSite +import YesodCoreTest.Breadcrumb import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader @@ -61,3 +62,4 @@ specs = do Ssl.sslOnlySpec Ssl.sameSiteSpec Csrf.csrfSpec + breadcrumbTest diff --git a/yesod-core/test/YesodCoreTest/Breadcrumb.hs b/yesod-core/test/YesodCoreTest/Breadcrumb.hs new file mode 100644 index 00000000..c64cfa25 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Breadcrumb.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module YesodCoreTest.Breadcrumb + ( breadcrumbTest, + ) +where + +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Text (Text) +import Data.Typeable (Typeable) +import Network.Wai +import Network.Wai.Test +import Test.Hspec +import UnliftIO.IORef +import Yesod.Core + +data A = A + +mkYesod + "A" + [parseRoutes| +/ RootR GET +/loop LoopR GET +|] + +instance Yesod A + +instance YesodBreadcrumbs A where + breadcrumb r = case r of + RootR -> pure ("Root", Nothing) + LoopR -> pure ("Loop", Just LoopR) -- Purposefully a loop + +getRootR :: Handler Text +getRootR = fst <$> breadcrumbs + +getLoopR :: Handler Text +getLoopR = fst <$> breadcrumbs + +breadcrumbTest :: Spec +breadcrumbTest = + describe "Test.Breadcrumb" $ do + it "can fetch the root which contains breadcrumbs" $ + runner $ do + res <- request defaultRequest + assertStatus 200 res + it "gets a 500 for a route with a looping breadcrumb" $ + runner $ do + res <- request defaultRequest {pathInfo = ["loop"]} + assertStatus 500 res + +runner :: Session () -> IO () +runner f = toWaiApp A >>= runSession f diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 685b95e5..0e3799d5 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.18.8 +version: 1.6.20.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -39,6 +39,7 @@ library , containers >= 0.2 , cookie >= 0.4.3 && < 0.5 , deepseq >= 1.3 + , entropy , fast-logger >= 2.2 , http-types >= 0.7 , memory diff --git a/yesod-form-multi/ChangeLog.md b/yesod-form-multi/ChangeLog.md index 737cd3af..046bb930 100644 --- a/yesod-form-multi/ChangeLog.md +++ b/yesod-form-multi/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog +## 1.7.0.2 + +* Allow yesod-form 1.7 + ## 1.7.0.1 [#1716](https://github.com/yesodweb/yesod/pull/1716) @@ -23,4 +27,4 @@ [#1601](https://github.com/yesodweb/yesod/pull/1601) -* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field \ No newline at end of file +* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field diff --git a/yesod-form-multi/yesod-form-multi.cabal b/yesod-form-multi/yesod-form-multi.cabal index 7e576ead..8588c106 100644 --- a/yesod-form-multi/yesod-form-multi.cabal +++ b/yesod-form-multi/yesod-form-multi.cabal @@ -1,5 +1,5 @@ name: yesod-form-multi -version: 1.7.0.1 +version: 1.7.0.2 license: MIT license-file: LICENSE author: James Burton @@ -26,7 +26,7 @@ library , text >= 0.9 , transformers >= 0.2.2 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 if flag(network-uri) build-depends: network-uri >= 2.6 diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index c38a49dc..5d37f2f8 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-form +## 1.7.0 + +* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`@ tag for selecting one option. Example usage: +-- | Creates a @\@ tag with optional @\@s for selecting one option. Example usage: -- -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing selectField :: (Eq a, RenderMessage site FormMessage) @@ -446,6 +458,9 @@ $newline never $newline never +|]) -- group label -- | Creates a @\ \#{text} |]) + Nothing -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction. -- @@ -598,15 +614,31 @@ $newline never showVal = either (\_ -> False) -- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly. -data OptionList a = OptionList +-- +-- Extended by 'OptionListGrouped' in 1.7.0. +data OptionList a + = OptionList { olOptions :: [Option a] , olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue'). } + | OptionListGrouped + { olOptionsGrouped :: [(Text, [Option a])] + , olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue'). + } --- | Since 1.4.6 +-- | Convert grouped 'OptionList' to a normal one. +-- +-- @since 1.7.0 +flattenOptionList :: OptionList a -> OptionList a +flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re +flattenOptionList ol = ol + +-- | @since 1.4.6 instance Functor OptionList where - fmap f (OptionList options readExternal) = + fmap f (OptionList options readExternal) = OptionList ((fmap.fmap) f options) (fmap f . readExternal) + fmap f (OptionListGrouped options readExternal) = + OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal) -- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function. mkOptionList :: [Option a] -> OptionList a @@ -615,13 +647,22 @@ mkOptionList os = OptionList , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os } +-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function. +-- +-- @since 1.7.0 +mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a +mkOptionListGrouped os = OptionListGrouped + { olOptionsGrouped = os + , olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os + } + data Option a = Option { optionDisplay :: Text -- ^ The user-facing label. , optionInternalValue :: a -- ^ The Haskell value being selected. , optionExternalValue :: Text -- ^ The representation of this value stored in the form. } --- | Since 1.4.6 +-- | @since 1.4.6 instance Functor Option where fmap f (Option display internal external) = Option display (f internal) external @@ -637,6 +678,30 @@ optionsPairs opts = do } return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) +-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs. +-- +-- @since 1.7.0 +optionsPairsGrouped + :: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg) + => [(msg, [(msg, a)])] -> m (OptionList a) +optionsPairsGrouped opts = do + mr <- getMessageRender + let mkOption (external, (display, internal)) = + Option { optionDisplay = mr display + , optionInternalValue = internal + , optionExternalValue = pack $ show external + } + opts' = enumerateSublists opts :: [(msg, [(Int, (msg, a))])] + opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts' + return $ mkOptionListGrouped opts'' + +-- | Helper to enumerate sublists with one consecutive index. +enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])] +enumerateSublists xss = + let yss :: [(Int, (a, [b]))] + yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss + in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss + -- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value. optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] @@ -692,7 +757,7 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do -- | An alternative to 'optionsPersist' which returns just the 'Key' instead of -- the entire 'Entity'. -- --- Since 1.3.2 +-- @since 1.3.2 #if MIN_VERSION_persistent(2,5,0) optionsPersistKey :: (YesodPersist site @@ -731,7 +796,7 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do }) pairs -- | --- A helper function for constucting 'selectField's. You may want to use this when you define your custom 'selectField's or 'radioField's. +-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's. -- -- @since 1.6.2 selectFieldHelper @@ -739,23 +804,26 @@ selectFieldHelper => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options + -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options -> HandlerFor site (OptionList a) -> Field (HandlerFor site) a -selectFieldHelper outside onOpt inside opts' = Field +selectFieldHelper outside onOpt inside grpHdr opts' = Field { fieldParse = \x _ -> do - opts <- opts' + opts <- fmap flattenOptionList opts' return $ selectParser opts x , fieldView = \theId name attrs val isReq -> do - opts <- fmap olOptions $ handlerToWidget opts' outside theId name attrs $ do - unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts - flip mapM_ opts $ \opt -> inside - theId - name - ((if isReq then (("required", "required"):) else id) attrs) - (optionExternalValue opt) - ((render opts val) == optionExternalValue opt) - (optionDisplay opt) + optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts' + unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat + opts'' <- handlerToWidget opts' + case opts'' of + OptionList{} -> constructOptions theId name attrs val isReq optsFlat + OptionListGrouped{olOptionsGrouped=grps} -> do + forM_ grps $ \(grp, opts) -> do + case grpHdr of + Just hdr -> hdr grp + Nothing -> return () + constructOptions theId name attrs val isReq opts , fieldEnctype = UrlEncoded } where @@ -768,6 +836,14 @@ selectFieldHelper outside onOpt inside opts' = Field x -> case olReadExternal opts x of Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Just y -> Right $ Just y + constructOptions theId name attrs val isReq opts = + forM_ opts $ \opt -> inside + theId + name + ((if isReq then (("required", "required"):) else id) attrs) + (optionExternalValue opt) + (render opts val == optionExternalValue opt) + (optionDisplay opt) -- | Creates an input with @type="file"@. fileField :: Monad m @@ -864,7 +940,7 @@ prependZero t0 = if T.null t1 then "-0." `T.append` (T.drop 2 t1) else t1 - where t1 = T.dropWhile ((==) ' ') t0 + where t1 = T.dropWhile (==' ') t0 -- $optionsOverview -- These functions create inputs where one or more options can be selected from a list. diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index c66cd7b0..dc33cbf0 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,6 @@ +cabal-version: >= 1.10 name: yesod-form -version: 1.6.7 +version: 1.7.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -7,7 +8,6 @@ maintainer: Michael Snoyman synopsis: Form handling support for Yesod Web Framework category: Web, Yesod stability: Stable -cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/ description: API docs and the README are available at . Third-party packages which you can find useful: - richtext form fields (currntly it provides only Summernote support). @@ -19,6 +19,7 @@ flag network-uri default: True library + default-language: Haskell2010 build-depends: base >= 4.10 && < 5 , aeson , attoparsec >= 0.10 @@ -70,6 +71,7 @@ library ghc-options: -Wall test-suite test + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index 1aaa6c63..52286010 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -1,5 +1,13 @@ # ChangeLog for yesod-persistent +## 1.6.0.7 + +* Add support for persistent 2.13. [#1723](https://github.com/yesodweb/yesod/pull/1723) + +## 1.6.0.6 + +* Add support for persistent 2.12 + ## 1.6.0.5 * Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701) diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 2e450366..6a671ca7 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -25,6 +25,7 @@ module Yesod.Persist.Core import Database.Persist import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Data.Foldable (toList) import Yesod.Core import Data.Conduit import Blaze.ByteString.Builder (Builder) @@ -33,6 +34,9 @@ import Control.Monad.Trans.Resource import Control.Exception (throwIO) import Yesod.Core.Types (HandlerContents (HCError)) import qualified Database.Persist.Sql as SQL +#if MIN_VERSION_persistent(2,13,0) +import qualified Database.Persist.SqlBackend.Internal as SQL +#endif unSqlPersistT :: a -> a unSqlPersistT = id @@ -196,7 +200,15 @@ insert400 datum = do conflict <- checkUnique datum case conflict of Just unique -> +#if MIN_VERSION_persistent(2, 12, 0) +-- toList is called here because persistent-2.13 changed this +-- to a nonempty list. for versions of persistent prior to 2.13, toList +-- will be a no-op. for persistent-2.13, it'll convert the NonEmptyList to +-- a List. + badRequest' $ map (unFieldNameHS . fst) $ toList $ persistUniqueToFieldNames unique +#else badRequest' $ map (unHaskellName . fst) $ persistUniqueToFieldNames unique +#endif Nothing -> insert datum -- | Same as 'insert400', but doesn’t return a key. diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index fb50543d..b9ca9fff 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-persistent -version: 1.6.0.5 +version: 1.6.0.7 license: MIT license-file: LICENSE author: Michael Snoyman @@ -17,8 +17,8 @@ library default-language: Haskell2010 build-depends: base >= 4.10 && < 5 , yesod-core >= 1.6 && < 1.7 - , persistent >= 2.8 && < 2.12 - , persistent-template >= 2.1 && < 2.10 + , persistent >= 2.8 + , persistent-template >= 2.1 , transformers >= 0.2.2 , blaze-builder , conduit diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 04b9bbf8..8294bbbc 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.10 +cabal-version: >=1.10 name: yesod-websockets version: 0.3.0.3 synopsis: WebSockets support for Yesod diff --git a/yesod/ChangeLog.md b/yesod/ChangeLog.md index 42a429e2..dd2fe0b0 100644 --- a/yesod/ChangeLog.md +++ b/yesod/ChangeLog.md @@ -1,3 +1,9 @@ +# ChangeLog for yesod + +## 1.6.1.1 + +* Allow yesod-form 1.7 + ## 1.6.1.0 * `widgetFileReload` and `widgetFileNoReload` now use absolute paths via the new `globFilePackage` Q Exp which can provide absolute templates paths within the project [#1691](https://github.com/yesodweb/yesod/pull/1691) diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 42e36729..2b0ef5b8 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.6.1.0 +version: 1.6.1.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -38,7 +38,7 @@ library , warp >= 1.3 , yaml >= 0.8.17 , yesod-core >= 1.6 && < 1.7 - , yesod-form >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.8 , yesod-persistent >= 1.6 && < 1.7 exposed-modules: Yesod