From 49f0bf7c3fbeeba2a867f9b4f72b556c072caac1 Mon Sep 17 00:00:00 2001 From: "Adam C. Baker" Date: Wed, 15 Oct 2014 18:10:02 -0700 Subject: [PATCH] broken attempts to work on concurrency --- dbapi.cabal | 22 ++++++++++------------ src/Main.hs | 15 ++++++++++++--- src/Middleware.hs | 17 ++++++++++++----- 3 files changed, 34 insertions(+), 20 deletions(-) diff --git a/dbapi.cabal b/dbapi.cabal index 40dc7ce30..088dbfd65 100644 --- a/dbapi.cabal +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 16dc35d24..fb1be07be 100644 --- a/src/Main.hs +++ b/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" diff --git a/src/Middleware.hs b/src/Middleware.hs index 9045c4703..80f6c4054 100644 --- a/src/Middleware.hs +++ b/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