Merge branch 'master' into uni2work

.envrc

@@ -0,0 +1 @@
+use flake

.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

.gitignore

@@ -25,3 +25,4 @@ tarballs/
 
 # OS X
 .DS_Store
+*.yaml.lock

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.

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
+}

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 ];
+        };
+      }
+    );
+}

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;
+  }
+)

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

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

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
+    ];
+}

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

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 491372
+    size: 534126
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/5.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml
-    sha256: 1b549cfff328040c382a70a84a2087aac8dab6d778bf92f32a93a771a1980dfc
+    sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6
-  original: lts-15.5
+  original: lts-16.31

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

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
 

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)

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)

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

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
+    go back (Just this)
-        (title, next) <- breadcrumb this
+      | this `elem` map fst back = error $ "yesod-core: infinite recursion in breadcrumbs at " ++ show this
-        go ((this, title) : back) next
+      | otherwise = do
+          (title, next) <- breadcrumb this
+          go ((this, title) : back) next

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

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
+languages = reqLangs <$> getRequest
-    mlang <- lookupSession langKey
-    langs <- reqLangs <$> getRequest
-    return $ maybe id (:) mlang langs
 
 lookup' :: Eq a => a -> [(a, b)] -> [b]
 lookup' a = map snd . filter (\x -> a == fst x)

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 ''()
     ]
 

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

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

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

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 <michael@snoyman.com>
@@ -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

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
+* Added `Yesod.Form.MultiInput` which supports multi-input forms without needing to submit the form to add an input field

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 <jamesejburton@gmail.com>
@@ -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

yesod-form/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-form
 
+## 1.7.0
+
+* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`<select>` with `<optgroup>`) [#1722](https://github.com/yesodweb/yesod/pull/1722)
+
 ## 1.6.7
 
 * Added equivalent version of `mreqMsg` for `areq` and `wreq` correspondingly [#1628](https://github.com/yesodweb/yesod/pull/1628)

yesod-form/README.md

@@ -3,7 +3,7 @@
 Form handling for Yesod, in the same style as formlets. See [the forms
 chapter](http://www.yesodweb.com/book/forms) of the Yesod book.
 
-This package provies a set of basic form inputs such as text, number, time,
+This package provides a set of basic form inputs such as text, number, time,
 checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module.  Also,
 there is `Yesod.Form.Nic` module providing richtext field using Nic editor.
 However, this module is grandfathered now and Nic editor is not actively

yesod-form/Yesod/Form/Fields.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 -- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.
@@ -45,6 +46,7 @@ module Yesod.Form.Fields
     , selectFieldHelper
     , selectField
     , selectFieldList
+    , selectFieldListGrouped
     , radioField
     , radioFieldList
     , checkboxesField
@@ -54,9 +56,11 @@ module Yesod.Form.Fields
     , Option (..)
     , OptionList (..)
     , mkOptionList
+    , mkOptionListGrouped
     , optionsPersist
     , optionsPersistKey
     , optionsPairs
+    , optionsPairsGrouped
     , optionsEnum
     ) where
 
@@ -80,7 +84,7 @@ import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend,
 import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)
 #endif
 import Text.HTML.SanitizeXSS (sanitizeBalance)
-import Control.Monad (when, unless)
+import Control.Monad (when, unless, forM_)
 import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
@@ -172,7 +176,7 @@ timeField = timeFieldTypeTime
 -- 
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- Since 1.4.2
+-- @since 1.4.2
 timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay  
 timeFieldTypeTime = timeFieldOfType "time"
 
@@ -182,7 +186,7 @@ timeFieldTypeTime = timeFieldOfType "time"
 -- 
 -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
 --
--- Since 1.4.2
+-- @since 1.4.2
 timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
 timeFieldTypeText = timeFieldOfType "text"
 
@@ -362,7 +366,7 @@ $newline never
 
 -- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.
 --
--- Since 1.3.7
+-- @since 1.3.7
 multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
 multiEmailField = Field
     { fieldParse = parseHelper $
@@ -427,7 +431,15 @@ selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg
                 -> Field (HandlerFor site) a
 selectFieldList = selectField . optionsPairs
 
--- | Creates a @\<select>@ tag for selecting one option. Example usage:
+-- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.
+--
+-- @since 1.7.0
+selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
+                => [(msg, [(msg, a)])]
+                -> Field (HandlerFor site) a
+selectFieldListGrouped = selectField . optionsPairsGrouped
+
+-- | Creates a @\<select>@ tag with optional @\<optgroup>@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
 <option value=#{value} :isSel:selected>#{text}
 |]) -- inside
+    (Just $ \label -> [whamlet|
+<optgroup label=#{label}>
+|]) -- group label
 
 -- | Creates a @\<select>@ tag for selecting multiple options.
 multiSelectFieldList :: (Eq a, RenderMessage site msg)
@@ -531,6 +546,7 @@ $newline never
         <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>
         \#{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
+          optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'
-            flip mapM_ opts $ \opt -> inside
+          unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat
-                theId
+          opts'' <- handlerToWidget opts'
-                name
+          case opts'' of
-                ((if isReq then (("required", "required"):) else id) attrs)
+            OptionList{} -> constructOptions theId name attrs val isReq optsFlat
-                (optionExternalValue opt)
+            OptionListGrouped{olOptionsGrouped=grps} -> do
-                ((render opts val) == optionExternalValue opt)
+                  forM_ grps $ \(grp, opts) -> do
-                (optionDisplay opt)
+                    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.

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 <michael@snoyman.com>
@@ -7,7 +8,6 @@ maintainer:      Michael Snoyman <michael@snoyman.com>
 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 <http://www.stackage.org/package/yesod-form>.  Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - 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

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)

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.

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 <michael@snoyman.com>
@@ -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                >= 2.8
-                   , persistent-template       >= 2.1      && < 2.10
+                   , persistent-template       >= 2.1
                    , transformers              >= 0.2.2
                    , blaze-builder
                    , conduit

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

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)

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 <michael@snoyman.com>
@@ -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