2011-09-15

Yesod Cookbook: Internationalized Form

I posted the following example of an internationalized form to the Yesod Cookbook a few days ago. Yesod has a pretty awesome library for programming with forms and also a flexible but currently under-documented system for internationalization. However, how the two interact, while straightforward, might not be immediately obvious to the newcomer. Hence the motivation for the below example which shows how to internationalize both custom messages and Yesod's built-in FormMessages (mostly form error messages).

Familiarity with Yesod at the level of the Yesod Book is assumed.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
{-

INTERNATIONALIZED FORM

Below is an example of how to internationalize a Yesod application,
including internationalization (i18n) of a form and Yesod's built-in
form error messages.

In the example we create a simple site that will show messages in
Swedish or English depending on the browser's preferred language.
If neither Swedish or English are preferred languages the site will
default to Swedish.

Familiarity with Yesod at the level of the Yesod book is assumed,
comments are concentrated to the parts relevant to i18n.

-}

{-# LANGUAGE QuasiQuotes
           , TemplateHaskell
           , MultiParamTypeClasses
           , OverloadedStrings
           , TypeFamilies
  #-}

import Yesod
import Yesod.Form.I18n.Swedish
import Control.Applicative ((<$>), (<*>))
import Data.Text (Text)


-- Our foundation data type.
data MyApp = MyApp

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

instance Yesod MyApp where
    approot _ = ""


-- Here we provide internationalization of Yesod's built in form
-- messages (mostly error messages). For brevity it is assumed that
-- Swedish translations are exported as 'swedishFormMessage' by the
-- module Yesod.Form.I18n.Swedish (an implementation can be copied
-- from https://gist.github.com/1209328).
instance RenderMessage MyApp FormMessage where
    renderMessage _ []        = swedishFormMessage -- Default to Swedish
    renderMessage _ ("sv":ls) = swedishFormMessage
    renderMessage _ ("en":ls) = defaultFormMessage -- English
    renderMessage m (_   :ls) = renderMessage m ls

-- Next we define the custom messages present on the site and their
-- rendering functions for different languages.
data Msg = Model
         | Year
         | Please

-- Rendering function for English.
renderEnglish Model  = "Model"
renderEnglish Year   = "Year"
renderEnglish Please = "Please fill in your car's details"

-- Rendering function for Swedish.
renderSwedish Model  = "Modell"
renderSwedish Year   = "Årgång"
renderSwedish Please = "Vänligen fyll i uppgifterna för din bil"

-- The instance used to select the appropriate rendering function.
-- This is almost identical to the instance for FormMessage above.
instance RenderMessage MyApp Msg where
    renderMessage _ []        = renderSwedish -- Default to Swedish
    renderMessage _ ("sv":ls) = renderSwedish
    renderMessage _ ("en":ls) = renderEnglish
    renderMessage m (_   :ls) = renderMessage m ls


-- The data model.
data Car = Car
    { carModel :: Text
    , carYear :: Int
    }
  deriving Show

-- In our form we use our messages Model and Year as field labels.
carAForm :: AForm MyApp MyApp Car
carAForm = Car
    <$> areq textField (fs Model) Nothing
    <*> areq intField  (fs Year)  Nothing
    where
        fs msg = FieldSettings msg Nothing Nothing Nothing

carForm :: Html -> Form MyApp MyApp (FormResult Car, Widget)
carForm = renderTable carAForm


-- Our handler just shows the form, with submitted values pre-filled.
-- Here we also use the Please message.
getRootR :: Handler RepHtml
getRootR = do
    ((_, widget), enctype) <- runFormGet carForm
    defaultLayout [whamlet|
        <p>_{Please}
        <form method=get action=@{RootR} enctype=#{enctype}>
            <table
                ^{widget}
            <p><input type=submit>
        |]


-- | Launch the app on port 3000.
main :: IO ()
main = warpDebug 3000 MyApp

Flattr this

2011-06-17

Toy URL shortener with Yesod and acid-state

Updated 2011-08-31: Modified urlForm to work with Yesod 0.9.1.

Herein we will create a rudimentary unsafe URL shortener – a toy. We will see how to use David Himmelstrup’s acid-state to persist a data structure and how to use Michael Snoyman’s Yesod to build a simple web application.

This URL shortener is unsafe not in the sense of unsafePerformIO or unsafeCoerce, but in the sense that it is wide open to abuse. If you use it as anything other than a toy The Internet (spammers et al) will have you for breakfast. Jason Jacek has written a good article on the good and bad of URL shorteners; if you are looking for a non-toy URL shortener use one of the products he recommends.

This post is literate Haskell; just copy and paste it into a .lhs file and build/run with GHC.

Preliminaries

Language extensions, imports, and all that. There’s just no way around them!

> {-# LANGUAGE DeriveDataTypeable #-}
> {-# LANGUAGE MultiParamTypeClasses #-}
> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE QuasiQuotes #-}
> {-# LANGUAGE StandaloneDeriving #-}
> {-# LANGUAGE TemplateHaskell #-}
> {-# LANGUAGE TypeFamilies #-}
> import Control.Exception (bracket)
> import Control.Monad.Reader (asks)
> import Control.Monad.State (gets, put)
> import Data.Acid
> import Data.IntMap (IntMap, Key, empty, insert, lookup)
> import Data.SafeCopy
> import Data.Text (Text)
> import Data.Typeable
> import Prelude hiding (lookup)
> import System (getArgs)
> import Yesod hiding (Key, insert, Update, update, get)
> type URL = Text
> -- type Key = Int is provided by Data.IntMap.

State

We first create an appropriate (for some definition of appropriate) data structure for storing URLs. Then we will give that data structure ACID (Atomicity, Consistency, Isolation and Durability) guarantees by way of the acid-state package.

URL storage data structure

We’re going to keep things real simple and stuff our URLs into an IntMap using sequentially increasing keys. We also keep track of the latest key assigned.

> data URLStore = URLStore Key (IntMap URL)

Now we create the API we will use for our URL store. We need to be able to create an empty store, add URLs, and retrieve the URL corresponding to a given key.

> -- | Create an empty store.
> emptyStore :: URLStore
> emptyStore = URLStore 0 empty
> -- | Add an URL to the store. Return the key to the URL together
> -- with the updated store.
> addURL :: URL -> URLStore -> (Key, URLStore)
> addURL u (URLStore n m) = let k = n+1 in (k, URLStore k (insert k u m))
> -- | Retrieve an URL from the store.
> retrieveURL :: Key -> URLStore -> Maybe URL
> retrieveURL k (URLStore _ m) = lookup k m

Nothing fancy going on so far, just the plain everyday Haskell you know and love!

Make our URL store ACIDic with acid-state

Now we’ll take our vanilla URL store and make it ACIDic using acid-state. First we’ll need Typeable and SafeCopy instances.

> deriving instance Typeable URLStore
> $(deriveSafeCopy 0 'base ''URLStore)

We also have to “port” the add/retrieve API to be ACIDic.

> -- | Add an URL to the ACIDic store. Return the key to the URL.
> add :: URL -> Update URLStore Key
> add u = do
>   (k, store) <- gets (addURL u)
>   put store
>   return k
> -- | Retrieve an URL from the ACIDic store.
> retrieve :: Key -> Query URLStore (Maybe URL)
> retrieve = asks . retrieveURL

Finally, let some magic happen and, ta-da, we have our ACIDic URL store! In particular this creates Add and Retrieve data constructors that will be used below as proxies for add and retrieve.

> $(makeAcidic ''URLStore ['add, 'retrieve])

The Yesod web app

All that is missing now is the web app that will use our ACIDic state. We’ll use Yesod to for that but only scratch the surface of all the good stuff Yesod can do (including persistence).

Seth Falcon has written a survey of URL shortening service APIs. Our API will is very basic: POST a href parameter to / to get a short URL (a GET will also do the job, I’ll let convenience trump idempotency here).

First we define the Yesod foundation type URLShort and make it an instance of Yesod. The foundation will have to carry its state.

> data URLShort = URLShort { state :: AcidState URLStore }
> instance Yesod URLShort where approot _ = ""

Then we define routes (paths) we will use. #Key will match any leading integer and discard trailing junk.

> mkYesod "URLShort" [parseRoutes|
> /      RootR      GET POST
> /#Key  RedirectR  GET
> |]

URL Shortening

The route handlers for / do the URL shortening. The only difference between a GET and a POST is where the query params come from.

> getRootR  = lookupGetParams  "href" >>= doRootR
> postRootR = lookupPostParams "href" >>= doRootR

When given a single URL store it and display its key and a HTML form for submitting another URL.

> doRootR [url] = do
>   acid <- fmap state getYesod
>   key  <- update' acid (Add url)
>   defaultLayout $ do
>     addHamlet [hamlet|<a href=@{RootR}#{key}>@{RootR}#{key}|]
>     addWidget urlForm  -- Is this "The Right Way"?

Otherwise display only the form.

> doRootR _ = defaultLayout urlForm

Here is the HTML form (we don’t bother with fancy formlets).

> urlForm = [whamlet|
> <form action=@{RootR} method=post
>   <input type=text name=href
>   <input type=submit value=Shorten!
> |]

Redirecting

The route handler for /[0–9]* retrieves the appropriate URL and redirects the client. If no URL is found for the key the client is given a 404.

> getRedirectR key = do
>   acid <- fmap state getYesod
>   url  <- query' acid (Retrieve key)
>   case url of
>     Just u  -> redirectText RedirectPermanent u
>     Nothing -> notFound
>   return ()

The return () at the end is there to help GHC infer a suitable type of getRedirectR.

Applicationification (main)

Our main runs the yesod application with its AcidState. The port number to run on must be provided. Bad arguments crash (I already mentioned that this is a toy, right?). A bracket ensures that the AcidState is checkpointed and closed on exit.

> -- Provide port number as argument.
> main = do
>   port <- fmap (read . head) getArgs
>   bracket (openAcidState emptyStore)
>           createCheckpointAndClose
>           (warpDebug port . URLShort)

Thanks to the magic of acid-state our URL store is persistent across executions. Go ahead, try it out!

Exercises

You can move this URL shortener a teenie bit further from toydom and closer to tooldom by implementing one or more of the following:

  • Use denser representation than decimal digits;
  • Don’t store duplicate URLs (reuse old key);
  • URL preview;
  • JSON, XML, and raw text content;
  • Sanity-check submitted URLs;
  • Filter spam URLs;

From there move on to authentication, statistics, and so on…

Thanks for reading!

Flattr this

2011-05-30

ANNOUNCE: dimensional-0.10

I just released version 0.10 of the dimensional library, adding an Enum instance for quantities. Thus now it is possible to, e.g.:

> import Numeric.Units.Dimensional.Prelude
> import qualified Prelude
> xs = [1 *~ meter..]  -- [1 m, 2 m, 3 m...]

However, I just realised that the behaviour may occasionally be surprising unless one keeps in mind that the default increment will be a product of SI base units and the value 1. For example:

> ys = [1 *~ kilo meter..]  -- [1000 m, 1001 m, 1002 m...]

In order to avoid shooting oneself in the foot I recommended sticking with the enumFromThen or enumFromThenTo forms:

> zs = [1 *~ kilo meter, 2 *~ kilo meter..]  -- [1000 m, 2000 m, 3000 m...]

Another option is to use *~~ (see my previous post):

> zs' = [1..] *~~ kilo meter  -- [1000 m, 2000 m, 3000 m...]

In other news I’ve added a “search this blog” widget to the right to help myself find my pandoc article that I need to refer to every time I post. Feel free to use it!

Flattr this

2011-04-20

ANNOUNCE: dimensional-0.9

I am pleased to announce version 0.9 of my dimensional library for arithmetic with statically checked physical dimensions. The differences from version 0.8.2.1 is the specification of fixity for *~~ and /~~ and their generalization to operate on functors rather than lists. The lack of fixity specifications was a bug; I had always intended them to have the same fixity as the closely related *~ and /~ (and * and / for that matter).

For readers unfamiliar with the above operators they are used to relate numerical values with units in order to construct and deconstruct physical quantities. For example:

> import Numeric.Units.Dimensional.Prelude
> import qualified Prelude
> x :: Length Double  -- type Length = Quantity DLength
> x = 1 *~ meter
> y :: Double
> y = x /~ kilo meter -- 0.001

This convention for constructing and deconstructing quantities by multiplication and division respectively is motivated by the NIST Guide to the SI, section 7.1.

The *~~ and /~~ operators are analogous to *~ and /~ but operate on functors, e.g.:

> xs :: [Length Double]
> xs = [1..] *~~ meter
> ys :: [Double]
> ys = xs /~~ kilo meter

Finally an observation for the Haskell community: the Haskell package versioning policy does not address fixity changes, which I presume should force a major version change. Unless someone either objects or beats me to it I will update the wiki to reflect this.

Flattr this

2011-04-09

ANNOUNCE: normaldistribution-1.1 – Minimum fuss normally distributed random values.

I’m pleased to announce the immediate availability of the normaldistribution library on hackage.

This purpose of this library is to have a simple API and no dependencies beyond Haskell 98 in order to let you produce normally distributed random values with a minimum of fuss. This library does not attempt to be blazingly fast nor to pass stringent tests of randomness. It attempts to be very easy to install and use while being “good enough” for many applications (simulations, games, etc.). The API builds upon and is largely analogous to that of the Haskell 98 Random module (more recently System.Random).

Pure:

> (sample,g) = normal  myRandomGen  -- using a Random.RandomGen
> samples    = normals myRandomGen  -- infinite list
> samples2   = mkNormals 10831452   -- infinite list using a seed

In the IO monad:

> sample    <- normalIO
> samples   <- normalsIO  -- infinite list

With custom mean and standard deviation:

> (sample,g) = normal'    (mean,sigma) myRandomGen
> samples    = normals'   (mean,sigma) myRandomGen
> samples2   = mkNormals' (mean,sigma) 10831452
> sample    <- normalIO'  (mean,sigma)
> samples   <- normalsIO' (mean,sigma)

Internally the library uses the Box-Muller method to generate normally distributed values from uniformly distributed random values. If more than one sample is needed taking samples off an infinite list (created by e.g. normals) will be roughly twice as efficient as repetedly generating individual samples with e.g. normal.

Update 2011–04–09: Changed to reflect version 1.1.

Update 2011–04–22: Version 1.1.0.1 released which builds with haskell98-1.1+ (GHC-7.0.1+). No code changes.


Flattr this

2011-03-31

Flattrable Reactive Programming

I have occasionally seen these “flattr this!” buttons, notably on the blog of Luke Palmer, and occasionally felt it was exactly what I wanted to do. However, inertia always got the better of me – no doubt I was busy being distracted by some lolcat screaming for adoration.

Lately I noticed a flattr button on the blog of Heinrich Apfelmus too, and again felt a desire to give. Heinrich’s blog was the tipping point (pun intended) that finally got me to actually visit flattr.com, and this great quote from Alexandros closed the sale:

This month, thanks to Flattr, I’we shared my world to the world. I earned 0.03 cents - the best 0.03 cents ever!

How can that not make me want to give? (Is Alexandros being sarcastic? He looks happy enough in his profile pic…)

My first flattrs go to Luke and Heinrich; 0.03 cents are coming your way! ;)

Alexandros gets flattred too. And now that I’ve signed up I’ll be on the lookout for more flattr buttons (so don’t feel bad if you weren’t mentioned here!).

As an aside, the common denominator that made me want to flattr Luke and Heinrich is their efforts to explore Functional Reactive Programming. It seems to me that much remains to be discovered in the FRP design space and I hope my flattrs encourage these brave explorers to push the boundaries further… Oh, look! Conal Elliott has a flattr button too!

2011-03-28

Dimensional example: leaky container pressure

Herein I demonstrate a calculation performed today in my work. The details are slightly different to protect the innocent but the problem is the same. The purpose of all this is to demonstrate use of the dimensional library. What this blog post unfortunately fails to demonstrate is how the compiler helps catch errors in units and formulae, effectively double-checking any derivations for me – this is the real value of dimensional! In case you have never heard of dimensional before here is the blurb from the project site:

Dimensional is a library providing data types for performing arithmetic with physical quantities and units. Information about the physical dimensions of the quantities/units is embedded in their types and the validity of operations is verified by the type checker at compile time. The boxing and unboxing of numerical values as quantities is done by multiplication and division with units. The library is designed to, as far as is practical, enforce/encourage best practices of unit usage.

This is a literate Haskell program. You can copy and paste this blog post into a .lhs file and it should compile and run (provided you have installed dimensional). First the formalities:

> import Numeric.Units.Dimensional.Prelude
> import Numeric.Units.Dimensional.NonSI
> import qualified Prelude

(In the below I have used parentheses rather than juxtaposition to denote function application for functions of time, e.g. p(t). Does this help or hurt clarity given the subject matter?)

Consider a leaky container of volume v filled with gas to pressure p0 and launched into space at time t0 (insert favorite monad tutorial joke here). There is a requirement that at some future time t1 said container must retain no less than a given amount of gas. The temperature T of the container is held constant by a thermal control system so per the ideal gas law (a good enough approximation) we can characterize the requirement to remnant gas by its pressure pmin. The problem at hand was to determine the maximum allowable leak rate of the container at t0 to ensure that the pressure at time t1 is no less than pmin.

Here are the inputs (don’t blame me for the choice of units, this is what I was given):

> v     =      2 *~ liter
> t_0 = 0 *~ hour
> p_0 = 750 *~ mmHg -- roughly atmospheric pressure
> t_1 = 133650 *~ hour -- about 15.25 years
> p_min = 5 *~ mmHg
> temp = fromDegreeCelsiusAbsolute 22

For slow leakage it can be assumed that the leakage rate is proportional to the pressure of the gas inside the container (more generally, the pressure difference between the gas in the container and the surrounding medium). Thus the rate of change of the pressure is described by the first order linear differential equation

> dpdt(t) = negate k * p(t)

with solution

> p(t) = c * exp (negate k * t)

The integration constant c is determined from the initial conditions at t0:

> c = p_0  -- follows from t_0 = 0 s.

We chose the worst case conditions at t1 to determine k:

> k = log (c / p_min) / t_1

Now, per the ideal gas law the amount of substance n in the container is described by

> n(t) = p(t) * v / (r * temp)

where

> r = 8.314472 *~ (joule / (mole * kelvin))

is the ideal gas constant. Differentiating n(t) give the rate of change of substance in the container:

> dndt(t) = dpdt(t) * v / (r * temp)

and the maximum allowed rate of change (leakage rate) at time t0 is produced by

> main = print (dndt t_0)  -- -8.486687441280605e-10 s^-1 mol

That’s it!