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.

About