Nested form result in Haskell - haskell

I have the following handler/template combination:
handler/automation.hs
data AutomationRequest = AutomationRequest {
arEnabled :: Bool
, arTemplate :: Text
, arSchedules :: Textarea
}
getAutomationR :: Handler Html
getAutomationR = do
(formWidget, formEnctype) <- generateFormPost form
defaultLayout $(widgetFile "automation")
form :: Form AutomationRequest
form extra = do
(enabledRes, enabledView) <- mreq checkBoxField "" Nothing
(templateRes, templateView) <- mreq textField (withPlaceholder "..." $ bfs (""::Text)) Nothing
(schedulesRes, schedulesView) <- mreq textareaField (withPlaceholder "..." $ bfs (""::Text)) Nothing
(_, submitView) <- mbootstrapSubmit $ BootstrapSubmit ("Save"::Text) ("btn-primary"::Text) []
let requestRes = AutomationRequest <$> enabledRes <*> templateRes <*> schedulesRes
widget = $(widgetFile "automation-form")
return (requestRes, widget)
templates/automation.hamlet
<form method=post role=form action=#{AutomationR} enctype=#{formEnctype}>
^{formWidget}
templates/automation-form.hamlet
#{extra}
<div .panel .panel-default>
<div .panel-heading>^{fvInput enabledView} ...
<div .panel-body>
^{fvInput templateView}
^{fvInput schedulesView}
^{fvInput submitView}
This works as expected, but I want additional functionality:
a) I want to be able to nest data structures like:
data AutomationRequestCollection = AutomationRequestCollection {
arcItemAbc :: AutomationRequest
, arcItemDef :: AutomationRequest
... -- 10 Items
}
data AutomationRequest = AutomationRequest {
arEnabled :: Bool
, arTemplate :: Text
, arSchedules :: Textarea
}
I don't know how to apply the nesting to let requestRes = AutomationRequest <$> enabledRes <*> templateRes <*> schedulesRes
b) Reuse the HTML panel for itemAbc, itemDef, ...:
-- loop somehow
<div .panel .panel-default>
<div .panel-heading>^{fvInput enabledView} ...
<div .panel-body>
^{fvInput templateView}
^{fvInput schedulesView}
Any ideas that could push me into the right direction?

I'm not sure about (b), but (a) should be straightforward Applicative composition, e.g.:
Foo <$> (Bar <$> baz <*> bin) <*> qux
It can also be easier to see if you break this into multiple functions:
bar = Bar <$> baz <*> bin
foo = Foo <$> bar <*> qux

Related

Applicative form in Yesod

