From HAppS to Happstack
October 13, 2009, in haskell

I have been dreading porting my Blog application from HAppS to Happstack for a long time now. It is however apparent that HAppS is dying and Happstack (a fork of HAppS designed to take things further) was the only way to roll.

… a refreshingly innovative web application server written in Haskell. Leveraging the MACID state system, Happstack offers robust and scalable data access without the headache of managing a traditional RDBMS such as MySQL.

The RELEASE_NOTES file had some guidelines for porting existing applications to Happstack. In my case it turned out to be really easy:

  1. Install Happstack
    • sudo cabal install happstack
  2. Change HAppS to Happstack in all .hs-files
    • find . -type f -name '*.hs' -exec sed -i.bak 's/HAppS/Happstack/g' {} \;
  3. Change unServerPartT to runServerPartT
    • find . -type f -name '*.hs' -exec sed -i.bak 's/unServerPartT/runServerPartT/g' {} \;
  4. Change all instances of [ServerPartT m a] to ServerPartT with msum
  5. Compile my code again
Well this sounds almost too easy. And it is. I alway got the error Unsupported socket - both on my Mac (development machine) and on my Linux box (the production machine). On Google Groups I found someone saying that it’s a problem with how Haskell’s Templating System handles  IPv6. The solution was to change Happstack.Server.HTTP.Socket.acceptLite to:
-- | alternative implementation of accept to work around EAI_AGAIN errors 
acceptLite :: S.Socket -> IO (Handle, S.HostName, S.PortNumber) 
acceptLite sock = do 
  (sock', addr) <- S.accept sock 
  h <- S.socketToHandle sock' ReadWriteMode 
  (N.PortNumber p) <- N.socketPort sock' 

  let peer = case addr of 
               (S.SockAddrInet _ ha)      -showHostAddress ha 
               (S.SockAddrInet6 _ _ ha _) -showHostAddress6 ha 
               _                          -error "Unsupported socket"
  return (h, peer, p) 
Actually I used the time to cabalize my code. Outlining the dependencies means that Cabal takes care of downloading all the necessary packages. To date my cabal file looks like this:
name:                gisliblog

version:             0.0
synopsis:            Personal website
description:         
category:            Web
license:             BSD3
license-file:        LICENSE
author:              Gísli Kristjánsson
maintainer:          gislik hamstur.is
build-depends:       base,feed,nano-md5,hscolour,json,curl,HStringTemplate,happstack
build-type:          Simple
hs-source-dirs:      src
executable:          gisli.hamstur.is
main-is:             src/Main.hs
ghc-options:         -isrc        
Also having everything in a git repository meant that I could port the code in a special branch and merge the branches when the code compiled successfully. The next steps are to port my brothers photo site to Happstack and then look into taking the advantage of the new API which has been simplified in many ways. For example
This:
    uriRest :: Monad m => (String -> ServerPartT m a) -> ServerPartT m a
    uriRest handle = withRequest $ \rq -> unServerPartT (handle (rqURL rq)) rq
Becomes this:
    uriRest :: (ServerMonad m, Monad m) => (String -> m a) -> m a
    uriRest handle = askRq >>= handle . rqURL
That’s it for now.
P.S. On a different note I just placed an order for the Arduino Duemilanove microcontroller board. It should be arriving this week. I’m all excited so the next blog could be about that.
Model migration
May 5, 2009, in haskell

My brother has been asking me for a new feature for some time now. It’s a simple video feature where instead of showing a picture when clicked on a video begins to play. I had been holding this project off for a while because I knew that model migration would probably be a hazzle.

I can recommend the LongTail FLV video player. It can handle FLV, MP4, MP3, AAC, JPG, PNG and GIF files. It also supports RTMP, HTTP, live streaming, various playlists formats, a wide range of settings and an extensive javascript API.

What exactly is model migration? Well, when you model your data you come up with something like this:

data Photo = Photo { photoName          :: String
                   , photoText          :: String
                   , photoDate          :: AppDate
                   , photoCategory      :: Maybe CategoryID
                   , photoCategoryCover :: Bool -- Calculated
                   , photoCover         :: Bool -- Calculated
                   , photoSeriesCover   :: Bool -- Calculated
                   , photoOrder         :: Int
                   , photoCategoryOrder :: Int
                   , photoSeriesOrder   :: Int -- Calculated
                   , photoCreated       :: AppDate
                   , photoModified      :: Maybe AppDate
                   } deriving (Show, Read, Eq, Data, Typeable)


When you start to use your model HAppS records your data into this structure in a binary form. Now let’s say that you need to add a field for the name of the video to be played instead of showing the picture you get something like this:

data Photo = Photo { photoName          :: String
                   , photoText          :: String
                   , photoDate          :: AppDate
                   , photoCategory      :: Maybe CategoryID
                   , photoCategoryCover :: Bool -- Calculated
                   , photoCover         :: Bool -- Calculated
                   , photoSeriesCover   :: Bool -- Calculated
                   , photoOrder         :: Int
                   , photoCategoryOrder :: Int
                   , photoSeriesOrder   :: Int -- Calculated
                   , photoVideo         :: Maybe String -- THE ONLY DIFFERENCE!
                   , photoCreated       :: AppDate
                   , photoModified      :: Maybe AppDate
                   } deriving (Show, Read, Eq, Data, Typeable)

Notice that I’ve only added the photoVideo field. The problem is however that when HAppS tries to read in the old structure it does not know how to map it to the new structure (model). That’s when you need to worry about model migration.

Fortunatelly it’s super easy in HAppS. In my case the Photo model was in a module called Model.Photo. To migrate you just have to execute the following steps

  1. Copy the file Photo.hs to Photo1.hs and change the module name to Model.Photo1
  2. Add this to Model.Photo:

    import qualified Model.Photo1 as P1
    instance Migrate P1.Photo Photo where
             migrate p1 = Photo { photoName          = (P1.photoName p1)
                                , photoText          = (P1.photoText p1)
                                , photoDate          = (P1.photoDate p1)
                                , photoCategory      = (P1.photoCategory p1)
                                , photoCategoryCover = (P1.photoCategoryCover p1)
                                , photoCover         = (P1.photoCover p1)
                                , photoSeriesCover   = (P1.photoSeriesCover p1)
                                , photoOrder         = (P1.photoOrder p1)
                                , photoCategoryOrder = (P1.photoCategoryOrder p1)
                                , photoSeriesOrder   = (P1.photoSeriesOrder p1)
                                , photoVideo         = Nothing
                                , photoCreated       = (P1.photoCreated p1)
                                , photoModified      = (P1.photoModified p1)
                                } 
    
    
    instance Version Photo where
             mode = extension 2 (Proxy :: Proxy P1.Photo)
  3. You’re all set. Compile and restart HAppS.

When HAppS starts up again it knows exactly how to transform the old structure into the new one.

Happy migration!

baldurkristjans.is - screen cast, code and more
January 20, 2009, in haskell

As mentioned in my tweet my brother’s online photo album went live last Thursday. Since then I’ve been trying to think not so much about it because this project had started to consume my brain leaving little space for anything else (including sleeping). I’m happy with the responses he’s been getting over the last couple of days - and the most important thing; he’s happy.

Readers of this blog know by now that this website was entirely written in Haskell/HAppS and I loved writing it. In this post I’ll attempt to discuss some of the more interesting parts of the site and show you a screen cast of the administrative panel.

Because I’m using HAppS there is no need for a database. HAppS-State simply persist my native data structure. The photos are represented as maps of photos.

type Photos = Map PhotoID Photo

type PhotoID = String

data Photo = Photo { photoName          :: String
                   , photoText          :: String
                   , photoDate          :: AppDate
                   , photoCategory      :: Maybe CategoryID
                   , photoCategoryCover :: Bool -- Calculated
                   , photoCover         :: Bool -- Calculated
                   , photoSeriesCover   :: Bool -- Calculated
                   , photoOrder         :: Int
                   , photoCategoryOrder :: Int
                   , photoSeriesOrder   :: Int -- Calculated
                   , photoCreated       :: AppDate
                   , photoModified      :: Maybe AppDate
                   } deriving (Show, Read, Eq, Data, Typeable)

Some of the fields are have a Calculated comment. These fields do not depend on being persisted (this is of course not enforced by HAppS in any way) but they are rather calculated when needed and handed over to the templates where they control how the photo is rendered.

To warm up let’s take a look at one of the simplest controller action (Controller.Photo.list):

list :: WebT IO LayoutResponse
list = liftIO $ do
     env           <- appEnv :: IO (AppEnv String String)
     photos        <- query ListPhotos
     photo         <- liftM (pidToPhoto photos) $ query GetCoverPhoto
     photoTemplate <- liftM (attr "photo" photo) $ parseTemplate env "photos_show"
     returnLayout Nothing (attrSession "body" photoTemplate)

Normally a controller action would have a type of WebT IO Response but I’ve created the LayoutResponse type to be able to wrap the master layout around the template (in this case photos_show). The variable photos has the the Photos (a map of Photo) and GetCoverPhoto returns the Photo ID (pid) of the cover photo which is then looked up with the function pidToPhoto in the photos map. The cover photo then gets assigned to the photo template variable. When the photo template has been parsed it self gets assigned to the body template variable which is returned from the controller action and handed to the wrapLayout function which purpose is to transform LayoutResponse to Response.  This is a very common practice in my code.

One of the more interesting controller actions is the one serving the photos. When a photo is requested the request gets handed to the Photo controller. If the photo does exist it is served directly but if it does not exist it is resized according to the directory name it’s contained in, i.e. h540 (meaning fix the height at 540 pixels), provided that the requested size is allowed (appears in sizes.txt)

legalSizes :: IO [String]
legalSizes = liftM lines (readFile "sizes.txt")

serveFile' :: FilePath -> [FilePath] -> FilePath -> ServerPartT IO Response
serveFile' orgsDir _ dir = let resize size f f' im = do
                                      (w, h) <- imageSize im
                                      let (fix, l) = splitAt 1 size
                                      let l' = read l :: Int
                                      let (w', h') = if fix == "w"
                                                        then (l', (l'*h)`div`w)
                                                        else ((l'*w)`div`h, l')
                                      let geometry = (P.show w')++"x"++(P.show h')
                                      status <- liftIO $ rawSystem "convert" 
                                                                      ["-geometry"
                                                                      ,geometry
                                                                      ,"-quality"
                                                                      ,(P.show quality)
                                                                      ,f
                                                                      ,f']
                                      case status of
                                           ExitFailure code -> fail.P.show $ code
                                           ExitSuccess      -> return ()                                           
                           in 
                           let resizePhoto size f f' = do
                                case map toLower (takeExtension f) of
                                     ".jpg" -> loadJpegFile f >>= resize size f f' 
                                     ".png" -> loadPngFile f >>= resize size f f'
                                     ".gif" -> loadGifFile f >>= resize size f f' 
                           in
       withRequest $ \req -> do
           currentDir <- liftIO getCurrentDirectory
           let (year:size:pid:_) = rqPaths req
           let file = joinPath [currentDir, orgsDir, year, pid]
           let file' = joinPath [currentDir, dir, drop 1.rqUri $ req]
           doesExist <- liftIO.doesFileExist $ file'
           sizes <- liftIO $ legalSizes
           let fixedRqPaths = map (drop 1).groupBy (\_ y -> y/='/') $ rqUri req
           let serveFile'' = do
               modifyResponse serveHeaders
               unServerPartT (fileServe [] dir) $ req { rqPaths=fixedRqPaths }
           if doesExist
              then serveFile''
              else if size `elem` sizes
                      then do
                           liftIO $ createDirectoryIfMissing True (takeDirectory file')
                           liftIO $ resizePhoto size file file'               
                           serveFile''
                      else noHandle

As you can see I spawn convert from ImageMagick in a different process to resize my photos. There are bindings to ImageMagick  available for Haskell but was unable to install them. Initially I wanted to go for a much simpler option and use the GD library which is a much simpler library and its bindingsseemed much simpler. The problem was however that the GD library decreased the quality of the photo.

GHCi, version 6.10.1: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer ... linking ... done.
Loading package base ... linking ... done.
Prelude> :m +Graphics.GD 
Prelude Graphics.GD> loadJpegFile "405ba7c1fc3aefcbe3cf4471ef1b781f.jpg"
        >>= resizeImage 600 400 
        >>= saveJpegFile 100 "gd-405ba7c1fc3aefcbe3cf4471ef1b781f.jpg"
Converted with GD

$ mogrify -geometry 600x400
405ba7c1fc3aefcbe3cf4471ef1b781f.jpg im-405ba7c1fc3aefcbe3cf4471ef1b781f.jpg
Converted with ImageMagick

The second is much richer in colors and identical to the source while the first one created with GD library is brighter and generally lower in quality. This was a big surprise and a let-down but I’ll just be using ImageMagick in the future. I wish someone would update the bindings though. For the purpose of creating small images containing only text the GD library seemed sufficient:

newImage ((width rect)-1, height'+1) 
         >>= fillImage (rgb 0 0 0)
         >>= drawString "fonts/current.otf" size 0 (x,y) title 
                        (rgb (v r1 r2) (v g1 g2) (v b1 b2)) 
         >>= savePngFile filename

Lastly I’d like to point out how one handles files submitted through HTML forms. The trick is to use inputFilename and inputValue like this:

handleData = do
           photo  <- lookInput "photo"
           cid    <- look "cid" `mplus` return ""
           series <- look "series" `mplus` return ""
           let Just name = inputFilename photo `mplus` Just ""
           let contents = inputValue photo
           return (name, contents, cid, series)

I hope this post is of use for someone and if you’ve some questions please leave a comment.

I've been busy over christmas...
January 5, 2009, in haskell

… but there’s no activity on your blog you may say. Well I decided to do my brother a favor. He is a professional photographer working for a photo gallery called Magg but with his own clientele. Now facing changes in the photographic scene as the recession begins to creep in he wanted to strengthen his own professional presence. The vehicle for such a requirement was an online photo gallery (due to open this week) with some of his more artistic images.

Initially I was going to create the gallery with Python and SQLite but I found myself always going back to hacking on my bloging platform. That was until I found the reason why; I had so much fun programming in Haskell. Armed with this new knowledge I decided to jump into the deeper end of the pool and rewrite (what little I had already done in Python) in Haskell. I was able to re-use much of my work from the bloging platform experience but this time around further investigation was needed to fulfill some of the requirements, such as uploading (multiple) photos, rescaling them and soforth. I will happily share my solution with you in coming blog posts although naturally I cannot give you access to the administrative side of the gallery. Instead I’ll post some photos with some explanation or even create a screen cast of the admin part.

With very few photos in the system it does perform remarkably well and I am very interested in what the site will feel like with a few hundreds or even thousands of photos in there.

The next steps for my blog will be to Tag-enable it. I am thinking about extending the Tags into Series where each blog in the Series will have links to the other posts in the series in a chronological order. This way I’ll be able to group a number of blog posts and present them as a whole.

P.S. As you have duly noticed I’ve begun to blog in English (at least where the topic is Haskell). I hope this goes well with everyone :)

About