-
Notifications
You must be signed in to change notification settings - Fork 370
/
hello-forms.hs
136 lines (117 loc) · 3.63 KB
/
hello-forms.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
import Yesod.Core
import Yesod.Form
import Yesod.Form.MassInput
import Control.Applicative
import Data.Text (Text, pack)
import Network.Wai.Handler.Warp (run)
import Data.Time (utctDay, getCurrentTime)
import qualified Data.Text as T
import Control.Monad.IO.Class (liftIO)
data Fruit = Apple | Banana | Pear
deriving (Show, Enum, Bounded, Eq)
fruits :: [(Text, Fruit)]
fruits = map (\x -> (pack $ show x, x)) [minBound..maxBound]
mkYesod "HelloForms" [parseRoutes|
/ RootR GET
/mass MassR GET
/valid ValidR GET
/file FileR GET POST
|]
myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
<*> areq boolField "Bool field" Nothing
<*> aopt boolField "Opt bool field" Nothing
<*> areq textField "Text field" Nothing
<*> areq (selectFieldList fruits) "Select field" Nothing
<*> aopt (selectFieldList fruits) "Opt select field" Nothing
<*> areq (multiSelectFieldList fruits) "Multi select field" Nothing
<*> aopt (multiSelectFieldList fruits) "Opt multi select field" Nothing
<*> aopt intField "Opt int field" Nothing
<*> aopt (radioFieldList fruits) "Opt radio" Nothing
data HelloForms = HelloForms
instance RenderMessage HelloForms FormMessage where
renderMessage _ _ = defaultFormMessage
instance Yesod HelloForms
fixType :: Handler a -> Handler a
fixType = id
getRootR = do
((res, form), enctype) <- myForm
defaultLayout [whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
^{form}
<div>
<input type=submit>
<p>
<a href=@{MassR}>See the mass form
<p>
<a href=@{ValidR}>Validation form
<p>
<a href=@{FileR}>File form
|]
myMassForm = fixType $ runFormGet $ renderTable $ inputList "People" massTable
(\x -> (,)
<$> areq textField "Name" (fmap fst x)
<*> areq intField "Age" (fmap snd x)) (Just [("Michael", 26)])
getMassR = do
((res, form), enctype) <- myMassForm
defaultLayout [whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
<table>
^{form}
<div>
<input type=submit>
<p>
<a href=@{RootR}>See the regular form
|]
myValidForm = fixType $ runFormGet $ renderTable $ pure (,,)
<*> areq (check (\x ->
if T.length x < 3
then Left ("Need at least 3 letters" :: Text)
else Right x
) textField)
"Name" Nothing
<*> areq (checkBool (>= 18) ("Must be 18 or older" :: Text) intField)
"Age" Nothing
<*> areq (checkM inPast dayField) "Anniversary" Nothing
where
inPast x = do
now <- liftIO $ getCurrentTime
return $ if utctDay now < x
then Left ("Need a date in the past" :: Text)
else Right x
getValidR = do
((res, form), enctype) <- myValidForm
defaultLayout [whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
<table>
^{form}
<div>
<input type=submit>
<p>
<a href=@{RootR}>See the regular form
|]
main = toWaiApp HelloForms >>= run 3000
fileForm = renderTable $ pure (,)
<*> (FileInfo' <$> areq fileField "Required file" Nothing)
<*> (fmap FileInfo' <$> aopt fileField "Optional file" Nothing)
newtype FileInfo' = FileInfo' FileInfo
instance Show FileInfo' where
show (FileInfo' f) = show (fileName f, fileContentType f)
getFileR = do
((res, form), enctype) <- runFormPost fileForm
defaultLayout [whamlet|
<p>Result: #{show res}
<form method=post enctype=#{enctype}>
<table>
^{form}
<tr>
<td>
<input type=submit>
<p>
<a href=@{RootR}>See the regular form
|]
postFileR = getFileR