Optimistic Concurrency Control (22)

Last post, I put in code to stop incorrect changes being made by malicious actors.

This post, I want to put in code to stop incorrect changes being made by innocent actors.

An example is the case that the form is submitted twice "at the same time", perhaps because it was opened on two different computers, submitted on the first, then later submitted on the second (or different browser tabs on the same computer). (I hit this bug with reddit quite often, and my bug submission there is one of the most disappointing bug responses I've ever encountered).

Because the was was opened the second time before the first instance was submitted, the user interface presents it as editable and waiting for submission, and continues to do so after the first instance has been submitted - for as long as you don't reload that page on the second computer.

A pretty common technique to deal with this is called optimistic concurrency control (OCC).

OCC assigns a version identifier to each version of the data. When a change is submitted, it contains the version against which the change is being made. If that version identifier isn't the same as the version in the database, the change is aborted.

If you're used to version control systems like git, you can imagine this as a very lightweight version of git's commit identifiers. Instead of storing the whole commit history, only the latest head is stored; and many of the interesting things git can do, like reconcile multiple changes against a history commit by merging can't happen in this system. (if you don't know about git, ignore this paragraph)

If you're used to transactions - this is a transaction system which can only enforce consistency against a single versioned record: you can't do SQL-style transactional changes to multiple records (unless they all have one single shared version identifier - which increases the likelihood of conflict).

It doesn't matter too much what database type is used for version identifiers, as long as you can generate new ones, and compare them.

I'm going to use a timestamp. This is quite a complicated type, but allows the field to double as a possibly-useful last-modified time.

First use the database migration system to update the registration table so that each record has a version. It doesn't matter what we use as an initial value for existing records; I'll use the current time.

In migrations/0006-occ.sql:

ALTER TABLE registration ADD COLUMN occ TIMESTAMP WITH TIME ZONE;
UPDATE registration SET occ = NOW();
ALTER TABLE registration ALTER COLUMN occ SET NOT NULL;

Without any further changes, we now can't create any new registrations although we can modify existing ones.

The Haskell-side Registration type now needs to know about this.

There's a postgresql-simple type for storing timestamps, which we can use in the definition of Registration.

import qualified Database.PostgreSQL.Simple.Time as PGT
...
data Registration = Registration {
...
    occ :: PGT.ZonedTimestamp,
...
}

There's immediately a build error:

    * No instance for (CSV.ToField
                         (postgresql-simple-0.5.3.0:Database.PostgreSQL.Simple.Time.Implementation.Unbounded
                            time-1.8.0.2:Data.Time.LocalTime.Internal.ZonedTime.ZonedTime))

... which is complaining that cassava doesn't know how to write a Registration out to CSV format any more - specifically because I doesn't know how to write out postgresql-simple timestamps.

Again I'm going to avoid wrapping this into its own type and specifying instances there. Instead I'm going to add a definition to our shifty Orphans.hs file:

