Joins

As we said in the introduction to this chapter, Persistent is non-relational: it works perfectly well with either SQL or non-SQL, and there is nothing inherent in its design which requires relations. On the other hand, this very chapter gave advice on modeling relations. What gives?

Both statements are true: you're not tied to relations, but they're available if you want to use them. And when the time comes, Persistent provides you with the tools to easily create efficient relational queries, or in SQL terms: table joins.

To play along with our existing no-SQL slant, the basic approach to doing joins in Persistent does not actually use any joins in SQL. This means that a Persistent join will work perfectly well with MongoDB, even though Mongo doesn't natively support joins. However, when dealing with a SQL database, most of the time you'll want to use the database's join abilities. And for this, Persistent provides an alternate module that works just that way. (Obviously, that module is incompatible with Mongo.)

The best part? These two modules have an identical API. All you have to do is swap out which runJoin function you import, and the behavior changes as well.

So how does this joining work? Let's look at a one-to-many relationship, such as a car/owner example above. Every car has an owner, and every owner has zero or more cars. The Database.Persist.Query.Join module provides a datatype, SelectOneMany, that contains a bunch of join settings, such as how to sort the owners (somOrderOne) and how to filter the cars (somFitlterMany).

In addition, there is a selectOneMany function, which will fill in defaults for all the settings except two. This function needs to be told how to filter the cars based on an owner, and how to determine the owner from a car value.

When you run a SelectOneMany, it will return something with a bit of a crazy type signature: [((PersonId, Person), [(CarId, Car)])]. This might look intimidating, but lets simplify it just a bit:

type PersonPair = (PersonId, Person)
type CarPair = (CarId, Car)
type Result = [(PersonPair, [CarPair])]

In other words, all this means is a grouped list of people to their cars.

What happens if a person doesn't have a car? By default, they won't show up in the output, though you can override this with the somIncludeNoMatch record. The default behavior matches the behavior of a SQL inner join. Overriding this matches the behavior of a SQL left join.

One other note: while the somOrderOne field is optional, you'll almost always want to provide it. Without it, there is no guarantee that the cars will be grouped appropriately. You might end up with multiple records for a single person.

{-# LANGUAGE TypeFamilies, TemplateHaskell, MultiParamTypeClasses,
GADTs, QuasiQuotes, OverloadedStrings, FlexibleContexts #-}
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Database.Persist.Query.Join (SelectOneMany (..), selectOneMany)
import Control.Monad.IO.Class (liftIO)

-- We'll use the SQL-enhanced joins. If you want the in-application join
-- behavior instead, just import runJoin from Database.Persist.Query.Join
import Database.Persist.Query.Join.Sql (runJoin)

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
Person
    name String
Car
    owner PersonId
    name String
|]

main :: IO ()
main = withSqliteConn ":memory:" $ runSqlConn $ do
    runMigration migrateAll

    bruce <- insert $ Person "Bruce Wayne"
    insert $ Car bruce "Bat Mobile"
    insert $ Car bruce "Porsche"
    -- this could go on a while

    peter <- insert $ Person "Peter Parker"
    -- poor Spidey, no car

    logan <- insert $ Person "James Logan" -- Wolverine
    insert $ Car logan "Harley"

    britt <- insert $ Person "Britt Reid" -- The Green Hornet
    insert $ Car britt "The Black Beauty"

    results <- runJoin (selectOneMany (CarOwner <-.) carOwner)
        { somOrderOne = [Asc PersonName]
        }

    liftIO $ printResults results

printResults :: [(Entity Person, [Entity Car])] -> IO ()
printResults =
    mapM_ goPerson
  where
    goPerson :: (Entity Person, [Entity Car]) -> IO ()
    goPerson ((Entity _personid person), cars) = do
        putStrLn $ personName person
        mapM_ goCar cars
        putStrLn ""

    goCar :: (Entity Car) -> IO ()
    goCar (Entity _carid car) = putStrLn $ "    " ++ carName car

Monadic Forms

Often times, a simple form layout is adequate, and applicative forms excel at this approach. Sometimes, however, you'll want to have a more customized look to your form.

For these use cases, monadic forms fit the bill. They are a bit more verbose than their applicative cousins, but this verbosity allows you to have complete control over what the form will look like. In order to generate the form above, we could code something like this.

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
TemplateHaskell, MultiParamTypeClasses #-}
import Yesod
import Control.Applicative
import Data.Text (Text)

data Monadic = Monadic

mkYesod "Monadic" [parseRoutes|
/ RootR GET
|]

instance Yesod Monadic

instance RenderMessage Monadic FormMessage where
    renderMessage _ _ = defaultFormMessage

data Person = Person { personName :: Text, personAge :: Int }
    deriving Show

personForm :: Html -> MForm Monadic Monadic (FormResult Person, Widget)
personForm extra = do
    (nameRes, nameView) <- mreq textField "this is not used" Nothing
    (ageRes, ageView) <- mreq intField "neither is this" Nothing
    let personRes = Person <$> nameRes <*> ageRes
    let widget = do
            toWidget [lucius|
##{fvId ageView} {
    width: 3em;
}
|]
            [whamlet|
#{extra}
<p>
    Hello, my name is #
    ^{fvInput nameView}
    \ and I am #
    ^{fvInput ageView}
    \ years old. #
    <input type=submit value="Introduce myself">
|]
    return (personRes, widget)

getRootR :: Handler RepHtml
getRootR = do
    ((res, widget), enctype) <- runFormGet personForm
    defaultLayout [whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
    ^{widget}
|]

