haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into uni2work

Browse Source
This commit is contained in:
Gregor Kleen 2021-06-27 13:59:35 +02:00
commit cb75192e0c
37 changed files with 437 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.envrc Normal file
View File

@ -0,0 +1 @@
use flake

4
.github/workflows/tests.yml vendored
View File

@ -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

1
.gitignore vendored
View File

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

2
demo/subsite/WikiRoutes.hs
View File

@ -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.

44
flake.lock Normal file
View File

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

30
flake.nix Normal file
View File

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

8
nixpkgs.nix Normal file
View File

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

20
stack-persistent-212.yaml Normal file
View File

@ -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

23
stack-persistent-213.yaml Normal file
View File

@ -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

14
stack.nix Normal file
View File

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

7
stack.yaml
View File

@ -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

8
stack.yaml.lock
View File

@ -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

6
yesod-auth-oauth/ChangeLog.md
View File

@ -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

4
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -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

8
yesod-auth/ChangeLog.md
View File

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

6
yesod-auth/yesod-auth.cabal
View File

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

17
yesod-core/ChangeLog.md
View File

@ -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

11
yesod-core/src/Yesod/Core/Class/Breadcrumbs.hs
View File

@ -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

16
yesod-core/src/Yesod/Core/Dispatch.hs
View File

@ -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

13
yesod-core/src/Yesod/Core/Handler.hs
View File

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

4
yesod-core/src/Yesod/Core/Internal/TH.hs
View File

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

8
yesod-core/src/Yesod/Core/Types.hs
View File

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

2
yesod-core/test/YesodCoreTest.hs
View File

@ -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

58
yesod-core/test/YesodCoreTest/Breadcrumb.hs Normal file
View File

@ -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

3
yesod-core/yesod-core.cabal
View File

@ -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

6
yesod-form-multi/ChangeLog.md
View File

@ -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

4
yesod-form-multi/yesod-form-multi.cabal
View File

@ -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

4
yesod-form/ChangeLog.md
View File

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

2
yesod-form/README.md
View File

@ -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

122
yesod-form/Yesod/Form/Fields.hs
View File

@ -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
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.

6
yesod-form/yesod-form.cabal
View File

@ -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

8
yesod-persistent/ChangeLog.md
View File

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

12
yesod-persistent/Yesod/Persist/Core.hs
View File

@ -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.

6
yesod-persistent/yesod-persistent.cabal
View File

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

2
yesod-websockets/yesod-websockets.cabal
View File

@ -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

6
yesod/ChangeLog.md
View File

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

4
yesod/yesod.cabal
View File

@ -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