diff --git a/pg-harness-server.cabal b/pg-harness-server.cabal --- a/pg-harness-server.cabal +++ b/pg-harness-server.cabal @@ -1,5 +1,5 @@ Name: pg-harness-server -Version: 0.4.0 +Version: 0.5.0 Synopsis: REST service for creating temporary PostgreSQL databases Description: REST service for conveniently creating temporary PostgreSQL databases @@ -31,12 +31,9 @@ , ini >= 0.2 && < 0.3 , postgresql-simple >= 0.4.2 && < 0.5 , random >= 1.0 && < 1.2 - , scotty >= 0.7.0 && < 0.10 + , scotty >= 0.11.0 && < 0.12 , text >= 1.1.0 && < 2 - , transformers >= 0.4.1 && < 0.5 - Default-extensions: LambdaCase - OverloadedStrings - ScopedTypeVariables + , transformers >= 0.5 && < 0.6 Hs-source-dirs: src Default-language: Haskell2010 Other-modules: Paths_pg_harness_server diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {- pg-harness, REST service for creating temporary PostgreSQL databases. Copyright (C) 2014, 2015 Bardur Arantsson @@ -21,14 +25,14 @@ import Control.Concurrent.Async (async, withAsync, waitCatch) import Control.Exception (bracket) import Control.Monad (void) -import Control.Monad.Trans.Class (lift) +import Control.Monad.IO.Class (liftIO) import Data.String (fromString) import qualified Data.Text.Lazy as TL import Database.PostgreSQL.Simple (Connection, ConnectInfo(..), Only(..)) import qualified Database.PostgreSQL.Simple as P import System.IO (stderr, hPutStrLn) import System.Random (randomRIO) -import Web.Scotty (scotty, post, text, ScottyM, raise) +import Web.Scotty (ScottyM, scotty, post, text, raise) import Paths_pg_harness_server (getDataFileName) import PgHarness.Mutex import PgHarness.Configuration @@ -39,14 +43,14 @@ -- completes, regardless of whether it completes successfully or -- not (e.g. if there's an exception). withConnection :: Configuration -> (Connection -> IO a) -> IO a -withConnection configuration action = bracket (P.connect connectInfo) P.close action +withConnection Configuration{..} action = bracket (P.connect connectInfo) P.close action where connectInfo = ConnectInfo - { connectHost = cfgHost configuration - , connectPort = cfgPort configuration - , connectUser = cfgUser configuration - , connectPassword = cfgPassword configuration - , connectDatabase = unquotedIdentifier (cfgDatabase configuration) + { connectHost = cfgHost + , connectPort = cfgPort + , connectUser = cfgUser + , connectPassword = cfgPassword + , connectDatabase = unquotedIdentifier cfgDatabase } -- Create a random valid PostgreSQL identifier. @@ -69,7 +73,7 @@ -- Create temporary database and return its name. createTemporaryDatabase :: Configuration -> DatabaseId -> IO () -createTemporaryDatabase configuration databaseId = do +createTemporaryDatabase configuration@Configuration{..} databaseId = do -- Connect to the administrative database. withConnection configuration $ \connection -> do -- Create the temporary database. @@ -77,18 +81,18 @@ putStrLn $ "Created temporary database: " ++ sqlDatabaseId -- Spawn a thread to kill the database after a certain delay. void $ async $ do - threadDelay $ (cfgDurationSeconds configuration) * 1000000 + threadDelay $ cfgDurationSeconds * 1000000 dropDatabase configuration databaseId where createSql = fromString $ "CREATE DATABASE " ++ sqlDatabaseId ++ - " WITH TEMPLATE " ++ (sqlIdentifier $ cfgTemplateDatabase configuration) ++ - " OWNER \"" ++ (cfgTestUser configuration) ++ "\"" + " WITH TEMPLATE " ++ (sqlIdentifier cfgTemplateDatabase) ++ + " OWNER \"" ++ cfgTestUser ++ "\"" sqlDatabaseId = sqlIdentifier databaseId dropDatabase :: Configuration -> DatabaseId -> IO () -dropDatabase configuration databaseId = +dropDatabase configuration@Configuration{..} databaseId = -- Since this is running in a separate thread we need explicit -- exception handling to avoid silent exceptions. withAsync doDropDatabase waitCatch >>= \case @@ -124,27 +128,23 @@ sqlDatabaseId = sqlIdentifier databaseId -- REST interface -routes :: Configuration -> ScottyM () -routes configuration = do - -- Mutex to prevent multiple "create" requests from being - -- processed simultaneously; PostgreSQL cannot handle - -- "cloning" a template concurrently. - mutex <- lift $ mkMutex +routes :: Configuration -> Mutex -> ScottyM () +routes configuration@Configuration{..} mutex = do -- Add all the routes. post "/" $ do -- Generate a name for temporary database. - lift mkTemporaryDatabaseId >>= \case + liftIO mkTemporaryDatabaseId >>= \case Left err -> raise $ TL.pack err Right databaseId -> do -- Create the temporary database. - lift $ mutex $ createTemporaryDatabase configuration databaseId + liftIO $ withMutex mutex $ createTemporaryDatabase configuration databaseId -- Return a string with the username/password and database name. text $ TL.unlines - [ TL.pack $ cfgTestUser configuration - , TL.pack $ cfgTestPassword configuration - , TL.pack $ cfgHost configuration - , TL.pack $ show $ cfgPort configuration + [ TL.pack $ cfgTestUser + , TL.pack $ cfgTestPassword + , TL.pack $ cfgHost + , TL.pack $ show $ cfgPort , TL.pack $ unquotedIdentifier databaseId ] @@ -154,6 +154,10 @@ getDataFileName "pg-harness.ini" >>= loadConfiguration >>= \case Left msg -> hPutStrLn stderr msg Right configuration -> do + -- Mutex to prevent multiple "create" requests from being + -- processed simultaneously; PostgreSQL cannot handle + -- "cloning" a template concurrently. + mutex <- mkMutex -- Start the web serving thread putStrLn $ "Starting with configuration: " ++ show configuration - scotty (cfgListenPort configuration) $ routes configuration + scotty (cfgListenPort configuration) $ routes configuration mutex diff --git a/src/PgHarness/Configuration.hs b/src/PgHarness/Configuration.hs --- a/src/PgHarness/Configuration.hs +++ b/src/PgHarness/Configuration.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {- pg-harness, REST service for creating temporary PostgreSQL databases. Copyright (C) 2014, 2015 Bardur Arantsson diff --git a/src/PgHarness/Mutex.hs b/src/PgHarness/Mutex.hs --- a/src/PgHarness/Mutex.hs +++ b/src/PgHarness/Mutex.hs @@ -15,15 +15,27 @@ You should have received a copy of the GNU Affero General Public License along with this program. If not, see . -} -module PgHarness.Mutex ( mkMutex ) where +module PgHarness.Mutex + ( Mutex + , mkMutex + , withMutex + ) where import Control.Exception (bracket_) -import Control.Concurrent.QSem (newQSem, waitQSem, signalQSem) +import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem) +-- Mutex type +newtype Mutex = Mutex QSem + -- Creates a mutex based on semaphores. The mutex takes the form a -- function which can be called with an IO action to perform that -- action in a critical section. -mkMutex :: IO (IO a -> IO a) +mkMutex :: IO Mutex mkMutex = do - mutex <- newQSem 1 - return $ \a -> bracket_ (waitQSem mutex) (signalQSem mutex) a + semaphore <- newQSem 1 + return $ Mutex semaphore + +-- Run a computation in a critical section. +withMutex :: Mutex -> IO a -> IO a +withMutex (Mutex semaphore) action = + bracket_ (waitQSem semaphore) (signalQSem semaphore) action