I have defined Wff data type:
data Wff = P Text | Ng Wff | Box Wff | Cnj [Wff] | Dsj [Wff]
deriving (Eq)
instance Show Wff where
show (P name) = unpack $ name
show (Ng f) = "-" ++ show f
show (Box f) = "[]" ++ show f
show (Cnj[]) = show " "
show (Cnj[f]) = show f
show (Cnj (f:fs)) = "(" ++ show f ++ "&" ++ show (Cnj fs) ++ ")"
show(Dsj[]) = show " "
show(Dsj[f]) = show f
show (Dsj (f:fs)) = "(" ++ show f ++ "v" ++ show (Dsj fs) ++ ")"
A function that translates a string to Wff:
foo :: String -> Wff
foo xs | elem '|' xs = Dsj (map foo (splitOn "|" xs))
foo xs | elem '&' xs = Cnj (map foo (splitOn "&" xs))
foo xs | head xs == '~' = Ng (foo . tail $ xs)
foo xs | take 2 xs == "[]" = Box (foo . tail . tail $ xs)
foo xs | otherwise = P (pack xs)
I am trying to write an app, where a user submits a string in a form and gets show of a Wff which corresponds to the string typed by the user. Here's my code:
data App = App
mkYesod "App" [parseRoutes|
/ HomeR GET
/person PersonR POST
|]
instance Yesod App
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodJquery App
wffAForm :: AForm Handler Wff
wffAForm = (foo. unpack) <$> areq textField "Model" Nothing
wffForm :: Html -> MForm Handler (FormResult Wff, Widget)
wffForm = renderTable wffAForm
getHomeR :: Handler Html
getHomeR = do
(widget, enctype) <- generateFormPost wffForm
defaultLayout
[whamlet|
<p> Type your formula </p>
<form method=post action=#{PersonR} enctype=#{enctype}>
^{widget}
<button>Submit
|]
postPersonR :: Handler Html
postPersonR = do
((result, widget), enctype) <- runFormPost wffForm
case result of
FormSuccess wff -> defaultLayout[whamlet| |<p>#{show wff}|]
main :: IO ()
main = warp 3000 App
The code compiles and the result is a web-page with the form, but the submit button doesn't do anything. What's wrong with it?
UPD: I looked at the terminal and it is seen that POSt requests don't even been sending for some reason when I click Submit button.
The submit button should be properly indented under the form element or add a form attribute to it.
...
defaultLayout
[whamlet|
<p> Type your formula </p>
<form method=post action=#{PersonR} enctype=#{enctype}>
^{widget}
<button>Submit
|]
...
or
...
defaultLayout
[whamlet|
<p> Type your formula </p>
<form #myForm method=post action=#{PersonR} enctype=#{enctype}>
^{widget}
<button type=submit form="myForm">Submit
|]
...
^{widget} should also be indented relative to the form tag.

validate field from database Yesod

Hi i want create a file that only accept values that exist in a table (with more that 20000 rows) so i have the following code
demoForm :: Maybe Demo -> AForm Handler Demo
demoForm demo = Demo
<$> areq nitField (bfs (MsgName)) (demoFieldOne <$> demo)
<*> areq intField (bfs (MsgName)) (demoFieldTwo <$> demo)
where
errorMessage :: Text
errorMessage = "the company no exist!"
nitField = check validateNit textField
validateNit nit
| companiesMatch nit = Left errorMessage
| otherwise = Right nit
companiesMatch name = do
entities <- runDB $ selectList [CompanyName ==. name] []
return (null entities)
but I get the error Couldn't match expected type ‘Bool’with actual type ‘m0 (HandlerT site0 IO Bool)’ so how can get the bool value from the monad or exist a better way to do this validations?
thanks #Michael Snoyman you are rigth I just have to use checkM
demoForm :: Maybe Demo -> AForm Handler Demo
demoForm demo = Demo
<$> areq nitField (bfs (MsgName)) (demoFieldOne <$> demo)
<*> areq intField (bfs (MsgName)) (demoFieldTwo <$> demo)
where
nitField = checkM validateNit textField
validateNit input = do
mbNit <- runDB $ selectList [CompanyName ==. input] []
return $ case null mbNit of
True -> Left (MsgErrNit :: AppMessage)
False -> Right input

Relate an item in the database to the User Session ID - Yesod Haskell Postgree

Im doing a PetShop System. I have a form that list all Animals. I already have Session in my Project. How can i add a Animal linking to session ID and in the page that list's the animals, list just the animals of that user.
This is the part related it.
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Animals
nome Text
idade Int
racaid RacaId
deriving Show
Users
nome Text
login Text
senha Text
deriving Show
Raca
nome Text
apelido Text sqltype=varchar(10)
deriving Show
|]
--Form that include animals
formAnimal :: Form Animals
formAnimal = renderDivs $ Animals <$>
areq textField "Nome: " Nothing <*>
areq intField "Idade: " Nothing <*>
areq (selectField racas) "Raca" Nothing
--Form that include Users
formUser :: Form Users
formUser = renderDivs $ Users <$>
areq textField "Nome: " Nothing <*>
areq textField "Login: " Nothing <*>
areq passwordField "Password: " Nothing
--Function do include animals
getAnimalR :: Handler Html
getAnimalR = do
(widget, enctype) <- generateFormPost formAnimal
defaultLayout $ do
toWidget [cassius|
label
color:blue;
|]
[whamlet|
<form .form-horizontal method=post enctype=#{enctype} action=#{AnimalR}>
^{widget}
<input type="submit" value="Cadastrar Animal">
|]
--Part that list all Animals (need to list just of the User)
getListarAnimalR :: Handler Html
getListarAnimalR = do
listaAnm <- runDB $ selectList [] [Asc AnimalsNome]
defaultLayout $ [whamlet|
<h1> Animais cadastrados:
$forall Entity pid animals <- listaAnm
<a href=#{ChecarAnimalR pid}> #{animalsNome animals}
<form method=post action=#{ChecarAnimalR pid}>
<input type="submit" value="Deletar Animal"><br>
|] >> toWidget [lucius|
form { display:inline; }
input { background-color: #ecc; border:0;}
|]
--Function that get the User. Check in database if contain any user with that login and pass
postLoginR :: Handler Html
postLoginR = do
((result, _), _) <- runFormPost formLogin
case result of
FormSuccess ("admin","admin") -> setSession "_ID" "admin" >> redirect AdminR
FormSuccess (login,senha) -> do
user <- runDB $ selectFirst [UsersLogin ==. login, UsersSenha ==. senha] []
case user of
Nothing -> redirect LoginR
Just (Entity pid u) -> setSession "_ID" (pack $ show $ fromSqlKey pid) >> redirect (PerfilR pid)

Dynamic form generation with yesod

How do I dynamically generate forms with a varying number of input fields?
The closest I managed is:
listEditForm :: [String] -> Html -> MForm App App (FormResult Text, Widget)
listEditForm xs = renderDivs $ mconcat [ areq textField (String.fromString x) Nothing | x <- xs]
but this has the result type Text and not [Text] as intended, owning to the coincidence that Text is an instance of Monoid, e.g. it fails with Int.
I have a working alternate attempt, which combines several forms, but somehow it only works for this toy example, while the real attempt fails strangely. Anyhow, I don't think this is the correct approach:
data MapPair = MapPair { mpKey :: T.Text, mpValue :: Maybe T.Text }
editForm mmp = renderTable $ MapPair
<$> areq textField "Key" (mpKey <$> mmp)
<*> aopt textField "Value" (mpValue <$> mmp)
pair2mp (v,k) = MapPair { mpKey = v, mpValue = Just k }
getEditR = do
sess <- getSession
let sesslist = Map.toList $ Map.map (decodeUtf8With lenientDecode) sess
forms <- forM sesslist (\a -> generateFormPost $ editForm $ Just $ pair2mp a)
defaultLayout [whamlet|
<h1>Edit Value Pairs
$forall (widget,enctype) <- forms
<form method=post action=#{EditR} enctype=#{enctype}>
^{widget}
<input type=submit>
|]
postEditR = do
sess <- getSession
let sesslist = Map.toList $ Map.map (decodeUtf8With lenientDecode) sess
forM_ sesslist (\a -> do
((res,_),_) <- runFormPost $ editForm $ Just $ pair2mp a
case res of
(FormSuccess (MapPair {mpKey=mk, mpValue=(Just mv)})) -> setSession mk mv
_ -> return ()
)
defaultLayout [whamlet|ok|]
Duh, it is actually easy using monadic forms (see code below).
My major headache is the extra text fields to make sure that the handler which receives the answer may also infer the corresponding question. Maybe I can hide those text fields, make them uneditable, or find another way around that (but I don't know much about Html yet).
listEditMForm :: [(String,Int)] -> Html -> MForm App App (FormResult [(FormResult Int, FormResult Text)], Widget)
listEditMForm xs extra = do
ifields <- forM xs (\(s,i) -> mreq intField (String.fromString s) (Just i))
tfields <- forM xs (\(s,i) -> mreq textField (String.fromString s) (Just $ pack s))
let (iresults,iviews) = unzip ifields
let (tresults,tviews) = unzip tfields
let results = zip iresults tresults
let views = zip iviews tviews
let widget = [whamlet|
#{extra}
<h1>Multi Field Form
$forall (iv,tv) <- views
Field #
#{fvLabel iv}: #
^{fvInput tv} #
^{fvInput iv}
<div>
|]
return ((FormSuccess results), widget)
There are also still some ugly things that I have no clue about, like always wrapping the result always in an outermost FormSuccess constructor, but I guess that really depends on each use-case (e.g. a single FormFailure or FormMissing should probably make the whole form fail/missing as well, but maybe in some case this is not wanted.)
All the zipping and unzipping can probably be done more neatly, but I guess in my case I just create a combined field textintField. I think I know how to do it, but it would be neat if there were a function to combine fields.
The tricky thing with having a dynamic number of fields is that the number of rows/fields need to be known when the form is parsed in the handler.
Let's say we have a regular form that looks like this:
type Form m a b =
(MonadHandler m, m ~ HandlerFor App) =>
Maybe a ->
Html ->
MForm m (FormResult b, Widget)
nameAndAgeForm :: Form m (Text, Int) (Text, Int)
nameAndAgeForm mPair extra = do
let nameSettings =
FieldSettings
{ fsLabel = "name"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
(nameResult, nameField) <- mreq textField nameSettings (fst <$> mPair)
let ageSettings =
FieldSettings
{ fsLabel = "age"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs = []
}
(ageResult, ageField) <- mreq intField ageSettings (snd <$> mPair)
let result = (,) <$> nameResult <*> ageResult
let widget = [whamlet|age: ^{fvInput nameField}, age: ^{fvInput ageField}^{extra}|]
pure (result, widget)
NOTE it's important that fsName = Nothing in all of the fields or they will collide with themselves when we try to repeat the form in a list.
We can turn it into a form of lists of pairs with a function with that has the following signature Form m a b -> Form m [a] [b].
We can write such a function if we use a trick to get around the problem that the number of fields must be known when parsing. We can send the number of rows as the first field to be parsed.
listifyForm :: Form m a b -> Form m [a] [b]
listifyForm form items csrf = do
let countSettings =
FieldSettings
{ fsLabel = "rowCount"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Just "listifiedFormRowCount"
, fsAttrs = []
}
(rowCountResult, rowCountField) <- mreq hiddenField countSettings (length <$> items)
case (rowCountResult, items) of
(FormSuccess rowCount, _) -> constructForms rowCountField $ replicate rowCount Nothing
(FormMissing, Just items') -> constructForms rowCountField $ Just <$> items'
(FormFailure err, _) -> pure (FormFailure err, [whamlet|Something went wrong with the form. Do all the fields have unique ID's?|])
(FormMissing, _) -> pure (FormMissing, [whamlet|Something went wrong with the form|])
where
constructForms rowCountField mItems =
fmap ([whamlet|^{csrf}^{fvInput rowCountField}|] <>) . bimap sequenceA mconcat . unzip
<$> traverse (flip form mempty) mItems
Now we can convert the nameAndAgeForm into a nameAndAgeListForm:
nameAndAgeListForm :: Form m [(Text, Int)] [(Text, Int)]
nameAndAgeListForm = listifyForm nameAndAgeForm
That can then be called like this in the handler that displays the form:
((_, namesAndAgesWidget), _) <- runFormPost $ nameAndAgeListForm $ Just [("Alice", 12), ("Bob", 34)]
And like this in the handler that handles the input:
((result, _), _) <- runFormPost $ nameAndAgeListForm Nothing

Need some guidance on function type definition

I'm getting the following error when trying to compile my Yesod project (built out from the scaffolding).
No instance for (PersistBackend (GGHandler Scheduler Scheduler) IO)
arising from a use of `checkDateStatus'
Possible fix:
add an instance declaration for
(PersistBackend (GGHandler Scheduler Scheduler) IO)
In the first argument of `checkM', namely `checkDateStatus'
In the expression: checkM checkDateStatus
In the expression:
checkM checkDateStatus
$ (jqueryDayField
(def {jdsChangeYear = True, jdsYearRange = "2011:2012"}))
I believe this is because Haskell's type inference is failing. If this is the case, all I need to do is to give an accurate definition for checkDateStatus. If not a push in the right direction would be welcome. If I'm right, I'm still stuck as to what the type definition of checkDateStatus should be. I've been getting away with depending on type inference. Included below is the code I think is relevant. If I am missing something, please inform.
getManagerR :: Handler RepHtml
getManagerR = do
((res, widget), enctype) <- runFormGet productForm
let findTestId = 1
res' = prepST res
scheduledTest = makeScheduledTest res'
dataInsert <- runDB $ insert scheduledTest
defaultLayout [whamlet|
<p>Result:#{show res}
<form enctype=#{enctype}>
^{widget}
|]
productForm :: Html
-> Form Scheduler Scheduler (FormResult SelectedProduct, Widget)
productForm extra = do
pInfo <- liftIO getUIdata
let products = V.toList $ V.map productACC $ fst pInfo
versions = V.toList $ V.map versionsACC $ snd pInfo
(productRes, productView) <- mreq (radioField products) "Placeholder" Nothing
versionInfo <- mapM generateVersionSelectFields versions
(dateRes, dateView) <- mreq requestedDayField "Schedule" Nothing
-- (dateRes, dateView) <- mreq (jqueryDayField def
-- { jdsChangeYear = True
-- , jdsYearRange = "2011:2012"
-- }) "Schedule" Nothing
let versionRes = map fst versionInfo
versionViews = map snd versionInfo
widget = do
toWidget [whamlet|
#{extra}
<p>
^{fvInput productView}
$forall versionView <- versionViews
^{fvInput versionView}
^{fvInput dateView}
<input type=submit value="Request Test">
|]
return (makeSelected productRes versionRes dateRes, widget)
requestedDayField = checkM checkDateStatus $ (jqueryDayField def
{ jdsChangeYear = True
, jdsYearRange = "2011:2012"
})
errorMessage :: Text
errorMessage = "I can't go for that, no can do."
checkDateStatus date = do
maybeTaken <- getBy $ UniqueStartDate date
case maybeTaken of
Nothing -> return $ Left errorMessage
otherwise -> return $ Right date
You're missing a runDB in front of the getBy.

Resources