Using a Reader monad to hold a DB handle for Happstack handlers

main.hs

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeOperators              #-}
module Main
where

import           Control.Monad.Reader
import           Data.Data                  (Data, Typeable)
import           Prelude                    hiding (head)

import qualified Database.PostgreSQL.Simple as Pg

import           Happstack.Server           (Response, ServerPartT, dir,
                                             nullConf, ok, simpleHTTP,
                                             toResponse)
import           Text.Boomerang.TH          (makeBoomerangs)
import           Web.Routes                 (PathInfo (..), RouteT, Site (..),
                                             mkSitePI, runRouteT, setDefault,
                                             showURL)
import           Web.Routes.Boomerang
import           Web.Routes.Happstack       (implSite)

data Sitemap = Home
             deriving (Eq, Ord, Read, Show, Data, Typeable)

$(makeBoomerangs ''Sitemap)

site = setDefault Home $ boomerangSite (runRouteT route) sitemap

sitemap :: Router () (Sitemap :- ())
sitemap = rHome

route :: Sitemap -> App Response
route url =
    case url of
      Home ->
          homePage

-- Handlers
homePage :: App Response
homePage = do
    [res:_] <- query_ "select 3 + 3"
    ok $ (toResponse . show) (res :: Int)

test :: App Response
test = do
    [res:_] <- query_ "select 2 + 2"
    ok $ (toResponse . show) (res :: Int)

-- a DB helper available in all handlers
query_ :: (Pg.FromRow r) => Pg.Query -> App [r]
query_ x = do
    conf <- ask
    let conn = dbHandle conf
    liftIO $ Pg.query_ conn x

type App a = ReaderT AppConfig (ServerPartT IO) a

data AppConfig = AppConfig { dbHandle :: Pg.Connection }

appconfig :: IO AppConfig
appconfig = do
    conn <- Pg.connect Pg.defaultConnectInfo
    return $ AppConfig conn

app :: App Response
app = msum [ dir "test" test
           -- , implSite "" "" site
           ]

main :: IO ()
main = do
    appconf <- appconfig
    simpleHTTP nullConf $ runReaderT app appconf