How to create a custom field which queries the dat

Question

I’m new to Yesod and would like to create a custom field in which I need to do a query.

My model is the following:

Article
    artname     Text
    title       Text
    body        Text
    parent      ArticleId Maybe

    UniqueArt   artname

    deriving    Typeable

I want to create a "parent field" in which the user enters an artname instead of a numerical id, but it will be the real id which will be stored in the database.

I cannot use checkMMap since the invert function works outside of IO.

From what I understood of the field processing, fieldParse takes the value entered by the user and tries to convert it to an ArticleId while fieldView takes an ArticleId and shows a more human version.

What I’ve come up until now is the following:

parentField :: Field sub ArticleId
parentField = Field
    { fieldParse = \rawVals _ -> do
            let (name:[]) = rawVals
            marticle <- runDB $ getBy (UniqueArt name)
            case marticle of
                Nothing      -> return $ (Left . SomeMessage) ("Article name invalid." :: Text)
                Just article -> return $ (Right . Just) (entityKey article)

    , fieldView = \idAttr nameAttr attrs eResult isReq ->
            case eResult of
                Right key -> do
                    marticle <- runDB $ get key
                    let name = case marticle of
                                   Just article -> Right (articleArtname article)
                                   Nothing      -> Left ("Article key invalid." :: Text)

                    (fieldView textField) idAttr nameAttr attrs name isReq

                Left _ -> (fieldView textField) idAttr nameAttr attrs eResult isReq
    }

GHC doesn’t like the marticle <- runDB $ get key line and gives me the following error:

Handler/Article.hs:50:21:
    Couldn't match type ‘HandlerT site1 IO’
                  with ‘WidgetT (HandlerSite sub) IO’
    Expected type: HandlerT site1 IO (Maybe Article)
                   -> (Maybe Article -> HandlerT site1 IO ())
                   -> WidgetT (HandlerSite sub) IO ()
      Actual type: HandlerT site1 IO (Maybe Article)
                   -> (Maybe Article -> HandlerT site1 IO ()) -> HandlerT site1 IO ()
    Relevant bindings include
      parentField :: Field sub ArticleId
        (bound at Handler/Article.hs:39:1)
    In a stmt of a 'do' block: marticle <- runDB $ get key
    In the expression:
      do { marticle <- runDB $ get key;
           let name = ...;
           (fieldView textField) idAttr nameAttr attrs name isReq }
    In a case alternative:
        Right key
          -> do { marticle <- runDB $ get key;
                  let name = ...;
                  (fieldView textField) idAttr nameAttr attrs name isReq }

Any idea ? Is it a lift I forgot ?

Answer 1

In order to be able to do queries inside fieldParse and fieldView, I needed some adjustments:

• the parentField signature must be fully specified. The YesodPersist and YesodPersistBackend constraints needs to be set because of the runDB calls.
• the query inside fieldView needs to be translated to a Widget because it is working inside a function that outputs a Widget. That’s why the handlerToWidget function is used.
• the original code was based on the textField field but this imposed other constraints. Therefore I defined my own whamlet.
• the fieldEnctype was missing.

Here is the updated source code:

parentField :: YesodPersist site
            => YesodPersistBackend site ~ SqlBackend
            => RenderMessage (HandlerSite (HandlerT site IO)) FormMessage
            => Field (HandlerT site IO) ArticleId
parentField = Field
    { fieldParse = \rawVals _ -> do
            let (name:[]) = rawVals
            articleM <- runDB $ getBy (UniqueArt name)
            return $ case articleM of
                Nothing      -> (Left . SomeMessage) ("Article name invalid." :: Text)
                Just article -> (Right . Just) (entityKey article)

    , fieldView = \ident name attrs resultE isReq ->
            case resultE of
                Right key -> do
                    articleM <- handlerToWidget . runDB $ get key
                    let value = case articleM of
                                   Just article -> Right (articleArtname article)
                                   Nothing      -> Left ("Article key invalid." :: Text)

                    parentHtml ident name attrs value isReq

                Left err -> parentHtml ident name attrs (Left err) isReq
    , fieldEnctype = UrlEncoded
    }
    where parentHtml ident name attrs val isReq =
            [whamlet|$newline never
                <input id="#{ident}"
                       name="#{name}"
                       *{attrs}
                       type="text"
                       :isReq:required
                       value="#{either id id val}">
            |]