By Michael SnoymanNow that WAI has been released, my next target is to release Yesod, my web application framework. It's already the basis for about five sites, most of them with source code available. Nonetheless, I've been wanting to write a comprehensive tutorial of writing a real web application with it before releasing.
Fortunately, I just had to write the perfect sample application: a bug tracker. It's very simplistic, but does what I need while showing some of the nice features of Yesod. It also shows the very ugly side of Yesod: there is no built in model yet. That's something I hope to tackle in future versions.
In any event, here's the code straight from the repo. You can also see it on Github, though this version is prettier. It's just one long literate Haskell file along with three string template files.
I know this is a long tutorial, but don't let the size scare you off; you can skip all of the serialization code below without missing the gist of things. And yes: this is actually code I'm using in production.
{-# LANGUAGE QuasiQuotes #-}
While coming up on the first release of Yesod, I realized I needed a nice, comprehensive tutorial. I didn't want to do the typical blog example, since it's so trite. I considered doing a Reddit or Twitter clone (the former became a bit of a meme a few weeks ago), but then I needed to set up a bug tracker for some commercial projects I was working on, and I decided that it would be a great example program.
Before getting started, a quick word of warning: Yesod at this point really provides nothing in terms of data storage (aka, the model). There is wonderful integration with the data-object package, and the data-object-yaml package provides good serialization, but this is all very inefficient in practice. For simplicity, I've gone ahead and used this as the storage model; this should not be done for production code.
There's a lot of boilerplate code at the beginning that just has to do with object storage; if you'd like to skip it, just start reading from the main function.
Anyway, here's the import list.
import Yesod
import Yesod.Helpers.Auth
import Data.Object.Yaml
import Data.Object.String
import Control.Concurrent
import qualified Safe.Failure as SF
import Data.Time
import Data.Attempt (Attempt, fromAttempt)
import Control.Arrow (second)
import qualified Network.Wai.Handler.SimpleServer
import Data.Monoid
import Data.Text (pack)
import Control.Applicative ((<$>), (<*>))
import Data.Maybe (fromMaybe)
One of the goals of Yesod is to make it work with the compiler to help you program. Instead of configuration files, it uses typeclasses to both change default behavior and enable extra features. An example of the former is error pages, while an example of the latter is authentication.
To start with, we need a datatype to represent our program. We'll call this bug tracker "Tweedle", after Dr. Seuss's "Tweedle Beetle Battle" in "Fox in Socks" (my son absolutely loves this book). We'll be putting the complete state of the bug database in an MVar within this variable; in a production setting, you might instead put a database handle.
data Tweedle = Tweedle Settings (MVar Category) TemplateGroup
(For now, just ignore the TemplateGroup, its purpose becomes apparent later.)
This issue database is fully hierarchical: each category can contain subcategories and issues. This might be too much nesting for many uses, but it's what my project demanded.
Also, if I cared about efficiency here, a trie or map would probably be a better data structure. As stated above, it doesn't matter.
data Category = Category
{ subCats :: [Category]
, subIssues :: [Issue]
, categoryId :: Integer
, catName :: String
}
data Issue = Issue
{ issueName :: String
, issueMessages :: [Message]
, issueId :: Integer
}
Further simplifications: authors will just be represented by their OpenID URL.
data Message = Message
{ messageAuthor :: OpenId
, messageStatus :: Maybe String
, messagePriority :: Maybe String
, messageText :: String
, messageCreation :: UTCTime
}
type OpenId = String
We need to be able to serialize this data to and from YAML files. You can consider all of the following code boilerplate.
messageToSO :: Message -> StringObject
messageToSO m = Mapping $ map (second Scalar)
[ ("author", messageAuthor m)
, ("status", show $ messageStatus m)
, ("priority", show $ messagePriority m)
, ("text", messageText m)
, ("creation", show $ messageCreation m)
]
messageFromSO :: StringObject -> Attempt Message
messageFromSO so = do
m <- fromMapping so
a <- lookupScalar "author" m
s <- lookupScalar "status" m >>= SF.read
p <- lookupScalar "priority" m >>= SF.read
t <- lookupScalar "text" m
c <- lookupScalar "creation" m >>= SF.read
return $ Message a s p t c
issueToSO :: Issue -> StringObject
issueToSO i = Mapping
[ ("name", Scalar $ issueName i)
, ("messages", Sequence $ map messageToSO $ issueMessages i)
, ("id", Scalar $ show $ issueId i)
]
issueFromSO :: StringObject -> Attempt Issue
issueFromSO so = do
m <- fromMapping so
n <- lookupScalar "name" m
i <- lookupScalar "id" m >>= SF.read
ms <- lookupSequence "messages" m >>= mapM messageFromSO
return $ Issue n ms i
categoryToSO :: Category -> StringObject
categoryToSO c = Mapping
[ ("cats", Sequence $ map categoryToSO $ subCats c)
, ("issues", Sequence $ map issueToSO $ subIssues c)
, ("id", Scalar $ show $ categoryId c)
, ("name", Scalar $ catName c)
]
categoryFromSO :: StringObject -> Attempt Category
categoryFromSO so = do
m <- fromMapping so
cats <- lookupSequence "cats" m >>= mapM categoryFromSO
issues <- lookupSequence "issues" m >>= mapM issueFromSO
i <- lookupScalar "id" m >>= SF.read
n <- lookupScalar "name" m
return $ Category cats issues i n
Well, that was a mouthful. You can safely ignore all of that: it has nothing to do with actual web programming.
Next is the Settings datatype. Normally I create a settings file so I can easily make changes between development and production systems without recompiling, but once again we are aiming for simplicity here.
data Settings = Settings
Many web frameworks make the simplifying assumptions that "/" will be the path to the root of your application. In real life, this doesn't always happen. In Yesod, you must specify explicitly your application root and then create an instance of YesodApproot (see below). Again, the compiler will let you know this: once you use a feature that depends on knowing the approot, you'll get a compiler error if you haven't created the instance.
{ sApproot :: String
, issueFile :: FilePath
Yesod comes built in with support for HStringTemplate. You'll see later how this ties in with data-object (and in particular HtmlObject) to help avoid XSS attacks.
, templatesDir :: FilePath
}
And now we'll hardcode the settings instead of loading from a file. I'll do it in the IO monad anyway, since that would be the normal function signature.
loadSettings :: IO Settings
loadSettings = return $ Settings "http://localhost:3000/" "issues.yaml" "examples/tweedle-templates"
And now we need a function to load up our Tweedle data type.
loadTweedle :: IO Tweedle
loadTweedle = do
settings <- loadSettings
Note that this will die unless an issues file is present. We could instead check for the file and create it if missing, but instead, just put the following into issues.yaml:
{cats: [], issues: [], id: 0, name: "Top Category"}
issuesSO <- decodeFile $ issueFile settings
issues <- fromAttempt $ categoryFromSO issuesSO
missues <- newMVar issues
tg <- loadTemplateGroup $ templatesDir settings
return $ Tweedle settings missues tg
And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer.
main :: IO ()
main = do
putStrLn "Running at http://localhost:3000/"
tweedle <- loadTweedle
app <- toWaiApp tweedle
Network.Wai.Handler.SimpleServer.run 3000 app
Well, that was a lot of boilerplate code that had nothing to do with web programming. Now the real stuff begins. I would recommend trying to run the code up to now an see what happens. The compiler will complain that there is no instance of Yesod for Tweedle. This is what I meant by letting the compiler help us out. So now we've got to create the Yesod instance.
The Yesod typeclass includes many functions, most of which have default implementations. I'm not going to go through all of them here, please see the documentation.
instance Yesod Tweedle where
The most important function is resources: this is where all of the URL mapping will occur. Yesod adheres to Restful principles very strongly. A "resource" is essentially a URL. Each resource should be unique; for example, do not create /user/5/ as well as /user/by-number/5/. In addition to resources, we also determine which function should handle your request based on the request method. In other words, a POST and a GET are completely different.
One of the middlewares that Yesod installs is called MethodOverride; please see the documentation there for more details, but essentially it allows us to work past a limitation in the form tag of HTML to use PUT and DELETE methods as well.
Instead of using regular expressions to handle the URL mapping, Yesod uses resource patterns. A resource is a set of tokens separated by slashes. Each of those tokens can be one of:
- A static string.
- An integer variable (begins with #), which will match any integer.
- A string varaible (begins with $), which will match any single value.
- A "slurp" variable, which will match all of the remaining tokens. It must be the last token.
Yesod uses quasi quotation to make specifying the resource pattern simple and safe: your entire set of patterns is checked at compile time to see if you have overlapping rules.
resources = [$mkResources|
Now we need to figure out all of the resources available in our application. We'll need a homepage:
/:
GET: homepageH
We will also need to allow authentication. We use the slurp pattern here and accept all request methods. The authHandler method (in the Yesod.Helpers.Auth module) will handle everything itself.
/auth/*: authHandler
We're going to refer to categories and issues by their unique numerical id. We're also going to make this system append only: there is no way to change the history.
/category/#id: # notice that "id" is ignored by Yesod
GET: categoryDetailsH
PUT: createCategoryH
/category/#id/issues:
PUT: createIssueH
/issue/#id:
GET: issueDetailsH
PUT: addMessageH
|]
So if you make a PUT request to "/category/5", you will be creating a subcategory of category 5. "GET /issue/27/" will display details on issue 27. This is all we need.
If you try to compile the code until this point, the compiler will tell you that you have to define all of the above-mentioned functions. We'll do that in a second; for now, if you'd like to see the rest of the error messages, uncomment this next block of code.
{-
homepageH = return ()
categoryDetailsH _ = return ()
createCategoryH _ = return ()
createIssueH _ = return ()
issueDetailsH _ = return ()
addMessageH _ = return ()
-}
Now the compiler is telling us that there's no instance of YesodAuth for Tweedle. YesodAuth- as you might imagine- keeps settings on authentication. We're going to go ahead a create an instance now. The default settings work if you set up authHandler for "/auth/*" (which we did) and are using openid (which we are). So all we need to do is:
instance YesodAuth Tweedle
Running that tells us that we're missing a YesodApproot instance as well. That's easy enough to fix:
instance YesodApproot Tweedle where
approot (Tweedle settings _ _) = sApproot settings
Congratulations, you have a working web application! Gratned, it doesn't actually do much yet, but you can use it to log in via openid. Just go to http://localhost:3000/auth/openid/.
Now it's time to implement the real code here. We'll start with the homepage. For this program, I just want the homepage to redirect to the main category (which will be category 0). So let's create that redirect:
homepageH :: Handler Tweedle ()
homepageH = do
ar <- getApproot
redirect RedirectPermanent $ ar ++ "category/0/"
Simple enough. Notice that we used the getApproot function; if we wanted, we could have just assumed the approot was "/", but this is more robust.
Now the category details function. We're just going to have two lists: subcategories and direct subissues. Each one will have a name and numerical ID.
But here's a very nice feature of Yesod: We're going to have multiple representations of this data. The main one people will use is the HTML representation. However, we're also going to provide a JSON representation. This will make it very simple to write clients or to AJAXify this application in the future.
categoryDetailsH :: Integer -> Handler Tweedle RepHtmlJson
That function signature tells us a lot: the parameter is the category ID, and we'll be returning something that has both an HTML and JSON representation.
categoryDetailsH catId = do
getYesod returns our Tweedle data type. Remember, we wrapped it in an MVar; since this is a read-only operation, will unwrap the MVar immediately.
Tweedle _ mvarTopCat _ <- getYesod
topcat <- liftIO $ readMVar mvarTopCat
Next we need to find the requested category. You'll see the (boilerplate) function below. If the category doesn't exist, we want to return a 404 response page. So:
(parents, cat) <- maybe notFound return $ findCat catId [] topcat
Now we want to convert the category into an HtmlObject. By doing so, we will get automatic HTML entity encoding; in other words, no XSS attacks.
let catHelper (Category _ _ cid name) = Mapping
[ ("name", Scalar $ Text $ pack name)
, ("id", Scalar $ Text $ pack $ show cid)
]
let statusHelper = fromMaybe "No status set"
. getLast . mconcat . map (Last . messageStatus)
let priorityHelper = fromMaybe "No priority set"
. getLast . mconcat . map (Last . messagePriority)
let issueHelper (Issue name messages iid) = Mapping
[ ("name", Scalar $ Text $ pack name)
, ("id", Scalar $ Text $ pack $ show iid)
, ("status", Scalar $ Text $ pack $ statusHelper messages)
, ("priority", Scalar $ Text $ pack $ priorityHelper messages)
]
let ho = Mapping
[ ("cats", Sequence $ map catHelper $ subCats cat)
, ("issues", Sequence $ map issueHelper $ subIssues cat)
]
And now we'll use a String Template to display the whole thing.
templateHtmlJson "category-details" ho $ \_ -> return
. setHtmlAttrib "cat" ho
. setHtmlAttrib "name" (catName cat)
. setHtmlAttrib "parents" (Sequence $ map catHelper parents)
findCat :: Integer -> [Category] -> Category -> Maybe ([Category], Category)
findCat i parents c@(Category cats _ i' _)
| i == i' = Just (parents, c)
| otherwise = getFirst $ mconcat $ map (First . findCat i (parents ++ [c])) cats
Now we get a new missing instance: YesodTemplate. As you can imagine, this is because of calling the templateHtmlJson function. This is easily enough solved (and explains why we needed TemplateGroup as part of Tweedle).
instance YesodTemplate Tweedle where
getTemplateGroup (Tweedle _ _ tg) = tg
Now we actually get some output! I'm not going to cover the syntax of string templates here, but you should read the files in the examples/tweedle-templates directory.
Next, we need to implement createCategoryH. There are two parts to this process: parsing the form submission, and then modifying the database. Pay attention to the former, but you can ignore the latter if you wish. Also, this code does not do much for error checking, as that would needlessly complicate matters.
createCategoryH :: Integer -> Handler Tweedle ()
createCategoryH parentid = do
Yesod uses a formlets-style interface for parsing submissions. This following line says we want a parameter named catname, which precisely one value (required) and that value must have a non-zero length (notEmpty).
catname <- runFormPost $ notEmpty $ required $ input "catname"
newid <- modifyDB $ createCategory parentid catname
ar <- getApproot
redirect RedirectPermanent $ ar ++ "category/" ++ show newid ++ "/"
And here's the database modification code we need. Once again, this is not web-specific.
modifyDB :: (Category -> (Category, x)) -> Handler Tweedle x
modifyDB f = do
Tweedle settings mcat _ <- getYesod
liftIO $ modifyMVar mcat $ \cat -> do
let (cat', x) = f cat
encodeFile (issueFile settings) $ categoryToSO cat'
return (cat', x)
createCategory :: Integer -> String -> Category -> (Category, Integer)
createCategory parentid catname topcat =
let newid = highCatId topcat + 1
topcat' = addChild parentid (Category [] [] newid catname) topcat
in (topcat', newid)
where
highCatId (Category cats _ i _) = maximum $ i : map highCatId cats
addChild i' newcat (Category cats issues i name)
| i' /= i = Category (map (addChild i' newcat) cats) issues i name
| otherwise = Category (cats ++ [newcat]) issues i name
Next is creating an issue. This is almost identical to creating a category.
createIssueH :: Integer -> Handler Tweedle ()
createIssueH catid = do
issuename <- runFormPost $ notEmpty $ required $ input "issuename"
newid <- modifyDB $ createIssue catid issuename
ar <- getApproot
redirect RedirectPermanent $ ar ++ "issue/" ++ show newid ++ "/"
createIssue :: Integer -> String -> Category -> (Category, Integer)
createIssue catid issuename topcat =
let newid = highIssueId topcat + 1
topcat' = addIssue catid (Issue issuename [] newid) topcat
in (topcat', newid)
where
highIssueId (Category cats issues _ _) =
maximum $ 0 : (map issueId issues) ++ map highIssueId cats
addIssue i' newissue (Category cats issues i name)
| i' /= i = Category (map (addIssue i' newissue) cats) issues i name
| otherwise = Category cats (issues ++ [newissue]) i name
Two functions to go. Now we want to show details of issues. This isn't too different from categoryDetailsH above, except for one feature: we need to know if a user is logged in. If they are logged in, we'll show an "add message" box; otherwise, we'll show a login box. Once again, we're getting the JSON representation easily.
issueDetailsH :: Integer -> Handler Tweedle RepHtmlJson
issueDetailsH iid = do
Tweedle _ mvarTopCat _ <- getYesod
topcat <- liftIO $ readMVar mvarTopCat
(cat, issue) <- maybe notFound return $ findIssue iid topcat
let messageHelper m = Mapping $ map (second $ Scalar . Text . pack)
$ (maybe id (\x -> (:) ("status", x)) $ messageStatus m)
$ (maybe id (\x -> (:) ("priority", x)) $ messagePriority m)
[ ("author", messageAuthor m)
, ("text", messageText m)
, ("creation", show $ messageCreation m)
]
let ho = Mapping
[ ("name", Scalar $ Text $ pack $ issueName issue)
, ("messages", Sequence $ map messageHelper $ issueMessages issue)
]
Now we determine is the user is logged in via the maybeIdentifier function. Later on, we'll see how we can force a user to be logged in using authIdentifier.
ident <- maybeIdentifier
templateHtmlJson "issue-details" ho $ \_ -> return
. setHtmlAttrib "issue" ho
. maybe id (setHtmlAttrib "ident") ident
. setHtmlAttrib "cat" (Mapping
[ ("name", Scalar $ Text $ pack $ catName cat)
, ("id", Scalar $ Text $ pack $ show $ categoryId cat)
])
And now the supporting model code. This function returns the requested Issue along with the containing category.
findIssue :: Integer -> Category -> Maybe (Category, Issue)
findIssue iid c@(Category cats issues _ _) =
case filter (\issue -> issueId issue == iid) issues of
[] -> getFirst $ mconcat $ map (First . findIssue iid) cats
(issue:_) -> Just (c, issue)
Cool, just one function left! This should probably all make sense by now. Notice, however, the use of authIdentifier: if the user is not logged in, they will be redirected to the login page automatically.
addMessageH :: Integer -> Handler Tweedle ()
addMessageH issueid = do
ident <- authIdentifier
(status, priority, text) <- runFormPost $
(,,)
<$> optional (input "status")
<*> optional (input "priority")
<*> required (input "text")
now <- liftIO getCurrentTime
let message = Message ident status priority text now
modifyDB $ addMessage issueid message
ar <- getApproot
redirect RedirectPermanent $ ar ++ "issue/" ++ show issueid ++ "/"
addMessage :: Integer -> Message -> Category -> (Category, ())
addMessage issueid message (Category cats issues catid catname) =
(Category (map (fst . addMessage issueid message) cats) (map go issues) catid catname, ())
where
go (Issue name messages iid)
| iid == issueid = Issue name (messages ++ [message]) iid
| otherwise = Issue name messages iid