From da79f6cea13926a57b1a7faeab9ef0c82dc0774d Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Sun, 16 Nov 2014 12:33:36 -0800
Subject: [PATCH] Share connection pool with all http clients

---
 dbapi.cabal | 2 ++
 src/App.hs  | 6 +-----
 src/Main.hs | 8 +++++++-
 3 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/dbapi.cabal b/dbapi.cabal
index a6d882652..a100bf093 100644
--- a/dbapi.cabal
+++ b/dbapi.cabal
@@ -37,6 +37,7 @@ executable dbapi
                      , resource-pool, process
                      , blaze-builder
                      , vector
+                     , mtl
   Other-Modules:       App
                      , Auth
                      , Config
@@ -81,3 +82,4 @@ Test-Suite spec
                      , resource-pool
                      , blaze-builder
                      , vector
+                     , mtl
diff --git a/src/App.hs b/src/App.hs
index 14376087b..317d11835 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
-module App (runApp, app) where
+module App (app) where
 
 import Control.Monad (join)
 import Data.Monoid ( (<>) )
@@ -33,10 +33,6 @@ import RangeQuery
 import PgStructure
 import Auth
 
-runApp :: H.Postgres -> H.SessionSettings -> Application
-runApp pg sess req respond =
-  respond =<< H.session pg sess (app req)
-
 app :: Request -> H.Session H.Postgres IO Response
 app req =
   case (path, verb) of
diff --git a/src/Main.hs b/src/Main.hs
index dbe80247a..bc6ec3c8d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,6 +7,8 @@ import App
 import Middleware
 
 import Control.Monad (unless)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Reader (runReaderT, ask)
 import Data.String.Conversions (cs)
 import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Handler.Warp hiding (Connection)
@@ -44,7 +46,11 @@ main = do
         . gzip def . cors corsPolicy . clientErrors
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) in
 
-    runSettings appSettings $ middle (runApp pgSettings sessSettings)
+    H.session pgSettings sessSettings $ do
+      session' <- flip runReaderT <$> ask
+      let runApp req respond = respond =<< session' (app req) in
+
+        liftIO $ runSettings appSettings $ middle runApp
  --     . authenticated (cs $ configAnonRole conf) $ app
 
   where