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
Related
Given a user, I am trying to select a list of events that are affiliated with organizations that the user is in. The UserOrg table describes which OrgIds correspond to a given UserId.
I have these tables:
User
email Text
name Text
UniqueUser email
deriving Typeable
Event
name Text
description Text
dateTime UTCTime
userId UserId
orgId OrgId
deriving Show
Org
name Text
description Text
deriving Show
UserOrg
userId UserId
orgId OrgId
Currently I am trying this:
getEventR :: Handler Html
getEventsR = do
muser <- maybeAuth
eventList <- runDB $
case muser of
Nothing -> []
(Just euser) -> selectList [ EventOrgId <-. (userOrgIds $ entityKey euser) ] []
defaultLayout $ do
setTitle "Events"
$(widgetFile "events")
userOrgIds :: UserId -> [OrgId]
userOrgIds userid = do
rows <- liftHandler $ runDB $ selectList [ UserOrgUserId ==. userid ] []
return $ [ userOrgOrgId $ entityVal $ erow | erow <- rows ]
But I get a type error saying that the return of userOrgIds returns a [[OrgId]] rather than [OrgId], and concat doesn't work here
Am I going about this wrong? Should I just use rawQuery in this case?
It's a good start, but I see a number of things wrong with this.
getEventR :: Handler Html
getEventsR = do
These function names don't match.
muser <- maybeAuth
eventList <- runDB $
case muser of
Nothing -> []
(Just euser) -> selectList [ EventOrgId <-. (userOrgIds $ entityKey euser) ] []
I'm not sure this will work; you probably want your Nothing branch to provide pure [].
defaultLayout $ do
setTitle "Events"
$(widgetFile "events")
This looks fine.
userOrgIds :: UserId -> [OrgId]
userOrgIds userid = do
rows <- liftHandler $ runDB $ selectList [ UserOrgUserId ==. userid ] []
return $ [ userOrgOrgId $ entityVal $ erow | erow <- rows ]
This definitely won't work. In your type signature, you've said that it's a pure function; it takes a UserId (which is a synonym for Key User), and returns a list of OrgId (again, synonymous with Key Org) values. However in your implementation, you're using liftHandler, runDB, and selectList. These are all effectful things!
Here's how I would write your Handler.
getEventsR :: Handler Html
getEventsR = do
mUser <- maybeAuth
eventList <- case mUser of
Nothing -> pure []
Just user -> runDB $ do
orgs <- selectList [ UserOrgUserId ==. entityKey user ] []
selectList [ EventOrgId <-. map entityKey orgs ] []
defaultLayout $ do
setTitle "Events"
$(widgetFile "events")
I'm writing that without a compiler, but it should be correct.
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
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
My attempt to render html as a label for a radiofieldList has yielded the following error.
Handler/Manager.hs:91:32:
No instance for (RenderMessage Scheduler (Handler RepHtml))
arising from a use of `radioFieldList'
Possible fix:
add an instance declaration for
(RenderMessage Scheduler (Handler RepHtml))
In the first argument of `mreq', namely `(radioFieldList bPairs)'
In a stmt of a 'do' block:
(jobRes, jobView) <- mreq
(radioFieldList bPairs) "Scheduled Jobs" Nothing
In the expression:
do { let bPairs = buttonPairs kjPairs
statusPairs
= map (pack . show &&& id) $ ([minBound .. maxBound] :: [Status ]);
(jobRes, jobView) <- mreq
(radioFieldList bPairs) "Scheduled Jobs" Nothing;
(noteRes, noteView) <- mreq textareaField " Notes " Nothing;
(statusRes, statusView) <- mreq
(selectFieldList statusPairs) " Status " Nothing;
.... }
So, given the code below, does it make sense to create an instance for (RenderMessage Scheduler (Handler RepHtml))
statusForm :: RForm CapturedData
statusForm kjPairs extra = do
let bPairs = buttonPairs kjPairs
statusPairs = map (pack . show &&& id) $
([minBound .. maxBound] :: [Status])
(jobRes ,jobView) <- mreq (radioFieldList bPairs) "Scheduled Jobs" Nothing
(noteRes, noteView) <- mreq textareaField " Notes " Nothing
(statusRes, statusView) <- mreq (selectFieldList statusPairs) " Status " Nothing -- as of 0.9.4.x it is just best to explicitly type widgetFile
let widget = toWidget ($(widgetFile "status") :: Widget)
return (CapturedData <$> jobRes <*> statusRes <*> noteRes
, widget)
buttonPairs :: [KeyJobPair] -> [(Handler RepHtml,KeyJobPair)]
buttonPairs kjList = sort $ map buttonPairs' kjList
where buttonPairs' :: KeyJobPair -> (Handler RepHtml,KeyJobPair)
buttonPairs' (KeyJobPair ((Key key), JobData (Firmware product)
(Version version)
(StartDate sDate)
status)) =
let (Right jid) = fromPersistValue key :: Either Text Int64
in (hamletToRepHtml [hamlet|<a href=#{RootR}(" Job Id " ++ (show jid))>|]
,KeyJobPair (Key key, JobData (Firmware product)
(Version version)
(StartDate sDate)
status))
It occurred to me, the true answer is to create a custom Field that will accept (HTML,a), as opposed to the required (msg,a) radioFieldList wants. I'm hoping that just creating an instance for RenderMessage will work.
You probably don't need to call hamletToRepHtml there, why not renderHtml from Text.Hamlet?
I don't have yesod installed on this machine (so I can't verify), but that should point you in the right direction. I'm assuming you don't want that to be a widget, and that you just want it rendered.
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.