Finished HAppS Application

Update: Due to popular demand, I put the plain haskell code for this app on hpaste.org. Here are links for Session.hs, Main.hs, and login.html.

The past three posts have laid the groundwork for a full HAppS web app. We have built the infrastructure for an authentication system that can store usernames and passwords as well as the session IDs for active sessions. Here we will tie everything together to make a functional web app. It should all compile with HAppS 0.9.2. Let's get the imports out of the way.

> {-# OPTIONS -fglasgow-exts #-}
> {-# LANGUAGE TemplateHaskell , FlexibleInstances,
>              UndecidableInstances, OverlappingInstances,
>              MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
>
> module Main where
>
> import Control.Concurrent
> import Control.Monad
> import HAppS.Server
> import HAppS.State
>
> import Session --The session and state code already developed

In the first post, we created code to serve a login/registration form and handle the form submission. Some of the details have changed since the first post, but the main ideas are the same. In order to verify that our state is being held properly, we will need two additional pages. One will show which user is "logged in" (associated with the active session). We'll make that page available at the /view URL. The second page will show a list of all registered users. We'll put that page at /list. Here is the new ServerPartT list implementing this:

> impl = [ dir "login" [methodSP GET $ (fileServe ["login.html"] ".")
>                      ,methodSP POST $ withData loginPage ]
>        , dir "newuser" [methodSP POST $ withData newUserPage]
>        , dir "view" [withDataFn (liftM Just (readCookieValue "sid") `mplus` return Nothing) viewPage]
>        , dir "list" userListPage
>        , anyRequest $ ok $ toResponse "Sorry, couldn't find a matching handler" ]

The code for /view uses readCookieValue to get the session ID from the cookies in the HTTP request. It encapsulates the result in the Maybe monad for convenient error handling and uses withDataFn to pass the results to viewPage. Before we jump into the new code, we need more of the code developed in the first post for getting data from the form.

> data UserAuthInfo = UserAuthInfo String String
> data NewUserInfo = NewUserInfo String String String
>
> instance FromData UserAuthInfo where
>     fromData = liftM2 UserAuthInfo (look "username")
>                (look "password" `mplus` return "nopassword")
>
> instance FromData NewUserInfo where
>     fromData = liftM3 NewUserInfo (look "username")
>                (look "password" `mplus` return "nopassword")
>                (look "password2" `mplus` return "nopassword2")

Since user registration is the first step in the process, we'll start there. newUserPage will take a NewUserInfo as a parameter, verify that the two passwords match, and add the user to our state. If the passwords did not match, it will return a simple error. This is very simple using Haskell's guards.

> newUserPage (NewUserInfo user pass1 pass2)
>   | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)]
>   | otherwise = [anyRequest $ ok $ toResponse $ "Passwords did not match"]

The checkAndAdd function needs to check to make sure the user doesn't already exist, and then add the user or return an error. To do this, we'll call upon the isUser and addUser functions created in the last post. But we can't call them directly. We have to use the query and update functions as well as the IsUser and AddUser types created for us by mkMethods. The update function is used for operations that modify the state. query is used for read-only operations.

> checkAndAdd user pass = do
>   exists <- query $ IsUser user
>   if exists
>     then ok $ toResponse $ "User already exists"
>     else do
>       update $ AddUser user $ User user pass
>       ok $ toResponse $ "User created."

The login form now needs to verify the user's password and create a new session to log the user in. Again, the functions we've already built give us exactly this capability. The loginPage function performs the authentication, and then calls the performLogin function to create the new session. performLogin uses mkCookie to create a cookie with the appropriate key/value pair. This cookie is passed to addCookie, which also takes an argument indicating the lifetime of the cookie. A value of -1 makes the cookie last forever.

> loginPage (UserAuthInfo user pass) = [anyRequest $ do
>   allowed <- query $ AuthUser user pass
>   if allowed
>     then performLogin user
>     else ok $ toResponse $ "Incorrect password"
>   ]
>
> performLogin user = do
>   key <- update $ NewSession (SessionData user)
>   addCookie (-1) (mkCookie "sid" (show key))
>   ok $ toResponse $ "UserAuthInfo: " ++ show (user)

After seeing state queries and updates used for registration and login, the viewPage and userListPage functions will be fairly straightforward. Haskell's piecewise function definition combined with our use of the Maybe monad makes it easy to separate the "error case" where the user is not logged in.

> viewPage (Just sid) = [anyRequest $ do
>   ses <- query $ (GetSession $ sid)
>   ok $ toResponse $ "Cookie value: " ++ (maybe "not logged in" show (ses :: Maybe SessionData))]
>
> viewPage Nothing =
>   [anyRequest $ ok $ toResponse $ "Not logged in"]
>
> userListPage = [anyRequest $ do u <- query ListUsers; ok $ toResponse $ "Users: " ++ (show u)]

The main function needs a little more infrastructure when state is being used. A call to startSystemState is required for initialization. startSystemState needs to be passed an entry point Proxy that tells what data is being stored in state. It's also probably a good idea to terminate more gracefully, so I've forked a new thread for the HTTP server and and waited for termination before killing it and cleaning up.

> entryPoint :: Proxy State
> entryPoint = Proxy
>
> main = do
>   control <- startSystemState entryPoint
>   tid <- forkIO $ simpleHTTP nullConf impl
>   waitForTermination
>   putStrLn "Shutting down..."
>   killThread tid
>   shutdownSystem control
>   putStrLn "Shutdown complete"

So, in less than 200 lines of Haskell code, we have implemented a fully functional, stateful web app in HAppS. What has this gotten us that we wouldn't have in most other web frameworks? First, we have all our state stored in memory and persisted nicely on disk. I'm not going to get into a detailed comparison with the standard relational database approach, but I will highlight some of the benefits that we get from this approach.

• Our state is defined with the Haskell type system giving us all the safety of its type checking and the flexibility of its type inference.
• The HAppS state system gives us ACID guarantees on our state changes with very little of the complexity visible to the user.
• With the upcoming development of multi-master replication and sharding, HAppS will give us excellent scalability with very little impact to our application.

Second, we have developed a simple authentication framework that can be the basis for any web app that requires a user to log in. This web app framework can be used with or without the state management mechanism. With a little restructuring, the state could be completely separated from the web front-end and any method of persistence used in its place. And third, you get to do all this in Haskell, a lazy, pure, functional programming language the merits of which have been elucidated by many others.