{-# Language FlexibleInstances #-}
{-# Language TypeSynonymInstances #-}
...
import Database.PostgreSQL.Simple.Time as PGT
...
instance CSV.ToField PGT.ZonedTimestamp
  where
    toField time = CSV.toField (show time)

Those Language pragmas are needed because ZonedTimestamp is actually an alias for a more complicated type that can't by default have typeclass instances declared on it. This instance will write the timestamp to CSV as a string.

In Main.hs, the only place we create a Registration from scratch is in doInvitation. When constructing that registration we'll need an initial database timestamp. One lazy way to do that is go ask the database for one. (Another way would be to ask the Haskell runtime for the current time, and convert it into a ZonedTimestamp)

In src/DB.hs, the place for database library functions, add this:

import qualified Database.PostgreSQL.Simple.Time as PGT
...
generateOCC :: IO PGT.ZonedTimestamp
generateOCC = do
  [[n]] <- withDB $ \conn -> PG.query conn "SELECT NOW()" ()
  return n

... which will ask the database what time is NOW().

Now in doInvite we can add:

...
  newOCC <- generateOCC
...

     nonce = Just newNonce,
     occ = newOCC,
     email = Just (I.email invitation),
...

In registrationDigestiveForm we can add this OCC field initially as a constant value that cannot be modified:

registrationDigestiveForm initial = do
  Registration
...
    <*> (pure . occ) initial
...

What we should have now is a registration which generates an initial OCC version identifier when a registration is initially added, but doesn't ever change it or act on it. Nevertheless the code should compile and run at this point.

Now I want to actually use this new field to do some concurrency control.

Rather than this field being a constant loaded from the database at each iteration of form processing (so always having the latest value), instead I want to send it to the user's browser as part of the form so that when a form submission comes back, I know which version of the form data they were modifying.

digestive-functors provides DF.stringRead to define a form field that can be converted to/from string representation using the standard Show and Read typeclasses.

In registrationDigestiveForm, get rid of the pure . occ implementation of the OCC field, and instead use

...
    <*> "occ" .: DF.stringRead "OCC Version" (Just $ occ initial)
...

This new string field can be invisibly sent as part of the HTML form, to be returned as a POST parameter using inputHidden from digestive-functors-blaze.

Add this:

      inputHidden "occ" view

... anywhere in the HTML form definition in htmlForRegistration.

If you build and compile that, and look at the HTML page source of a registration form, you should see something like this:

<input type="hidden" id="Registration.occ" name="Registration.occ" value="2018-02-25 18:15:44.392519 +0000">

... which will be sent back on each submission.

... but this is still not doing any checking...

I'm going to check in two places: in the user interface where nice errors can be presented to the user; and nearer the database where I can be a bit surer that there are not race conditions.

I'll implement the database level checking first.

At present, updates happen with a call like this:

  withDB $ \conn -> gupdateInto conn "registration" "nonce = ?" n [identifier]

which returns the number of rows that have been updated, and then ignores that number.

I'm going to change the WHERE clause of that update: instead of only selecting rows with the appropriate nonce, I'm going to further narrow down to rows with the correct OCC version; and when writing out the new row update the OCC (in the same way that the status is updated); and then check that exactly one row was updated.

import Control.Monad (when)
...
    (_, Just newRegistration) -> do
      let oldOcc = occ newRegistration
      newOcc <- liftIO $ generateOCC
      let n = newRegistration { status = "C", occ = newOcc}
      rows <- withDB $ \conn -> gupdateInto conn "registration" "nonce = ? AND occ = ?" n (identifier, occ newRegistration)
      when (rows /= 1) $ error "Registration POST did not update exactly one row"
      return "Record updated."

That rows /= 1 is quite rough: there are other reasons why it might not work, such as the registration being duplicated, or not in the database at all any more. But it will do for now.

With this in place, open the same registration form in two browser tabs, and try to submit changes from first one, then the other. The first submission should work, and the second should fail.

So we get an ugly error message.

Another place we can check this is in form validation. This has a race condition, though, which is why the above database check is necessary: two submissions of the same form could both be validated, before the two submissions hit the database. That's quite unlikely though so I haven't put much effort into the error message above.

More likely that race condition won't happen and we will be fine with form-level validation.

In registrationDigestiveForm, put the field definition for "occ" in its own function:

    <*> "occ" .: occVersion (occ initial)

... which will have the same stringRead definition as before, but with a validator on top.

occVersion dbOCC =   
  DF.check  
    "This form has been modified by someone else - please reload"
    (\newOCC -> show newOCC == show dbOCC)
  $ DF.stringRead "OCC Version" (Just $ dbOCC)

That will check that the most recent version of the data loaded from the database at POST time matches the version sent in the POST request.

This will now cause the form to refuse to be submitted, telling the user that there were errors.

But it doesn't tell the user where that error occurred - we need to put DB.errorList "occ" view in htmlForRegistration at the point where we want OCC errors to be reported. With individual editable fields, it makes sense to put that error list for each field's input; but there isn't a relevant visible input field for occ. I've put the error list near the top of the HTML.

So now most of the time, forms will submit just as before. If there has been a simultaneous edit, then most of the time, the error from digestive-functors will be sent back; but (hopefully only very occasionally) there will be a database level error with a not-very-helpful error returned instead.

Eliminating that last case while still using digestive-functors can probably be done, but involves a bit more interplay between explicit SQL transactions and validation: perhaps, run the whole form validation and update inside an SQL transaction and if it aborts due to a conflict, run it again, and again, and again, hoping that the second time round form validation will fail.

What about if the user is malicious and fiddles their occ value? All they are able to do is update data that they could already have updated by loading the form fresh and fiddling in there. This is a protection against user mistakes, not against users being able to change data.

Here's the link to this post's commit.

Immutable fields (21)

There are a couple of dodgy things in the present form submission that allow things to be modified that shouldn't be.

Firstly, some fields in Registration shouldn't be modifiable via the POST interface: for example, the nonce field to identify a particular registration, or the registration status (which will modified, but only by server side code).

At present, they aren't exposed to the end user in editable HTML fields - so it would be unusual for them to be edited accidentally. They do exist as hidden HTML fields, and even if they didn't, they could be added to a POST HTTP request by someone suitably malicious and skilled at reading the source code.

I'd like to prevent those fields from being modified.

A very simple-to-suggest option is that the form data types shouldn't have these fields at all - they should be nothing to do with the user-side wire protocol at all.

But, that fits in quite awkwardly with the idea that we can use a single Registration type both to represent records in the database and fields on the web form: a row either exists everywhere or not at all.

In each iteration of form processing, we have an initial value that we're using to populate all of the form fields. In the definition of registrationDigestiveForm, "status" .: nonEmptyString attaches the status field in Registration to an over-the-wire key/value pair also labelled "status". Instead we can use pure to place a constant value here, coming from that initial Registration. This removes any connection between this field in Registration and the wire protocol - nothing sent in a POST can change this value.

Here's the updated version of registrationDigestiveForm:

registrationDigestiveForm initial = do
  Registration
    <$> "firstname" .: nonEmptyString (Just $ firstname initial)
    <*> "lastname" .: nonEmptyString (Just $ lastname initial)
    <*> "dob" .: dateLikeString (Just $ dob initial)
    <*> "swim" .: DF.bool (Just $ swim initial)
    <*> (pure . nonce) initial
    <*> "email" .: DF.optionalString (email initial)
    <*> (pure . status) initial

Here's the commit for this post. Next, I want to deal with a different kind of bad change that more plausibly will happen even with innocent users: the case of the registration being modified in two places at the same time.

Submission status (20)

A few posts ago I added a status field to the registration types, but so far the only value used there is N for new.

I'd like to introduce some more statuses: most importantly C for completed, set when a registrant submits their form.

That's a small change: in handleRegistrationPost, instead of saving the Registration provided by digestive functors, change the status first:

    (_, Just newRegistration) -> do
      let n = newRegistration { status = "C" }
      withDB $ \conn -> gupdateInto conn "registration" "nonce = ?" n [identifier]
      return "Record updated."

Now when a registrant submits a valid form, it will be marked as completed in the database. You'll be able to see that if you look at the registration table in the database, but this changed status won't otherwise affect the behaviour of the registration system.

I'd like the registration system to prohibit changes once a form has been completed: in real life, perhaps because that information is going to be used to print admission wristbands or attendee lists. That's not to say that a registration can't ever be amended after this: but there is more happening in real life that needs to be adjusted too, and this little registration system isn't going to do that.

People coming to edit the form do so via handleRegistration in app/Main.hs and it's there that I'll put in a check for completion status.

First I'll define a predicate on status to decide if a form is editable: by default, not editable; and explicitly, editable if New and not-editable if Completed.

editableStatus :: String -> Bool
editableStatus "N" = True
editableStatus "C" = False
editableStatus _ = False

handleRegistration can split into two:

handleRegistration :: String -> S.Handler B.Html
handleRegistration identifier = do
  registration <- selectByNonce identifier

  if (editableStatus . status) registration
  then handleEditableRegistration registration
  else handleReadOnlyRegistration registration

... with handleEditableRegistration containing the remainder of the original handleRegistration, with a tweak to extract the nonce: where we previously had identifier in scope we do not, so instead extract it with nonce registration.

handleEditableRegistration :: Registration -> S.Handler B.Html
handleEditableRegistration registration = do
...
      B.h1 $ do "Registration "
                B.toHtml (show $ nonce registration)
...

... and handleReadOnlyRegistration should deliver some non-editable HTML description, for example:

handleReadOnlyRegistration :: Registration -> S.Handler B.Html
handleReadOnlyRegistration registration =
  return $ B.docTypeHtml $ do
    B.body $ do
      B.h1 $ do "Completed registration "
                B.toHtml (show $ nonce registration)
      B.p $ "First name: " <> (fromString . firstname) registration
      B.p $ "Last name: " <> (fromString . lastname) registration
      B.p $ "Date of birth: " <> (fromString . dob) registration

If there are next steps to be taken by a user, this is an appropriate place to include links (for example, in the real life version, at this point there is a downloadable PDF to print and sign - that we only want available once the form has been completed).

There's a security problem here though: although the server no longer delivers an editable form to the end user, so that they aren't encouraged to edit the form, nothing else stops a POST request being sent some other way to cause changes to the database. With friendly users, that's most likely to happen (I think) with the form being opened twice, and then submitted twice. With malicious users, it's probably not too hard to fake a submission with curl (for example) as the protocol is really simple.

So next I'm going to look at verifying updates a bit more strictly.

factor withDB out (19)

The code so far has ended up with a six or so repeated blocks that look like:

liftIO $ bracket
  (PG.connectPostgreSQL "user='postgres'")
  PG.close
  \conn -> _something_to_do_with_the_database_

More than three times violates the Rule of Three so I'm going to pull this out into a new file, src/DB.hs.

{-# Language OverloadedStrings #-}

module DB where

import Control.Exception (bracket)
import Control.Monad.IO.Class (liftIO, MonadIO)
import qualified Database.PostgreSQL.Simple as PG

withDB :: MonadIO io => (PG.Connection -> IO b) -> io b
withDB act = liftIO $ bracket
  (PG.connectPostgreSQL "user='postgres'")
  PG.close
  act

Now every occurence of bracket happens to fit into the above pattern, so every place in the code you see this:

  [registration] <- liftIO $ bracket
    (PG.connectPostgreSQL "user='postgres'")
    PG.close
    $ \conn -> do
       PGS.gselectFrom conn "registration where nonce = ?" [identifier]

... replace it with this:

  [registration] <- withDB $ \conn -> do
       PGS.gselectFrom conn "registration where nonce = ?" [identifier]

... which is three lines shorter.

We can go a bit further - this occurs three times:

withDB $ \conn -> PGS.gselectFrom conn "registration where nonce = ?" [identifier]

so replace that with a new selectByNonce:

import qualified Database.PostgreSQL.Simple.SOP as PGS
selectByNonce :: MonadIO io => String -> io [Registration]
selectByNonce identifier = withDB $ \conn -> PGS.gselectFrom conn "registration where nonce = ?" [identifier]

... or go one step further and realise that a selectByNonce is always used where exactly one row is expected to match, like this:

  [registration] <- selectByNonce identifier

and so that pattern matching can move into selectByNonce too, with better error reporting. Now the function will return exactly one Registration or otherwise throw an error (rather than returning a list and the same error manifesting as a pattern match failure).

selectByNonce :: MonadIO io => String -> io Registration
selectByNonce identifier = do
  res <- withDB $ \conn -> PGS.gselectFrom conn "registration where nonce = ?" [identifier]
  case res of
    [r] -> return r
    [] -> error $ "selectByNonce: no rows returned for " ++ identifier
    _ -> error $ "selectByNonce: multiple rows returned for " ++ identifier

... with invocations looking like this:

registration <- selectByNonce identifier

Those are just a couple of small changes but they make database access look much tidier. Specifically if the code moved to some more elaborate database connection handling (for example, a persistent connection shared between requests), then withDB could be rewritten to deal with that but the higher level code would not need to change.

Here's the commit for this post.

Sending invitations by email (18)

Now I want to invite people by email: when a person is added to the database, they should be sent an email with a link to complete their registration details (some of which - name - will have been filled in as part of entering the invitation information).

I'd like a function quite like sendTestEmail from the previous post, but to which I can pass a registration identifier. Once that works, it can be called from the end of the invitation form submission code, and potentially from other places (for example, in the real life version of this crap web form, there is an administrator link to re-send an invitation).

The bit that actually does the delivery, sendEmail, won't change. But we'll need to generate a Mail based on the selected Registration rather than using a fairly constant value.

First, here are a load of new imports to add to src/InvitationEmail.hs: we're going to be accessing the database and generating HTML emails with blaze, plus bits to stick them together. blaze-html also needs to be added in the library dependencies in package.yaml - it's only in the main executable dependencies at the moment.

+import Control.Exception (bracket)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Data.Monoid ( (<>) )
import Data.String (fromString)
import qualified Data.Text.Lazy as TL
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.SOP as PGS
import qualified Text.Blaze.Html5 as B
import Text.Blaze.Html5 ( (!) )
import qualified Text.Blaze.Html5.Attributes as BA
import qualified Text.Blaze.Html.Renderer.Text as BT

import Registration

First let's get the configuration, and the relevant registration record:

sendInvitationEmail identifier = do
  c <- getConfig

  [r] <- liftIO $ bracket
    (PG.connectPostgreSQL "user='postgres'")
    PG.close
    $ \conn -> PGS.gselectFrom conn "registration where nonce = ?" [identifier]

... and now prepare some of the components we'll need to generate a Mail:

  let ub = urlbase c
  let url = ub <> "/registration/" <> identifier

  let fullname = T.pack $ firstname r ++ " " ++ lastname r
  let targetEmail = T.pack $
        fromMaybe
          (error $ "No email supplied for " ++ identifier)
          (email r)
  let subject = "Registration form for " <> fullname

I'd like to produce two forms of body text: a plain text version, and an HTML version with a clickable link. The plaintext version comes from simple string concatenation; the HTML version comes from rendering some blaze-html to a text value:

  let plaintext =
          "Hello.\n"
       <> "Please complete this registration form.\n"
       <> TL.pack url

  let htmltext = BT.renderHtml $ do
        B.p "Hello"
        B.p "Please complete this registration form.\n"
        B.p $ (B.a ! BA.href (fromString url)) (fromString url)

It would be nice if this text wasn't written out twice, and if there was more text in here I'd probably make more effort to abstract away the content (with yet another markup language or perhaps just a single paragraph read from elsewhere).

Now we can prepare a Mail to send - similar to the last post's Mail construction, but plugging in the appropriate values.

  let mail = M.Mail {
      M.mailFrom = M.Address { M.addressName = Just "Registration System"
                             , M.addressEmail = T.pack $ smtpFrom c
                             }
    , M.mailTo = [M.Address { M.addressName = Just fullname
                            , M.addressEmail = targetEmail
                            }
             ]
    , M.mailCc = []
    , M.mailBcc = []
    , M.mailHeaders = [("Subject", subject)]
    , M.mailParts = [[M.plainPart plaintext, M.htmlPart htmltext]]
    }

and finally we can send it:

  sendEmail mail

With that done, find doInvitation in app/Main.hs and right before the final return, add:

  sendInvitationEmail newNonce

Now try inviting yourself. Or your friends.

I'm frustrated in this post that there are so many kinds of string-like types used: General string types include String, Text, Text.Lazy, ByteString.Lazy; and there's a specialised AttributeValue used as the parameter of !. ++ works to concatenate String, and <> works to concatenate all of them, so I've used the latter for all of the types.

url is the only place where two different types are needed from the same value: so I form it as a String and use the polymorphic fromString to turn it into whatever is needed at the point of use.

Here's the commit for this post.

Next, I've noticed that there are quite a few places where the same bracket and connectPostgreSQL code is being used to open the database; so I'll pull that out so it is only written once; and maybe also tidy up a bit of database related error handling.

Sending an email (17)

There doesn't seem to be a clear answer about the best way to send email in Haskell in the way that there are (several) web frameworks around. But a bit of digging in Stack Overflow suggests HaskellNet-SSL and mime-mail can be put to good use.

For this post, you're going to need an outbound mail server, which I'm expecting to need to authenticate to in order to send emails. I have my own outbound server, but I think you can probably use gmail. The details for this will be specified using the configuration mechanism implemented in the last past.

In the config file config.yaml, add your own version of this with your own email address, and mail server details.

smtpFrom: "reg@cwfh28.example.com"
smtpServer: "smtp.example.com"
smtpPort: "587"
smtpUser: "your_user_id"
smtpPassword: "yourpass"

... and add the corresponding fields in src/Config.hs:

import qualified Network.Socket as N

data Config = Config {

...

  , smtpServer :: String
  , smtpPort :: N.PortNumber
  , smtpUser :: String
  , smtpPassword :: String

...

}

You'll need to add in some dependencies to package.yaml:

    - HaskellNet
    - HaskellNet-SSL
    - bytestring
    - mime-mail
    - network
    - text

... and if you try to compile now, you'll find that there is no FromJSON instance for port number, so smtpPort can't be deserialised from YAML.

Luckily we have src/Orphans.hs as a dumping ground for orphan instances, and so we can add (with suitable imports):

instance Y.FromJSON N.PortNumber
  where parseJSON v = read <$> Y.parseJSON v

... which combines the PortNumber Read instance with the String FromJSON instance. That's why the example smtpPort configuration snippet above uses double-quotes around 587.

With this configuration in place, we can now write some code to send an email. To begin with, it will just be a test sender, rather than anything directly related to registrations.

Add an API endpoint to trigger the sending of this test mail:

type MailTestAPI = "admin" :> "mailtest" :> S.Get '[SB.HTML] B.Html

type API = 
...
      :<|> MailTestAPI


server = ... :<|> handleMailTest

handleMailTest = 

handleMailTest :: Handler B.Html
handleMailTest = do
  liftIO $ sendTestMail
  return $ B.p "mail test sent"

All that will do is give us a new API endpoint - so loading http://localhost:8080/admin/mailtest will invoke sendMailTest, which isn't written yet.

So create a new module in src/InvitationEmail.hs and import it into app/Main.hs.

This module will need these prereqs:

{-# Language OverloadedStrings #-}
module InvitationEmail where

import qualified Network.Mail.Mime as M

import Config

sendTop then consists of two parts: first, constructing a Mail containing the email to send:

sendTestMail = do
  c <- getConfig
  sendEmail $
    M.Mail {
      M.mailFrom = M.Address { M.addressName = Just "Registration System"
                             , M.addressEmail = T.pack $ smtpFrom c
                             }
    , M.mailTo = [M.Address { M.addressName = Just "You"
                            , M.addressEmail = T.pack $ smtpFrom c
                            }
             ]
    , M.mailCc = []
    , M.mailBcc = []
    , M.mailHeaders = [("Subject", "Test registration invitation for you")]
    , M.mailParts = [[M.plainPart "HELLO"]]
    }

... and the second part, sendEmail, which knows how to send the supplied email:

import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T
import qualified Network.HaskellNet.SMTP.SSL as SSL
import qualified Network.Mail.Mime as M

...
sendEmail :: M.Mail -> IO ()
sendEmail msg = do
  config <- getConfig

  rendered <- BSL.toStrict <$> M.renderMail' msg

  let sslSettings = SSL.defaultSettingsSMTPSTARTTLS
       { SSL.sslPort = smtpPort config,
         SSL.sslDisableCertificateValidation = True
       } 

  SSL.doSMTPSTARTTLSWithSettings
    (smtpServer config)
    sslSettings
    $ \connection -> do
      succeeded  <- SSL.authenticate SSL.LOGIN
                                     (smtpUser config)
                                     (smtpPassword config)
                                     connection
      if succeeded
      then
          SSL.sendMail (addressToText (M.mailFrom msg))
                       (map addressToText (M.mailTo msg))
                       rendered connection
      else error "Could not authenticate to SMTP server"

This basically builds a server config, renders the message into a strict bytestring, then runs an SMTP session which first authenticates using your specified username/password and then sends the message (to/from the same addresses as used in the mail body - in internet email, there are at least two different To/From addresses although it's common for them to match up).

Note that SSL turns off all certificate validation, because certificate validation is a ballache to configure, and always has been. Except for when it's hard-coded into your browser. That option is an annoying double negative Disable... = True which always makes me frown.

This code is also reading the configuration file in twice. That's inefficiently but not terribly so for the expected load, and it saves threading the config through the code either explicitly or in a ReaderT.

Anyway, now you should be able to start up the web server, load http://localhost:8080/admin/mailtest, wait a few seconds for stuff to happen, and get an invitation email in your inbox.

If you're trying to use gmail outbound servers, you probably need to Allow Less Secure Apps (such as the crap webform). I had to do that, and also had to use the base of my gmail address (without @gmail.com) as the username.

Next post, I'll make that email be sent as part of creating an invitation, and customise it to have the appropriate link to click on.

A configuration file (16)

We're going to need some configuration values for sending email, so I'll implement a very basic configuration file now.

To begin with, all it will contain is a single parameter to replace that hardcoded localhost:8080 in the source code. (trying to figure out something like that automatically is fraught with naivety and frustration)

I'll use the yaml yaml library to read in a config file formatted in yaml. For the simple key/value pair style of config file that I'm expecting this is about right. So add yaml to the library dependencies in package.yaml.

I'm going to base the configuration file around a Haskell data structure. Put this in a new file src/Config.hs:

module Config where

data Config = Config {
  urlbase :: String
}

Later on, any new configuration keys can be added into this.

I'd like to then have a function:

getConfig :: IO Config

... that returns the config.

The yaml module provides a function that reads YAML into an almost arbitrary data structure, returning either that structure or an error.

import qualified Data.Yaml as Y
...
getConfig :: IO Config
getConfig = do
  e <- Y.decodeFileEither "config.yaml"
  either
    (\err -> error $ "cannot read config file: " ++ show err)
    return
    e

decodeFileEither returns either an error (on the Left), or the loaded Config (on the Right). It knows that the output is a Config by inference from the type signature of getConfig - so in this case, the type signature isn't just pretty decoration.

If the config file can't be read, we'll error out and let someone else handle the mess. If this happens inside a servant request handler for example, it'll return a 500 error code to the remote client.

This won't compile though. decodeFileEither can't decode into any arbitrary data structure. It actually needs the destination class to be an instance of ToJSON (because YAML is a relative of JSON, and the yaml module uses that fact). Luckily it's possible to use generics for this again:

import qualified GHC.Generics as G
...
data Config = Config {
  urlbase :: String
} deriving (G.Generic, Y.FromJSON)

Now we can use this. In app/Main.hs, find doInvitation and add:

config <- getConfig

... somewhere in there. And now the code for generating the URL can change from:

let url = "http://localhost:8080/registration/" ++ newNonce

... to ...

let url = (urlbase config) ++ "/registration/" ++ newNonce

Here's an example configuration file that uses localhost still:

urlbase: "http://localhost:8080"

You can change that localhost to, for example, your PC's LAN IP address and then perhaps be able to register for events from your phone on the same LAN.

Used in this way, the config file is re-read every time doInvitation runs. For the light load I'm expecting I'm not massively fussed about this. A more Haskelly approach would be to read the configuration once at startup and thread it through the program where needed using ReaderT. That would also mean the whole program would see a consistent configuration even if the configuration file is changed; which may be a good thing or a bad thing.

Here's today's commit: f1bbe3a2. There's a config.yaml.example in there, that you'll have to copy into place. The git repo is also configured to ignore the live version of the configuration file so that it won't be committed to version control, in .gitignore. This is because that configuration is going to contain secrets in the future, and version control is a hilarious way to leak your secrets.

Next I'm going to get some basic email sending working.

An invitation form (15)

I'm expecting most invitation information for this system to come from a separate database, but I'm expecting to want to be able to manually invite people too - for example if they aren't in the database, or are tagged incorrectly in the database. Having a manual invitation facility will be useful for testing too.

So I'm going to build an invitation form: that will take basic information (but not everything - just enough to make an invitation), and on submission, generate a URL, and send it in email. Unlike the registration form, it won't be directly backed by its own table: this is more of a form used to issue a command, rather than a form used to edit a database record.

The invitation form is going to collect name, and email address; somewhere in here, a nonce needs generating too.

I'm going to model the form contents a Haskell data type a bit like the Registration datatype. In src/Invitation.hs, write:

module Invitation where

data Invitation = Invitation {
  firstname :: String,
  lastname :: String,
  email :: String
}

Unlike Registration, we won't need any typeclass instances for this because we aren't expecting to send it into the database.

When we import this into app/Main.hs, we run into a problem: each of the field names defined in Invitation define a function to access those field names. So there is a function:

firstname :: Invitation -> String

... which is how you can write things like firstname someinvitation to extract the first name field.

But. the same applies for everything else, including Registration which also implicitly defines a function:

firstname :: Registration -> String

Those are two different functions, and so with a plain import, it is ambiguous which one you mean. (although if the input type is known, it isn't actually ambiguous. Have a look at duplicate record fields if you'd like to see more; the Haskell-like language Idris can also disambiguate this properly but it has its own problems).

So instead, lets import Invitation qualified with an short identifier:

import qualified Invitation as I

That way, firstname on its own refers to only the Registration version; if we mean the invitation version, we have to write I.firstname. We could also qualify the import of Registration as R and then we'd have to put the R. prefix in front of everything to do with registrations. Avoiding potential overlapping names is half of the reason why most of the library imports I've done so far have been qualified like this.

We'll need to define GET and POST API endpoints to get access to our form - GET to provide an initial form, and POST to send in the completed form. Unlike the registration form, there is no identifier in the URL. An invitation form doesn't have any long term presence in the server environment that can be identified: if you close your browser before you've used it to perform an actual invitation, you lose what you've typed in.

type InvitationGetAPI = "admin" :> "invite" :> S.Get '[SB.HTML] B.Html
type InvitationPostAPI = "admin" :> "invite" :> S.ReqBody '[S.FormUrlEncoded] [(String,String)] :> S.Post '[SB.HTML] B.Html

... and add them into the main API:

type API = 
...
      :<|> InvitationGetAPI
      :<|> InvitationPostAPI

... make sure that the server handles them:

server :: S.Server API
server = handlePing :<|> handleHtmlPing :<|> handleRegistration
    :<|> handleRegistrationPost :<|> handleCSV
    :<|> handleInvitationGet :<|> handleInvitationPost

... and (later in the post) provide implementations for the GET and POST methods.

This form will use digestive-functors so we'll need:

invitationDigestiveForm :: Monad m => DF.Form B.Html m I.Invitation
invitationDigestiveForm =
  I.Invitation
    <$> "firstname" .: nonEmptyString Nothing
    <*> "lastname" .: nonEmptyString Nothing
    <*> "email" .: nonEmptyString Nothing

invitationDigestiveForm doesn't take an initialising parameter - this is another difference from registrationDigestiveForm, and again is because we aren't ever loading/restoring form state from somewhere else. You can only ever start with a blank invitation.

Most of the basic mechanics of getting this form rendered to HTML and interacting with GET and POST are the same as with registrations: we need handleInvitationGet and handleInvitationPost to respond, and two helpers: htmlForInvitation which will give an HTML rendering of a form, and doInvitation which is going to actually do whatever needs to be done when an invitation command is submitted. The first three I've pasted below without comment.

handleInvitationGet :: S.Handler B.Html
handleInvitationGet = do
  view <- DF.getForm "Invitation" invitationDigestiveForm
  return $ B.docTypeHtml $ do
    B.body $ do
      B.h1 $ "New Invitation"
      htmlForInvitation view

handleInvitationPost :: [(String, String)] -> S.Handler B.Html
handleInvitationPost reqBody = do

  viewValue <- DF.postForm "Invitation" invitationDigestiveForm (servantPathEnv reqBody)

  case viewValue of
    (view, Nothing) -> 
      return $ B.docTypeHtml $ do
        B.body $ do
          B.h1 $ "New Invitation (there were errors): "
          htmlForInvitation view

    (_, Just newInvitation) -> liftIO $ doInvitation newInvitation

htmlForInvitation :: DF.View B.Html -> B.Html
htmlForInvitation view = 
  B.form
    ! BA.method "post"
    $ do
      B.p $ do  "First name: "
                DB.errorList "firstname" view
                DB.inputText "firstname" view
      B.p $ do  "Last name: "
                DB.errorList "lastname" view
                DB.inputText "lastname" view
      B.p $ do  "email: "
                DB.errorList "email" view
                DB.inputText "email" view
      B.p $     DB.inputSubmit "Save" 

Now, in doInvitation, for now, I want to: generate a Registration record, store it into the database, and return some HTML to the inviting administrator with a URL to send on. (another time, we'll make that URL be emailed, but not today).

We begin by constructing a Registration record: mostly by copying values from the invitation or setting them to a default. The nonce comes from a helper function generateNonce which I'll talk about later. It returns a random alphabetical string to use as a nonce value.

doInvitation :: I.Invitation -> IO B.Html
doInvitation invitation = do

  newNonce <- generateNonce

  let registration = Registration {
    firstname = I.firstname invitation,
    lastname = I.lastname invitation,
    dob = "",
    swim = False,
    nonce = Just newNonce,
    email = Just (I.email invitation),
    status = "N"
    
  }

Once we have a Registration, we can write it to the database:

  liftIO $ bracket
    (PG.connectPostgreSQL "user='postgres'")
    PG.close
    $ \conn -> do
      PGS.ginsertInto conn "registration" registration

... and then return a suitable HTML response:

  let url = "http://localhost:8080/registration/" ++ newNonce

  return $ B.docTypeHtml $ do
    B.head $ do
      B.title "Invitation Processed"
    B.body $ do
      B.h1 "Invitation processed."
      B.p $ "Please ask the participant to complete the form at "
            <> (B.a ! BA.href (fromString url)) (fromString url)

generateNonce uses the Haskell system random number generator in this one-liner:

import System.Random (randomRIO)
...
generateNonce :: IO String
generateNonce = sequence $ take 32 $ repeat $ randomRIO ('a', 'z')

randomRIO is an IO action that returns a character between a-z. We build an infinite list of such IO actions using repeat, and then take the first 32 elements, giving a list that holds 32 IO actions that each return a character. sequence then executes each IO action in turn, and returns the list of results: 32 random characters.

Now you can invite as many people to register as you want.

Here's the commit for this post.

Next, I'm going to add support for a configuration file: you'll see there's a hardcoded localhost above that I'd like to be able to configure; and when it is time to send email, there will be a few server parameters there that need configuring.

getting ready to invite people (14)

This booking system is for an invite-only event - a scout camp - which is why I've made a form for editing your details, but not for registering from scratch. I'm expecting the database to be loaded with basic details of each invitee (from an existing membership database), and then invitees to be emailed a link to fill out the form.

The registration links that exist now aren't suitable for sending out: registation/1 contains a number that is almost definitely sequential, and is trivial editable to view and modify other people's registrations.

I don't want to go down the road of building a username/password system that will need a lot of human support to deal with lost passwords, etc.

Instead, I'll use the technique username/password systems often use to let you reset your password when you can't remember it but when you do have access to your email: I want to send a link with a large random-looking value, intended to be unguessable, instead of a sequentially numbered one - something like registration/24f556856f4cfce0e08e17769465d92f.

So add a new string column to the database to store this key called nonce (although it arguably isn't a nonce).

The existing records need something done to them: either we need to make nonce nullable so those records can have no key (and be inaccessible); or we need to invent a value for them (This is doable in postgres but I'm not going to do it because this series is meant to be about Haskell); or we could do the migration in Haskell code (but postgresql-simple-migrations doesn't support that from the command line) or we can set them to some magic constant (such as the empty string "") which reeks of 1970s data processing.

If we were starting from a completely clean database, we wouldn't have this choice to make: we could insist every record has a nonce, and make the column NOT NULL. But I promised myself at least (and maybe you) that we wouldn't need to wipe out the database any more after implementing migrations.

So I'll make the nonce nullable, and the relevant bits of Haskell code will have to deal with that. (you make a field nullable by not writing NOT NULL as part of the type: well done SQL for supporting non-nullable values, but boo sql for making it non-default.

Here's a migration to add as migrations/0003-nonce.sql:

ALTER TABLE registration ADD COLUMN nonce TEXT;

TEXT columns in the registration have so far always been converted to/from Haskell String values inside the Registration type. That will sort-of work in some cases for nonce but not always: String doesn't have a way to represent a NULL - so we won't be able to write out NULL values to the database (which probably won't be a problem for us) and reading in NULL values will cause some kind of explosion (which will probably be a problem for us).

The obvious type to use instead is Maybe String, and indeed that works out of the box.

So onto the end of Registration in src/Registration.hs, add in a new field: nonce :: Maybe String

None of the SQL code needs changing now because of the generics magic in previous posts, but there's still that pesky applicative in registrationDigestiveForm which needs this sticking on the end (if you added the nonce field on the end of the Registration type):

...
  <*> "nonce" .: DF.optionalString (nonce initial)

We can't use DF.string here because that is for String, not Maybe String but digestive-functors has a suitable optionalString. If it didn't, it would be a very straightforward wrapper to build around DF.string.

If I'm going to invite people by email, I'm also going to need one other critical field: their email address. I'll call that email because I'm expecting that there might be other email addresses involved as user requirements change.

So migrations/0004-email.sql can be:

ALTER TABLE registration ADD COLUMN email TEXT;

... and we can add that new field onto the Registration type:

...
  email :: Maybe String
  }

... and onto registrationDigestiveForm:

...
    <*> "email" .: DF.optionalString (email initial)

We could stick some kind of email validation onto this, instead of directly using DF.optionalString but good luck.

While we're adding fields, let's add yet another field which is going to track the completion status of this form: I want to know if a registration is New, or if they have been Invited, or if they have Saved the form, or if they have Completed registration, or if their registration has been cancelled. Those capital letters are there to suggest that I'm going to use a single character field for this in the database.

Here are the relevant code fragments - hopefully you can figure out where they go:

ALTER TABLE registration ADD COLUMN status CHAR(1);
UPDATE registration SET status = 'N' WHERE status IS NULL;
ALTER TABLE registration ALTER COLUMN swim SET NOT NULL;

...

  status :: String
...
  <*> "status" .: nonEmptyString (Just $ status initial)

Luckily for this field, there's a meaningful default value: N for new, so the migration sets that status for every existing record, and we don't need to use Maybe.

In the next posts, I'll start using these fields: first to generate invitation URLs for new registrations, and then next to actually email those registrants.

Even more generic SQL (13)

The master branch of postgresql-simple-sop can do SELECT but not UPDATE.

(although if you dig hard enough, you *can* find an implementation in a branch in a different github repo with a sign on the door saying 'Beware of the Leopard')

I'm going to write an implementation, or rather adapt the SELECT implementation, gselectFrom which you can see online here.

What I want to do is generate an SQL statement that looks like this:

"UPDATE registration SET firstname = ?, lastname = ?, dob = ?, swim = ? WHERE id = ?"

... but where all those field = ? bits are generated from the names of the Haskell record data type (for exampl,e Registration).

There's a function fieldNames in Database.PostgreSQL.Simple.SOP...

fieldNames :: HasFieldNames a => GS.Proxy a -> [String]

... that will give us field names for a suitable type a, if we feed in some proxy thing. Luckily from the previous post, Registration indeed HasFieldNames.

We can use it like this:

> PGS.fieldNames (GS.Proxy :: GS.Proxy Registration)
["firstname","lastname","dob","swim"]

That Proxy stuff is because we're trying to write a function from a type to a value (feed in a type like Registration and get out a value, a list of the fields). Normal Haskell only lets you write functions from values to a values. So Proxy is some generics-sop magic that sort-of turns a type into a value, so that we can pass it to a Haskell function. Don't think about it too hard.

Given that list it's fairly to generate the desired SQL:

  let fns = PGS.fieldNames $ (GS.Proxy :: GS.Proxy Registration)

  let fieldSets = map (\name -> name <> " = ?") fns

  let sql = ("UPDATE " <> tbl
          <> " SET " <> (fromString $ intercalate ", " fieldSets)
          <> " WHERE " <> whereclause)

... and then execute the SQL:

  PG.execute conn sql (val PG.:. where_val)

I've put two sets of SQL parameters in there: one is the value that we're going to write (a Registration in our case), and the other is any parameters needed for the WHERE clause: for example to pick a row to update based on id column.

But I want this to live in a function that is not specialised to Registration. I want it to work for any (suitable) type. So I can't talk about Proxy Registration. I want to be able to write something like:

gupdateInto :: (PG.ToRow a, PGS.HasFieldNames a) => a -> stuff -> IO ()
...
  let fns = PGS.fieldNames $ (GS.Proxy :: a)
...

... which doesn't work by default - that final reference to type variable a doesn't get connected up with the type variable a used in the type signature.

We can turn on two language features, ScopedTypeVariables and RankNTypes, to make that work.

The type signature then ends up being about the same length as the body of the function:

gupdateInto :: forall r. forall s.
    (PG.ToRow r, PGS.HasFieldNames r,
     PG.ToRow s)
  => PG.Connection -> PG.Query -> PG.Query -> r -> s -> IO Int64
gupdateInto conn tbl whereclause val where_val = ...

Here, r is the type of data we're going to write (eg. Registration). We need to be convert it to an SQL row (ToRow) and to get the field names for it (HasFieldNames).

Then, s will be the type of whatever we're using to select the record(s) to update - for example an index Integer. We also need to be able to turn that into a row of data to send to PostgreSQL; but we don't need any field names for it as we're just using it as parameters for the UPDATE.

That PG.Query is actually something String-like, not a fully formed abstract database query of some sort - to generate those from string literals, we'll also need the OverloadedStrings language extension enabled. (That's also why the string munging above uses fromString - fieldNames returns text made out of String, but execute needs text made out of PG.Query.)

And finally the return value, Int64 is what PG.execute returns: the number of rows that were affected by the UPDATE.

So here's the whole massive pile, which I've put in its own file at src/Update.hs:

{-# Language OverloadedStrings #-}
{-# Language ScopedTypeVariables #-}
{-# Language RankNTypes #-}

module Update where

import Control.Monad.IO.Class (liftIO)

import Data.Int (Int64)
import Data.String (fromString)
import Data.List (intercalate)
import Data.Monoid ( (<>) )

import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.SOP as PGS

import qualified Generics.SOP as GS

gupdateInto :: forall r. forall s.
    (PG.ToRow r, PGS.HasFieldNames r,
     PG.ToRow s)
  => PG.Connection -> PG.Query -> PG.Query -> r -> s -> IO Int64
gupdateInto conn tbl whereclause val where_val = do
  let fieldNames = PGS.fieldNames $ (GS.Proxy :: GS.Proxy r)
  let fieldSets = map (\name -> name <> " = ?") fieldNames

  let sql = ("UPDATE " <> tbl
          <> " SET " <> (fromString $ intercalate ", " fieldSets)
          <> " WHERE " <> whereclause)

  PG.execute conn sql (val PG.:. where_val)

Now we can use this in app/Main.hs:

gupdateInto conn "registration" "id = ?" newRegistration (fromIntegral identifier)

instead of the previous:

PG.execute conn "UPDATE ...

As we're now passing a whole Registration into postgresql-simple, and to satisfy the gupdateInto type signature, we need to add another instance declaration for Registration, PG.ToRow. This is like the mirror image of PG.FromRow, and can be automatically derived.

So that's all the explicit field names removed from the SQL parts of codebase.

More Generic SQL (12)

In the last post, we made a bunch of changes throughout the codebase to support an additional field.

Some of those changes are fairly mechanical: for example, when we SELECT a Registration out of the database, we always need to request all of the fields in a Registration (else we can't give sensible values for every parameter of the constructor).

Some of this work is done already in postgresql-simple. As long as we include the all the fields in the right order in a SELECT, then the FromRow typeclass can figure out how to turn those fields into a single Registration value. The code already does that at every SELECT.

But we still need to include all the fields. This should be automatable. And indeed it is, using postgresql-simple-sop.

There isn't much to this: it gets the list of fields in a specified datatype, and sticks them in a SELECT statement for you.

This is the first package we're going to encounter that is neglectware: last updated on hackage in 2015, and until a few days ago, the git version wouldn't build against the stack snapshot that I'm building. That last problem is fixed as of last weekend, and so we can get the package from github (rather than from a curated stack snapshot). (actually there's been a bunch of other development buried in a branch of a fork in a previous employer's github repo, but it never got merged to release/master)

To do that, add a dependency for postgresql-simple-sop for the reg-exe executable. This will give a build error about the stack configuration has no specified version - because there isn't one in the stack snapshot I'm using.

So tell stack to download the dependency from github, in extra-deps in stack.yaml, alongside the two existing extra dependencies:

extra-deps:
- digestive-functors-0.8.3.0
- digestive-functors-blaze-0.6.2.0
- git: https://github.com/openbrainsrc/postgresql-simple-sop
  commit: d1834bda124081ad6a39fd4849a40d4b2fa74b3e

So in addition to (previously) telling stack that yes we want it to use those specific versions of two digestive functor packages, we've specified which package we want for postgres-simple-sop as a specific git version. (you could also write master there instead of a commit, to use the latest on a master branch. But magically updating dependencies is troublesome in the long run.

Now instead of this:

PG.query
  conn
  "SELECT firstname, lastname, dob, swim FROM registration WHERE id = ?"
  [identifier]

... we can instead write:

We can now write things like this:

import Database.PostgreSQL.Simple.SOP as PGS
...
PGS.gselectFrom conn "registration where id = ?" [identifier]

... although to allow this new library to work we have to add some more instance declarations on Registration:

import qualified Generics.SOP as GS
import qualified Database.PostgreSQL.Simple.SOP as PGS

...

instance GS.Generic Registration
instance GS.HasDatatypeInfo Registration
instance PGS.HasFieldNames Registration

... with generics-sop added as a dependency in package.yaml.

generics-sop is a different implementation of generics (different from GHC.Generics) that is nicer to use if you're writing generic code (rather than using it, as we are here).

HasFieldNames is a typeclass that says we can get an SQL field name for each entry in the Registration type. Because we don't specify any actual implementation code, the default will use generics-sop to generate them from the names used in the Haskell declaration. We don't have to do it that way though, and can specify a different implementation, if the names don't align. (I was expecting this all along so I was secretly careful to call my SQL field names the same as my Haskell field names).

There are three instances of SELECT to be replaced in the above style.

It would be nice if you could do this for the single UPDATE too, but the master version of postgres-simple-sop doesn't provide that. So next post, I'll dig into what is happening inside a bit more, and write my own UPDATE variation of gselectFrom.

Can you swim? (11)

The last post added a swim boolean column to the database, but that is ignored by everything on the Haskell side. The code will compile and run, but silently ignore this extra column.

You can try this out, but remember that we deleted all the registrations in the last post so you might need to INSERT some more, just like in this earlier post.

I want it to appear as a checkbox on the registration form.

So here's a list of things that need changing:

Modify the Registration data type in src/Registration.hs. Add on a new field there:

  swim :: Bool

This now breaks compilation - the resulting type errors will lead us towards some (but not all) of the places we need to make changes.

The first type error reports something like:

Couldn't match type `Bool -> Registration' with `Registration'

... in the definition for registrationDigestiveForm. This is where digestive-functors is told about all the fields in a Registration. The three existing fields have all been string based, using wrappers around DF.string. There's a fairly obviously named DF.bool that can be used in a similar fashion. There won't be any extra validation on this field, so we don't need any validation wrappers like dateLikeString.

The next compile error is related to CSV generation:

    * No instance for (CSV.ToField Bool)

That means that cassava, the CSV library, doesn't know how to render a Haskell bool into a CSV file.

So we can write this in a new module in src/Orphans.hs. add cassava as a library dependency in package.yaml, and then import Orphans in app/Main.hs.

module Orphans where

import qualified Data.Csv as CSV

instance CSV.ToField Bool
  where
    toField bool = CSV.toField (show bool)

... which defines an orphan instance, generally regarded as a bad thing. So don't do this unless you're lazy. We're going to be lazy. (a good thing to do is define this either where Bool is defined or where ToField is defined - which we can't do without editing the source for those - or define a new wrapper datatype and define the instance next to that). At least, I'm trying to keep any orphan instances in one place.

What the instance above does is turn the Bool into a String, and then uses the existing cassava-provided code to render that String into CSV. (render is a bit of a pretentious term for that - pretty much all it does is dump the string into the CSV file with a few escapes for " and ,).

So now the code compiles! And the server starts up!

But when we view a registration (for example http://localhost:8080/registration/1) there's a runtime server error - which I have formatted for easier reading:

ConversionFailed {
  errSQLType = "3 values: [\"text\",\"text\",\"text\"]",
  errSQLTableOid = Nothing,
  errSQLField = "",
  errHaskellType = "at least 4 slots in target type",
  errMessage = "mismatch between number of columns to convert and number in target type"
}

Where is your compile time static type checking god now?

What's happened is that the SQL SELECT statement asks for three fields (firstname, lastname and dob), and then tries to turn those into a Registration, which used to have three fields too. But now it has four.

The most immediate solution is to fix that SELECT, and all the others, and the one UPDATE too, to list all four fields.

But that *still* doesn't work. Yet another undetected type mismatch is that in a Haskell Registration, the swim boolean always has a value - no nulls. But the swim column in the database is nullable, as PostgreSQL columns are nullable by default. Whoops.

It's too late to go fix this in the last posts though so I'll use the lovely migration infrastructure to fix it now:

Create migrations/0002-swim-mandatory.sql:

UPDATE registration SET swim = FALSE WHERE swim IS NULL;
ALTER TABLE registration ALTER COLUMN swim SET DEFAULT FALSE;
ALTER TABLE registration ALTER COLUMN swim SET NOT NULL;

... and ensure that migration is applied:

$ stack exec migrate migrate user=postgres migrations/

There's a data modelling issue here: I might like partially completed registrations to be stored in the database without an answer for this question rather than defaulting one way or another. In that case, a better Haskell representation might be Maybe Bool. I'll ignore that for now and maybe come back to the issue much later.

At this point, we can view and edit registrations again. But the swim field doesn't appear in the HTML form. So here's another place where the type system doesn't detect that we're missing fields (although it's more reasonable to expect that a web form might not include all of the fields in a database row, so we can't be too annoyed).

digestive-functor's view of a form is gatewayed to HTML in the htmlForRegistration, and that's where we'll add in the new swim field. Previously we used DB.inputText for next. There's a similar inputCheckbox that will give a checkbox (surprise).

htmlForRegistration view =
...
      B.p $ do  "Date of Birth: "
                DB.errorList "dob" view
                DB.inputText "dob" view
      B.p $ do  "Can participant swim?: "
                DB.errorList "swim" view
                DB.inputCheckbox "swim" view
      B.p $     DB.inputSubmit "Save"

With this change, we now can edit the swim field, see it saved in the database, and see it successfully exported in CSV.

Next post I'm going to look at getting rid of some of the manual work / opportunities for mistakes around those SQL SELECT statements; and the changes for today's post are in commit e8848d2dd.

Changing the SQL schema (10)

The database so far is pretty simple: there are a couple of name fields, and a date of birth. Eventually, I'd like to add in a load of other fields.

One way to do this is to over-engineer an Inner Platform that allows some non-programmer admin to add in fields as they see fit. Another way is to hardcode the choice of fields into the codebase, and that is the way I'm going to proceed.That means to customise for a particular event, you need to fork the codebase and change stuff all the way through the code, which is icky, but this is really only for a couple of events for now.

As an example, I'd like to ask if a registrant can swim, and store the result as a PostgreSQL BOOLEAN column.

On the database side, there are a couple of ways to add this column: if you don't care about the data in your database, modify the appropriate CREATE statement in tables.sql, delete the database and create a new fresh database.

If you have any data, that's not so good - all the previously registered registrations will disappear.

Instead you can modify the schema of a database using PostgreSQL's ALTER command. For example:

postgres=# ALTER TABLE registration ADD COLUMN swim BOOLEAN;
ALTER TABLE
postgres=#

This doesn't lose existing registration, so is better.

But now for every deployment of the app, you need to remember to run the appropriate ALTER statements. (and yes there will be more than one deployment, even for such a small use case: there's a copy on my laptop for hacking on, and the copy people will use for real).

As a programmer, who cares? You throw the software over the wall to the lazy incompetant ops team, and leave it to them to screw up following your poorly written upgrade instructions. As an ops person, though, you'd much rather the programmers wrote their poorly written upgrade instructions in something that had actually been tested by the testing system before being passed on to you to discover the bugs.

Fear not! There's a pretty standard way of handling this, and there's a Haskell implementation called postgresql-simple-migration. Install that now with stack build postgresql-simple-migration.

What we do is write out each bit of SQL that needs to run in a series of files in a directory. When a new SQL statement needs running on all existing databases, put that in a new file in that directory. Let postgresql-simple-migration handle the tracking and executing of the commands when each installation of the application is upgraded.

To begin, set this up so that it will just create the same database schema as we've been using already: make a directory called migrations/ and rename the existing tables.sql to migrations/0000-create.sql. Then delete the existing database and let postgresql-simple-migrations take charge:

psql --user=postgres -c "DROP TABLE registration;"

stack exec migrate init user=postgres
Initializing schema

stack exec migrate migrate user=postgres migrations/
Execute:        0000-create.sql

If you run migrate again, it will report a different status for 0000-create:

stack exec migrate migrate user=postgres migrations/
Ok:     0000-create.sql

... which says that migrate didn't need to run that migration but that it is happy that it has been done already. So to get a nice mathsy term in, migrate is idempotent.

Now it's time to run that ALTER command to add the SWIM column.

Open your favourite SQL-editing text editor, or /bin/cat, and create a file called 0001-swim.sql containing the single line:

ALTER TABLE registration ADD COLUMN swim BOOLEAN;

... and run the migration command again:

stack exec migrate migrate user=postgres migrations/
Ok:     0000-create.sql
Execute:        0001-swim.sql

(Note the poor indentation. It's using \t tabs. We can have a debate about that. But we won't.)

migrate has seen that 0000-create has been run already, and that 0001-swim is new and so has executed it.

If this was a fresh database, both of the scripts would have been run, hopefully resulting in the same final schema. They're run in alphabetical order, so using a fixed-width sequence number gives an obvious way to put things in order until you run out of four digit integers. I've seen a date stamp commonly used too - I don't have a huge amount of opinion on the matter.

You need to be a bit careful here though. It is possible to add migrations out of order: for example, having added 0001-swim and had it deployed, I could add 0001-a which is *before* 0001-swim. Now, on a fresh database, they'll run in the order: 0000-create, 0001-a, 0001-swim. But in the database that has already been around a while, they'll have been applied in the order 0000-create, 0001-swim, 0001-a. This is the sort of thing that can happen with multiple developers working on different branches and merging their results without remembering to look out for this, although it's often the case that swapping the order doesn't matter much (for example, two column adds can happen in either order - the effect will be observable but shouldn't break properly written code).

Another degeneracy is when someone messes with existing migrations in version control to "fix" a problem that has happened. This can easily lead to database schemas in existence which can't be recreated by any one version of the software, an unfortunate circumstance.

And yet another downside is we now don't have a single set of CREATE statements to create the final database schema. Instead you have to run all the migrations and observe them in a live database.

Nevertheless, it is a pretty simple, and very common, solution to the problem of SQL schema upgrades.

It's also possible to make migrations happen at the beginning of reg-exe. That makes sense if there is one copy of reg-exe pointing at the database, and nothing else.

But did you know you can run *two* copies of reg-exe pointing at the same database? (or at least, I hope so - I haven't tried it). Magic scalability. In that case, it doesn't (always) make sense for an older version of the software to be talking to a database with a newer schema.

So although I'm not expecting to have super-scalability with this project, I still have a personal preference to manage the migrations separately from other processes which touch the database - even though it's one more deployment step to fuck up.

Here's the commit for this post - 599735f5. In the next post, I'll go over the changes to the Haskell code needed to support this new swim field.

ps. My notes for this post also say "some waffle about how the migrations are like a fold, done over database schema".

Suggesting a filename for a downloaded file (9)

Last post, I got the code generating CSVs but (at least in my case) my browser chooses a lame filename: just "csv". I'd much rather it chose something like "registrations.csv". (It decided on "csv" because that was the last component of the URL path.

One way to accomplish this is by adding on a new HTTP header called Content-Disposition.

Here's a change to the API to specify that header:

type CSVAPI = "admin" :> "csv" :> S.Get '[SC.CSV] (S.Headers '[S.Header "Content-Disposition" String] [Registration])

This changes the previous CSVAPI in one place - the type that servant will expect back from the handler code. Why? Because in addition to [Registration] to be serialised, we also need to return a value to go into this content-disposition header. servant is going to check at compile time that we have supplied headers as required by the API.

The updated handleCSV still needs to SELECT the registrations from the database, but needs to wrap those values with a call to addHeader.

handleCSV :: S.Handler (S.Headers '[S.Header "Content-Disposition" String] [Registration])
handleCSV = do
  rs <- liftIO $ bracket
    (PG.connectPostgreSQL "user='postgres'")
    PG.close
    $ \conn -> do
      PG.query
        conn
        "SELECT firstname, lastname, dob FROM registration" ()
  return $ S.addHeader "attachment;filename=\"registrations.csv\"" rs

That was a pretty small change, but now http://localhost:8080/admin/csv should result in a CSV file with a better filename. As the filename is specified as part of the return value of the handler, it should be straightforward to (for example) put a date/time stamp in the filename, or something else like that to disambiguate multiple downloads over time.

Exporting as CSV (8)

So far we've built a pretty lame way for people to fill out their registration forms (as long as they know the URL their a pre-created registration...).

Once that's all happened, it would be nice to do something with the data. One of the main ways I want to do this with the real life version of this booking system is send it on to various other non-geek humans to fiddle with as they please in their favourite spreadsheet app.

The cheap and cheerful way to do this is to dump everything out in one big CSV file (and leave it to some other poor sucker to deal with the inevitable encoding problems etc). It turns out there really isn't much to build on top of what already exists to make that happen - there is already cassava to handle CSV in Haskell, and the almost inevitable servant-cassava that does what it says in the package name.

Add servant-cassava and cassava as dependencoes in package.yaml and:

import Servant.CSV.Cassava as SC

...
type CSVAPI = "admin" :> "csv" :> S.Get '[SC.CSV] [Registration]

This declares a URL path /admin/csv which we can GET - so use as a regular URL in a browser or wget. What's different?

Multiple literal path components - subdirectories if you want to pretend the URL space is backed by a posix-like file system. Just string a bunch of those in a row.

The two type parameters for Get are different:

Previously we've always had SB.HTML as the first type parameter, meaning that the wire-side content type will be text/html . This is how a browser knows that it should try rendering the response as HTML. This has changed to a new content type text/csv provided by servant-cassava, which will tell your browser that what is coming over the wire is a CSV file. That's how it knows to do whatever it does: perhaps offer you the chance to open in a spreadsheet app or save to disk, rather than trying to render it as HTML.

The second type parameter has changed too: previously we specified B.Html meaning that a Haskell handler for this API will return a B.Html value. This is because we've been generating the structure of the HTML ourselves; all servant(-blaze) has had to do is convert that into a wire format and send it. In the admin/csv endpoint, we' going to return a list of Registrations from our handler - something much closer to our application - and we're not going to write any "rendering" / "conversion" code inside the handler. Instead that conversion will happen inside servant-cassava.

import qualified Data.Csv as CSV
[...]
handleCSV :: S.Handler [Registration]
handleCSV = 
 liftIO $ bracket 
    (PG.connectPostgreSQL "user='postgres'")
    PG.close
    $ \conn -> do
      PG.query
        conn
        "SELECT firstname, lastname, dob FROM registration" ()

instance CSV.ToNamedRecord Registration
instance CSV.DefaultOrdered Registration

This will SELECT all the rows in the database (like previous SELECT queries but without a WHERE clause to filter, and return a list of those rows.

cassava needs to know how to turn a Registration into a CSV row, but there is an "obvious" way to do it and those two instance declarations says "do it the obvious way".

And that's all there is to it. Hit localhost:8080/admin/csv and you'll get a CSV file back...

... although it might have a bit of a rubbish filename (like csv without a .csv on the end like you're probably used to.

Next post I'll fix that.

Validating a form and displaying errors (7)

The previous post ended with code that had an error path for invalid forms, but no easy way to enter invalid data to try it out.

That's because the implemented registration form is so "open" - it has three text fields into which you can put anything you want.

I'm going to make the form a little bit more aggressive: I'm going to require the first and last name fields be non-empty (better hope you have two names else you can't come to play); and I'm going to further restrict the date of birth field to contain only numbers and the symbols / and -.

Validation rules can be added in the definition of a DF.Form. The form for registrations is defined like this:

registrationDigestiveForm initial = do
  Registration
    <$> "firstname" .: DF.string (Just $ firstname initial)
    <*> "lastname" .: DF.string (Just $ lastname initial)
    <*> "dob" .: DF.string (Just $ dob initial)

... and it defines each of the fields as being a DF.string. But that can be replaced with something user defined, such as this:

nonEmptyString def =
    (DF.check "This field must not be empty" (/= ""))
  $ DF.string def

... which declares a non-empty string: it's going to behave like a DF.string which takes any string, but additionally it will check that submitted string is not "", the empty string, and if it is, the form will fail to validate, giving the error "This field must not be empty".

So we can redefine registrationDigestiveForm like this:

registrationDigestiveForm initial = do
  Registration
    <$> "firstname" .: nonEmptyString (Just $ firstname initial)
    <*> "lastname" .: nonEmptyString (Just $ lastname initial)
    <*> "dob" .: nonEmptyString (Just $ dob initial)

That's enough to catch empty fields - try this now by deleting a name. The form will be submitted to the server, but what comes back will be the form again, ready for you to correct mistakes. There won't be any clues, though, about why this form wasn't validated.

For that, digestive-functors-blaze provides another HTML-generating function: DB.errorList. It will emit the list of validation errors for a named field, if there are any. So for each field in htmlForRegistration, alongside the function that generates that input field, we can add the list of errors:

htmlForRegistration view =
  B.form
    ! BA.method "post"
    $ do
      B.p $ do  "First name: "
                DB.errorList "firstname" view
                DB.inputText "firstname" view
      B.p $ do  "Last name: "
                DB.errorList "lastname" view
                DB.inputText "lastname" view
      B.p $ do  "Date of Birth: "
                DB.errorList "dob" view
                DB.inputText "dob" view
      B.p $     DB.inputSubmit "Save"

Now let's do some stricter validation on the date-of-birth field. Here's a predicate on a string that determines if our input will be valid:

isDateLike :: String -> Bool
isDateLike s = foldr (&&) $ map isDateChar s
  where 
    isDateChar c = c `elem` ("0123456789-/" :: String)

(That type signature :: String is needed because of an ambiguity that arises from elem being pretty vague about what container type it will take, and string literals being pretty vague about what type they will actually produce. You can grumble about the foldable/traversable proposal/problem here if you like. Or blame the people who keep inventing new string libraries.)

... and now use that to define:

dateLikeString def =
    (DF.check "This field must look like a date" isDateLike)
  $ nonEmptyString def

... and use it to define the date field like this:

...
    <*> "dob" .: dateLikeString (Just $ dob initial)
...

So now date of birth has two ways of failing: it can be empty, or it can be text that doesn't look like a date. (The empty string passes the date-like test, by the way, so you'll only get one error message if you leave it empty.)

The code changes for this post are in commit 07f46e83.

Saving a POSTed form (6)

In the last post, I got as far as an HTML form you can edit in a browser and submit to a servant web server which promptly fails.

In this post, I'm going to implement the POST side of this, which needs to handle saving the result back to the database, if the input is valid, and go back to the user if not.

t

POSTs are handled by this rather poor implementation at the moment:

handleRegistrationPost = error "We'll implement this later"

First, give it a type signature. The API definition for this end point is:

 "registration" :> S.Capture "id" Integer :> S.ReqBody '[S.FormUrlEncoded] [(String,String)] :> S.Post '[HTML] B.Html

... so handleRegistrationPost will take two parameters: an Integer from the Capture (as with handleRegistration, and the form body as [(String,String)] key-value pairs.

So add on this type signature to the existing implementation (and check it still typechecks, if you want):

handleRegistrationPost :: Integer -> [(String, String)] -> S.Handler B.Html

First, load the identified registration from the database, as before: (we need this for constructing the DF.Form which always seems a bit awkward to me)

handleRegistrationPost identifier reqBody = do
  [registration] <- liftIO $ bracket
    (PG.connectPostgreSQL "user='postgres'")
    PG.close
    $ \conn -> do
      PG.query
        conn
        "SELECT firstname, lastname, dob FROM registration WHERE id = ?"
        [identifier] :: IO [Registration]

(If you're feeling fancy, factor this out with handleRegistration at this point)

We've been sent some stuff from the user's browser, containing new values for form fields. If we're lucky, those will all be valid and we can apply them to the DF.Form to get a Registration value. If we're not so lucky, the values won't be valid. However, we can still apply them to the form and represent them in a DF.View (like in handleRegistration).

  viewValue <- DF.postForm "Registration" (registrationDigestiveForm registration) (servantPathEnv reqBody)

That servantPathEnv is a helper to munge the form parameters into something digestive-functors is happy with. The code is later on in the post.

This viewValue has two cases: the form is invalid, or the form is valid; I'll deal with the invalid case first, because it is most like handleRegistration. All I've done here is change the h1 heading text. Other than that, we generate an HTML version of the view and send it back to the user.

  case viewValue of
    (view, Nothing) ->
      return $ B.docTypeHtml $ do
        B.body $ do
          B.h1 $ do "Registration (there were errors): "
                    B.toHtml (show identifier)
          htmlForRegistration view

The other case occurs when the form *does* contain enough to create a valid Registration. In this case, it should be written out to the database over the top of the existing registration:

    (_, Just newRegistration) -> do
      liftIO $ bracket
        (PG.connectPostgreSQL "user='postgres'")
        PG.close
        $ \conn -> PG.execute conn
                   "UPDATE registration SET firstname = ?, lastname = ?, dob = ? WHERE id = ?"
                   (firstname newRegistration,
                    lastname newRegistration,
                    dob newRegistration,
                    identifier
                   )
      return "Record updated."

We also need that helper servantPathEnv that I'll just paste in here without much explanation. It munges the form parameters from [(String, String)] into a form that digestive-functors likes.

Add text as a dependency in package.yaml, and then:

import qualified Data.Maybe as M
import qualified Data.Text as T
...
servantPathEnv :: Monad m => [(String, String)] -> DF.FormEncType -> m (DF.Env m)
servantPathEnv reqBody _ = return env
  where
      pathAsString = T.unpack . DF.fromPath
      packAsInput = DF.TextInput . T.pack
      lookupParam p = lookup (pathAsString p) reqBody
      env path = return (packAsInput <$> (M.maybeToList (lookupParam path)))

So now you should have a form you can update. Edit the names. Save. Go to another computer, and observe that the form has your changes.

You might wonder, though, how we ever hit that code path that comes back to you when your input is invalid. That's not really going to happen the way things are set up now, because this form will accept pretty much anything. Next time, I'll implement some validation rules to give some restrictions on what you can put into a form.

Commit dbe32fea contains the changes for this post.

An editable form in your browser (5)

If you're up to date with the last post, you should have a registration system that can show user info in a web browser, but needs information to be edited directly in the SQL database using some other tool.

This post aims to change that: instead of a read only view of a registration record, the fields in your web browser should become editable, with a save button to save your changes. Just like in 1993.

There's a lot of fiddly book keeping with forms: for example, if some entered value is invalid, the form should be presented again to the user for fixing, with suitable error messages, and without losing all the values they've just entered.

The digestive-functors package provides some infrastructure to help with this, and that's what I'll use in this post.

It will need integrating with blaze, so that it can generate the right HTML to send to the user. This has already been done in the digestive-functors-blaze package.

It will also need integrating with servant so that it can receive form data from the user. This needs a helper function which I'll show below.

The idea with digestive functors is that you have a Haskell datatype representing the values of your form. For this form, the existing Registration type will suffice. Then you wire up the fields of this datatype to form fields in two places: once in the HTML to get an HTML <INPUT> tag to appear so people can put in values; and once to get values back out of the form submission into a value of the Registration datatype.

First, we have to prat around with stack: digestive-functors and digestive-functors-blaze is not available by default (for reasons, presumably) so when you add them to the dependencies section of reg-exe in package.yaml you'll get a build error. At least if you're using the same stack resolver as me (lts-10.4).

The error message helpfully tells you how to modify stack.yaml to make this work, though, so I can't complain too much: add this into stack.yaml

extra-deps:
- digestive-functors-0.8.3.0
- digestive-functors-blaze-0.6.2.0

With those dependencies installed, let's write some code.

We're going to have two URL endpoints now: the same registration/1 endpoint from before, and a new one to receive form submissions. This new one will have the same URL, but will receive HTTP POST commands instead of the HTTP GET that everything so far has used. (That's a style of using HTTP where things which do not change the world should use GET, and things which do change the world should use POST: so GET is "pure" and POST is "like IO")

This new POST endpoint is declared like this:

type RegistrationPostAPI = "registration" :> S.Capture "id" Integer :> S.ReqBody '[S.FormUrlEncoded] [(String,String)] :> S.Post '[HTML] B.Html

handleRegistrationPost = error "We'll implement this later..."

API = ... :<|> RegistrationPostAPI

server = ... :<|> handleRegistrationPost

It is quite similar to the RegistrationAPI: a bunch of pieces separated by :>. There's a constant URL fragment ("registration"") and then a captured variable for the registration ID, using Capture.

But then there's another section to capture more: the request body (ReqBody). This is something that doesn't exist in HTTP with regular GET requests. With POST requests, the browser can upload a big lump of data. In the case of an HTML form, that lump contains the values of all the form fields. The parameters to ReqBody act a bit like the parameters to Get and Post: they describe the on-the-wire encoding (HTTP's x-www-form-urlencoded type) and a corresponding Haskell datatype to decode that encoding into - in this case, a list of String key-value pairs.

At the end, Get has been replaced with Post to indicate that this piece of API uses HTTP POST. The type parameters are the same, indicating that HTML will be returned on the wire, and that this will come from blaze-html HTML values on the Haskell side.

The GET endpoint needs to return an editable HTML view of the chosen Registration always. The POST endpoint will have different behaviour though. The "expected" behaviour that you'd naturally go and implement right away is that it will update the database with the provided values. But there's another case that is also likely: that the POST data will contain invalid data, in which case we need to present the HTML form again, with suitable errors.

First let's factor out the HTML generation into a separate function, so that it can be used by both the GET and POST implementations. Move the HTML generating code at the end of handleRegistration into its own function:

handleRegistration :: Integer -> S.Handler B.Html
handleRegistration identifier = do
-- ...
  return $ B.docTypeHtml $ do
    B.body $ do
      B.h1 $ do "Registration "
                B.toHtml (show identifier)
      htmlForRegistration registration


htmlForRegistration :: Registration -> B.Html
htmlForRegistration registration = do
  B.p $ do  "First name: "
            B.toHtml (firstname registration)
  B.p $ do  "Last name: "
            B.toHtml (lastname registration)
  B.p $ do  "Date of Birth: "
            B.toHtml (dob registration)

Now we're ready to start making changes to use Digestive Functors.

digestive-functors has a few types that wrap around your base content datatype (which is Registration in this case).

First there is digestive-functors's model of a form, DF.Form. In our case, it will have this type: DF.Form B.Html m Registration, saying its a form for providing a Registration, and that if there are error messages, they will be represented by B.Html - pieces of blaze-html HTML. Never mind that m for now.

Secondly there's a view, DF.View, of a form: this stores the state of a form that is being filled out, no matter whether it is valid or not. If it turns out to be valid (i.e. completed correctly), you can extract out a Registration from it; if not, you can extract out some error messages to go back into the (HTML) form to show to the user again.

It gets a bit tangly with multiple similar-but-different meanings for the word "form".

Define the DF.Form that we're going to get users to fill out:

import qualified Text.Digestive as DF

[...]

registrationDigestiveForm :: Monad m => Registration -> DF.Form B.Html m Registration
registrationDigestiveForm initial = do
  Registration
    <$> "firstname" .: DF.string (Just $ firstname initial)
    <*> "lastname" .: DF.string (Just $ lastname initial)
    <*> "dob" .: DF.string (Just $ dob initial)

This uses <$> because it is the Functor bit of Digestive Functors. The form says that the three fields of Registration will come from (in order) a form field called firstname, a form field called lastname and a form field called dob. You better hope that these match up with the order of the fields in Registration because there is no static checking of that. The code also declares that the three fields will be strings, and that their initial value will come from the supplied Registration records. (There's not a lot written about getting default values into digestive functor forms, but this is one way.)

Given this form, we can get a DF.view of a form populated with a value we've read from the database, in handleRegistration:

  view <- DF.getForm "Registration" (registrationDigestiveForm registration)

... and now instead of passing a complete Registration value to htmlForRegistration to generate the HTML for the user, we instead pass that DF.view. This will have all the fields of a Registration but can accomodate invalid values too.

We'll need to make some serious changes to htmlForRegistration to make it into a form:

import Data.Monoid ( (<>) )
import Text.Blaze.Html5 ( (!) )
import qualified Text.Blaze.Html5.Attributes as BA
import Text.Digestive.Blaze.Html5 as DB

htmlForRegistration :: DF.View B.Html -> B.Html
htmlForRegistration view =
  B.form
    ! BA.method "post"
    $ do
      B.p $ do  "First name: "
                DB.inputText "firstname" view
      B.p $ do  "Last name: "
                DB.inputText "lastname" view
      B.p $ do  "Date of Birth: "
                DB.inputText "dob" view

So, what should work now is if you go to a registration URL such as http://localhost:8080/registration/1 you should see an editable version of a Registration record. But when you click the Submit button, you'll get a server error in the browser, and an error message on the console output of servant: because this is the point that we hit:

handleRegistrationPost = error "We'll implement this later..."

That's quite a lot of wiring stuff up just to, apparently, turn our data paragraphs into HTML input fields. Next time, I'll implement the POST side of this, which needs to handle saving the result back to the database, if the input is valid, and properly displaying an error to the user if not.