pg-harness-server 0.4.0 → 0.5.0
raw patch · 4 files changed
+52/−37 lines, 4 filesdep ~scottydep ~transformers
Dependency ranges changed: scotty, transformers
Files
- pg-harness-server.cabal +3/−6
- src/Main.hs +30/−26
- src/PgHarness/Configuration.hs +2/−0
- src/PgHarness/Mutex.hs +17/−5
pg-harness-server.cabal view
@@ -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
src/Main.hs view
@@ -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
src/PgHarness/Configuration.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- pg-harness, REST service for creating temporary PostgreSQL databases. Copyright (C) 2014, 2015 Bardur Arantsson
src/PgHarness/Mutex.hs view
@@ -15,15 +15,27 @@ You should have received a copy of the GNU Affero General Public License along with this program. If not, see <http://www.gnu.org/licenses/>. -}-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