main :: IO ()
main = warpDebug 3000 Monadic

Similar to the applicative areq, we use mreq for monadic forms. (And yes, there's also mopt for optional fields.) But there's a big difference: mreq gives us back a pair of values. Instead of hiding away the FieldView value and automatically inserting it into a widget, we get the control to insert it as we see fit.

FieldView has a number of pieces of information. The most important is fvInput, which is the actual form field. In this example, we also use fvId, which gives us back the HTML id attribute of the input tag. In our example, we use that to specify the width of the field.

You might be wondering what the story is with the "this is not used" and "neither is this" values. mreq takes a FieldSettings as its second argument. Since FieldSettings provides an IsString instance, the strings are essentially expanded by the compiler to:

fromString "this is not used" == FieldSettings
    { fsLabel = "this is not used"
    , fsTooltip = Nothing
    , fsId = Nothing
    , fsName = Nothing
    , fsClass = []
    }

The other interesting bit is the extra value. GET forms include an extra field to indicate that they have been submitted, and POST forms include a security tokens to prevent CSRF attacks. If you don't include this extra hidden field in your form, Yesod will not accept it.

Other than that, things are pretty straight-forward. We create our personRes value by combining together the nameRes and ageRes values, and then return a tuple of the person and the widget. And in the getRootR function, everything looks just like an applicative form. In fact, you could swap out our monadic form with an applicative one and the code would still work.

Input forms

Applicative and monadic forms handle both the generation of your HTML code and the parsing of user input. Sometimes, you only want to do the latter, such as when there's an already-existing form in HTML somewhere, or if you want to generate a form dynamically using Javascript. In such a case, you'll want input forms.

These work mostly the same as applicative and monadic forms, with some differences:

• You use runInputPost and runInputGet.
• You use ireq and iopt. These functions now only take two arguments: the field type and the name (i.e., HTML name attribute) of the field in question.
• After running a form, it returns the value. It doesn't return a widget or an encoding type.
• If there are any validation errors, the page returns an "invalid arguments" error page.

You can use input forms to recreate the previous example. Note, however, that the input version is less user friendly. If you make a mistake in an applicative or monadic form, you will be brought back to the same page, with your previously entered values in the form, and an error message explaning what you need to correct. With input forms, the user simply gets an error message.

{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
TemplateHaskell, MultiParamTypeClasses #-}
import Yesod
import Control.Applicative
import Data.Text (Text)

data Input = Input

mkYesod "Input" [parseRoutes|
/ RootR GET
/input InputR GET
|]

instance Yesod Input

instance RenderMessage Input FormMessage where
    renderMessage _ _ = defaultFormMessage

data Person = Person { personName :: Text, personAge :: Int }
    deriving Show

getRootR :: Handler RepHtml
getRootR = defaultLayout [whamlet|
<form action=@{InputR}>
    <p>
        My name is #
        <input type=text name=name>
        \ and I am #
        <input type=text name=age>
        \ years old. #
        <input type=submit value="Introduce myself">
|]

getInputR :: Handler RepHtml
getInputR = do
    person <- runInputGet $ Person
                <$> ireq textField "name"
                <*> ireq intField "age"
    defaultLayout [whamlet|<p>#{show person}|]

main :: IO ()
main = warpDebug 3000 Input

Custom fields

The fields that come built-in with Yesod will likely cover the vast majority of your form needs. But occasionally, you'll need something more specialized. Fortunately, you can create new forms in Yesod yourself. The Field datatype has two records: fieldParse takes a list of values submitted by the user and returns one of three results:

• An error message saying validation failed.
• The parsed value.
• Nothing, indicating that no data was supplied.

That last case might sound surprising: shouldn't Yesod automatically know that no information is supplied when the input list is empty? Well, no actually. Checkboxes, for instance, indicate an unchecked state by sending in an empty list.

Also, what's up with the list? Shouldn't it be a Maybe? Well, that's also not the case. With grouped checkboxes and multi-select lists, you'll have multiple widgets with the same name. We also use this trick in our example below.

The second record is fieldView, and it renders a widget to display to the user. This function has four arguments: the id attribute, the name attribute, the result and a Bool indicating if the field is required.

What did I mean by result? It's actually an Either, giving either the unparsed input (when parsing failed) or the successfully parsed value. intField is a great example of how this works. If you type in 42, the value of result will be Right 42. But if you type in turtle, the result will be Left "turtle". This lets you put in a value attribute on your input tag that will give the user a consistent experience.

As a small example, we'll create a new field type that is a password confirm field. This field has two text inputs- both with the same name attribute- and returns an error message if the values don't match. Note that, unlike most fields, it does not provide a value attribute on the input tags, as you don't want to send back a user-entered password in your HTML ever.

passwordConfirmField :: Field sub master Text
passwordConfirmField = Field
    { fieldParse = \rawVals ->
        case rawVals of
            [a, b]
                | a == b -> return $ Right $ Just a
                | otherwise -> return $ Left "Passwords don't match"
            [] -> return $ Right Nothing
            _ -> return $ Left "You must enter two values"
    , fieldView = \idAttr nameAttr _ eResult isReq -> [whamlet|
<input id=#{idAttr} name=#{nameAttr} type=password>
<div>Confirm:
<input id=#{idAttr}-confirm name=#{nameAttr} type=password>
|]
    }

getRootR :: Handler RepHtml
getRootR = do
    ((res, widget), enctype) <- runFormGet $ renderDivs
        $ areq passwordConfirmField "Password" Nothing
    defaultLayout [whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
    ^{widget}
    <input type=submit value="Change password">
|]