broken attempts to work on concurrency

dbapi.cabal

@@ -11,29 +11,26 @@ cabal-version:         >=1.10
 
 executable dbapi
   main-is:             Main.hs
-  ghc-options:         -Wall -W -Werror
+  ghc-options:         -Wall -W -threaded
   default-language:    Haskell2010
   build-depends:       base >=4.6 && <5
                      , HDBC, HDBC-postgresql
                      , warp, wai >= 3.0.1 && < 3.0.2
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
-                     , HTTP, convertible
+                     , HTTP, convertible, http-types
                      , case-insensitive
-                     , http-types, scientific, time
-                     , bytestring, aeson, network >= 2.6
-                     , text , containers
+                     , scientific, time
+                     , aeson, network >= 2.6
+                     , bytestring, text, split, string-conversions
+                     , containers, unordered-containers
                      , optparse-applicative >= 0.9.1 && < 0.10
-                     , unordered-containers
-                     , regex-base
-                     , string-conversions
-                     , http-media, regex-tdfa
+                     , regex-base, regex-tdfa
                      , Ranged-sets
                      , transformers
-                     , bcrypt
-                     , base64-string
-                     , split
+                     , bcrypt, base64-string
                      , network-uri >= 2.6
+                     , resource-pool, process
   Other-Modules:       Dbapi
                      , PgStructure
                      , PgQuery
@@ -69,3 +66,4 @@ Test-Suite spec
                      , base64-string
                      , split
                      , network-uri >= 2.6
+                     , resource-pool

src/Main.hs

@@ -3,9 +3,8 @@
 module Main where
 import Dbapi
 import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
-  redirectInsecure)
+  redirectInsecure, withDBConnection)
 import Network.Wai.Handler.Warp hiding (Connection)
-import Database.HDBC.PostgreSQL (connectPostgreSQL')
 import Data.String.Conversions (cs)
 
 import Control.Monad (unless)
@@ -14,6 +13,15 @@ import Options.Applicative hiding (columns)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Middleware.Static (staticPolicy, only)
+import Database.HDBC (disconnect)
+import Database.HDBC.PostgreSQL(connectPostgreSQL')
+import Data.Pool(createPool)
+import System.Process
+
+import Control.Concurrent(threadDelay)
+
+import Network.HTTP.Types.Status
+import Network.Wai
 
 argParser :: Parser AppConfig
 argParser = AppConfig
@@ -29,8 +37,9 @@ argParser = AppConfig
 main :: IO ()
 main = do
   conf <- execParser (info (helper <*> argParser) describe)
-  let port = configPort conf
   let dburi = configDbUri conf
+  pool <- createPool (putStrLn "creating connection" >> connectPostgreSQL' (configDbUri conf)) (\c-> putStrLn "destroying connection" >> disconnect c) 1 600 10
+  let port = configPort conf
 
   unless (configSecure conf) $
     putStrLn "WARNING, running in insecure mode, auth will be in plaintext"

src/Middleware.hs

@@ -6,6 +6,7 @@ module Middleware where
 import Data.Aeson ((.=), toJSON, ToJSON, object, encode)
 import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
+import Data.Pool(withResource, Pool)
 
 import Database.HDBC (runRaw)
 import Database.HDBC.PostgreSQL (Connection)
@@ -15,6 +16,7 @@ import Data.String.Conversions(cs)
 import qualified Data.ByteString.Char8 as BS
 import Control.Exception (finally, throw, catchJust, catch, SomeException,
     bracket_)
+import Control.Concurrent(threadDelay)
 
 import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
   hLocation)
@@ -26,18 +28,23 @@ import Network.URI (URI(..), parseURI)
 import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
-inTransaction :: (Connection -> Application) -> Connection -> Application
+
+withDBConnection :: Pool Connection -> (Connection -> Application) -> Application
+withDBConnection pool app req respond =
+  withResource pool (\c -> app c req respond)
+
+inTransaction :: (Connection -> Application) -> (Connection -> Application)
 inTransaction app conn req respond =
   finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
 
-withSavepoint :: (Connection -> Application) -> Connection -> Application
+withSavepoint :: (Connection -> Application) -> (Connection -> Application)
 withSavepoint app conn req respond = do
   runRaw conn "savepoint req_sp"
   catch (app conn req respond) (\e -> let _ = (e::SomeException) in
     runRaw conn "rollback to savepoint req_sp" >> throw e)
 
 authenticated :: BS.ByteString -> (Connection -> Application) ->
-                 Connection -> Application
+                 (Connection -> Application)
 authenticated anon app conn req respond = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
@@ -46,9 +53,9 @@ authenticated anon app conn req respond = do
     LoginFailed ->
       respond $ responseLBS status401 [] "Invalid username or password"
     LoginSuccess role ->
-      bracket_ (setRole conn role) (resetRole conn) $ app conn req respond
+      bracket_ (setRole conn role >> threadDelay 10000000) (resetRole conn) $ app conn req respond
     NoCredentials ->
-      bracket_ (setRole conn anon) (resetRole conn) $ app conn req respond
+      bracket_ (setRole conn anon >> threadDelay 10000000) (resetRole conn) $ app conn req respond
 
  where
    httpRequesterRole :: RequestHeaders -> IO LoginAttempt