broken attempts to work on concurrency

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