An example Snap Framework web-app which displays data from a PostgreSQL database accessed with Takusen.

.gitignore

.DS_Store
._*
/dist/
*.log

gist646901.cabal

Name:                gist646901
Version:             0.1
Synopsis:            Using Takusen with Snap 
Description:         An example of using Takusen in a Snap application.
License:             BSD3
Author:              Thomas Sutton
Maintainer:          [email protected]
Stability:           Experimental
Category:            Web
Build-type:          Simple
Cabal-version:       >=1.2

Executable gist646901
  hs-source-dirs: src
  main-is: Main.lhs

  Build-depends:
    base >= 4,
    haskell98,
    monads-fd >= 0.1 && <0.2,
    bytestring >= 0.9.1 && <0.10,
    snap-core >= 0.2 && <0.3,
    snap-server >= 0.2 && <0.3,
    xhtml-combinators,
    unix,
    text,
    containers,
    Takusen,
    MonadCatchIO-transformers,
    filepath >= 1.1 && <1.2

  if impl(ghc >= 6.12.0)
    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
                 -fno-warn-unused-do-bind
  else
    ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

Glue.hs

{-# LANGUAGE OverloadedStrings #-}
module Glue
    ( templateHandler
    , defaultReloadHandler
    , templateServe
    , render
    ) where

import           Control.Applicative
import           Control.Monad
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import           Prelude hiding (catch)
import           Snap.Types hiding (dir)
import           Snap.Util.FileServe
import           Text.Templating.Heist
import           Text.Templating.Heist.TemplateDirectory


templateHandler :: TemplateDirectory Snap
                -> (TemplateDirectory Snap -> Snap ())
                -> (TemplateState Snap -> Snap ())
                -> Snap ()
templateHandler td reload f = reload td <|> (f =<< getDirectoryTS td)


defaultReloadHandler :: TemplateDirectory Snap -> Snap ()
defaultReloadHandler td = path "admin/reload" $ do
    e <- reloadTemplateDirectory td
    modifyResponse $ setContentType "text/plain; charset=utf-8"
    writeBS . B.pack $ either id (const "Templates loaded successfully.") e


render :: TemplateState Snap -> ByteString -> Snap ()
render ts template = do
    bytes <- renderTemplate ts template
    flip (maybe pass) bytes $ \x -> do
        modifyResponse $ setContentType "text/html; charset=utf-8"
        writeBS x


templateServe :: TemplateState Snap -> Snap ()
templateServe ts = ifTop (render ts "index") <|> do
    path' <- getSafePath
    when (head path' == '_') pass
    render ts $ B.pack path'

Main.lhs

This is a drop-in replacement for the `Main.hs` file generated by the `snap
init` command.

We'll need two language extensions: `OverloadedStrings` as usual for Snap and
`DeriveDataTypeable` for the Takusen iteree.

> {-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
> module Main where

We'll use the Snap boilerplate code as is, so import it along with the Snap
API and ByteString library:

> import           Server
> import           Snap.Types
> import           Data.ByteString.Char8 (pack)

On the database side we'll need to import Takusen itself along with a bit of
machinery to use it and to integrate it with Snap:

> import           Database.Enumerator
> import           Database.PostgreSQL.Enumerator
> import           Data.Typeable
> import           Control.Monad.Trans

With the libraries loaded, let's define a data type to hold the information
from the database. To keep it simple we'll have just two fields: an ID number
and a string:

> data Item = Item {
>   id :: Int,
>   title :: String
>   } deriving (Show, Eq, Typeable)

Now that we can represent our values let's load them from the database. We're
only using the database in this one place, so we'll just use `withSession` to
connect, run our query and disconnect. It should be fairly self evident what's
going on here:

> -- | Snap action to fetch Item values from the database.
> getItems :: Snap [Item]
> getItems = liftIO $ withSession (connect [CAdbname "example"]) ( do
>     doQuery (sql "SELECT id, title FROM items;") itemIteree []
>   )
>   where
>     -- | Iteree to fetch a query set as Item values.
>     itemIteree :: (Monad m) => Int -> String -> IterAct m [Item]
>     itemIteree id' title' acc = result' $ (Item id' title'):acc

Now that we can load values from the database, let's use them to build a page:

> pgHandler :: Snap ()
> pgHandler = do
>   items <- getItems
>   modifyResponse $ setHeader "X-Items" $ (pack . show) $ length items
>   writeBS "The items:\n\n"
>   writeBS $ pack $ unlines $ map show items

And finally, we'll use the above to respond to all requests:

> main :: IO ()
> main = quickServer pgHandler

Server.hs

{-# LANGUAGE OverloadedStrings #-}
module Server
    ( ServerConfig(..)
    , emptyServerConfig
    , commandLineConfig
    , server
    , quickServer
    ) where
import qualified Data.ByteString.Char8 as B
import           Data.ByteString.Char8 (ByteString)
import           Data.Char
import           Control.Concurrent
import           Control.Exception (SomeException)
import           Control.Monad.CatchIO
import qualified Data.Text as T
import           Prelude hiding (catch)
import           Snap.Http.Server
import           Snap.Types
import           Snap.Util.GZip
import           System hiding (getEnv)
import           System.Posix.Env
import qualified Text.XHtmlCombinators.Escape as XH


data ServerConfig = ServerConfig
    { locale          :: String
    , interface       :: ByteString
    , port            :: Int
    , hostname        :: ByteString
    , accessLog       :: Maybe FilePath
    , errorLog        :: Maybe FilePath
    , compression     :: Bool
    , error500Handler :: SomeException -> Snap ()
    }


emptyServerConfig :: ServerConfig
emptyServerConfig = ServerConfig
    { locale          = "en_US"
    , interface       = "0.0.0.0"
    , port            = 8000
    , hostname        = "myserver"
    , accessLog       = Just "access.log"
    , errorLog        = Just "error.log"
    , compression     = True
    , error500Handler = \e -> do
        let t = T.pack $ show e
            r = setContentType "text/html; charset=utf-8" $
                setResponseStatus 500 "Internal Server Error" emptyResponse
        putResponse r
        writeBS "<html><head><title>Internal Server Error</title></head>"
        writeBS "<body><h1>Internal Server Error</h1>"
        writeBS "<p>A web handler threw an exception. Details:</p>"
        writeBS "<pre>\n"
        writeText $ XH.escape t
        writeBS "\n</pre></body></html>"
    }


commandLineConfig :: IO ServerConfig
commandLineConfig = do
    args <- getArgs
    let conf = case args of
         []        -> emptyServerConfig
         (port':_) -> emptyServerConfig { port = read port' }
    locale' <- getEnv "LANG"
    return $ case locale' of
        Nothing -> conf
        Just l  -> conf {locale = takeWhile (\c -> isAlpha c || c == '_') l}

server :: ServerConfig -> Snap () -> IO ()
server config handler = do
    putStrLn $ "Listening on " ++ (B.unpack $ interface config)
             ++ ":" ++ show (port config)
    setUTF8Locale (locale config)
    try $ httpServe
             (interface config)
             (port      config)
             (hostname  config)
             (accessLog config)
             (errorLog  config)
             (catch500 $ compress $ handler)
             :: IO (Either SomeException ())
    threadDelay 1000000
    putStrLn "Shutting down"
  where
    catch500 = (`catch` (error500Handler config))
    compress = if compression config then withCompression else id


quickServer :: Snap () -> IO ()
quickServer = (commandLineConfig >>=) . flip server


setUTF8Locale :: String -> IO ()
setUTF8Locale locale' = do
    mapM_ (\k -> setEnv k (locale' ++ ".UTF-8") True)
          [ "LANG"
          , "LC_CTYPE"
          , "LC_NUMERIC"
          , "LC_TIME"
          , "LC_COLLATE"
          , "LC_MONETARY"
          , "LC_MESSAGES"
          , "LC_PAPER"
          , "LC_NAME"
          , "LC_ADDRESS"
          , "LC_TELEPHONE"
          , "LC_MEASUREMENT"
          , "LC_IDENTIFICATION"
          , "LC_ALL" ]