tmp-postgres 1.0.1.0 → 1.2.0.0
raw patch · 5 files changed
+126/−58 lines, 5 filesdep +containers
Dependencies added: containers
Files
- README.md +1/−1
- src/Database/Postgres/Temp/Internal.hs +7/−16
- src/Database/Postgres/Temp/Internal/Partial.hs +89/−20
- test/Spec.hs +25/−20
- tmp-postgres.cabal +4/−1
README.md view
@@ -1,7 +1,7 @@ [](http://travis-ci.org/jfischoff/tmp-postgres) # tmp-postgres -`tmp-postgres` provides functions creating a temporary @postgres@ instance.+`tmp-postgres` provides functions creating a temporary `postgres` instance. By default it will create a temporary directory for the data, a random port for listening and a temporary directory for a UNIX domain socket.
src/Database/Postgres/Temp/Internal.hs view
@@ -14,6 +14,7 @@ import Control.Monad.Trans.Cont import Control.Monad.Trans.Class import qualified Database.PostgreSQL.Simple as PG+import qualified Data.Map.Strict as Map -- | Handle for holding temporary resources, the @postgres@ process handle -- and postgres connection information. The 'DB' also includes the@@ -64,15 +65,15 @@ { configPlan = mempty { partialPlanLogger = pure mempty , partialPlanConfig = Mappend defaultPostgresConfig- , partialPlanCreateDb = Mappend $ pure mempty- { partialProcessConfigCmdLine = Mappend ["test"]- }+ , partialPlanCreateDb = Mappend Nothing , partialPlanInitDb = Mappend $ pure mempty- { partialProcessConfigCmdLine = Mappend ["--no-sync"]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased = Map.singleton "--no-sync" Nothing+ } } , partialPlanPostgres = mempty { partialPostgresPlanClientConfig = mempty- { Client.dbname = pure "test"+ { Client.dbname = pure "postgres" } } }@@ -181,16 +182,6 @@ -- want to create a database owned by a specific user you will also log in as -- among other use cases. It is possible some 'Client.Options' are not -- supported so don't hesitate to open an issue on github if you find one.--- This function works around a difficulty with appending options to--- the 'createdb' plan by mappending to 'defaultConfig' and--- optionally replacing the database name. optionsToDefaultConfig :: Client.Options -> Config optionsToDefaultConfig opts@Client.Options {..} =- let thePartialPlan = configPlan defaultConfig- noDbDefault = defaultConfig- { configPlan = thePartialPlan- { partialPlanCreateDb = mempty- }- }- generateConfig = optionsToConfig opts- in noDbDefault <> generateConfig+ defaultConfig <> optionsToConfig opts
src/Database/Postgres/Temp/Internal/Partial.hs view
@@ -31,6 +31,8 @@ import Control.Monad.Trans.Cont import Control.Monad.Trans.Class import System.IO.Error+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map {- | 'Lastoid' is helper for overriding configuration values.@@ -66,12 +68,51 @@ Replace a -> a Mappend a -> a +-- | A type to help combine command line arguments.+data PartialCommandLineArgs = PartialCommandLineArgs+ { partialCommandLineArgsKeyBased :: Map String (Maybe String)+ -- ^ Arguments of the form @-h foo@, @--host=foo@ and @--switch@.+ -- The key is `mappend`ed with value so the key should include+ -- the space or equals (as shown in the first two examples+ -- respectively).+ , partialCommandLineArgsIndexBased :: Map Int String+ -- ^ Arguments that appear at the end of the key based+ -- arguments.+ }+ deriving stock (Generic, Show, Eq)+ deriving Monoid via GenericMonoid PartialCommandLineArgs++instance Semigroup PartialCommandLineArgs where+ x <> y = PartialCommandLineArgs+ { partialCommandLineArgsKeyBased =+ partialCommandLineArgsKeyBased y <> partialCommandLineArgsKeyBased x+ , partialCommandLineArgsIndexBased =+ partialCommandLineArgsIndexBased y <> partialCommandLineArgsIndexBased x+ }++-- | Take values as long as the index is the successor of the+-- last index.+takeWhileInSequence :: [(Int, a)] -> [a]+takeWhileInSequence ((0, x):xs) = x : go 0 xs where+ go _ [] = []+ go prev ((next, a):rest)+ | prev + 1 == next = a : go next rest+ | otherwise = []+takeWhileInSequence _ = []++-- | This convert the 'PartialCommandLineArgs' to '+completeCommandLineArgs :: PartialCommandLineArgs -> [String]+completeCommandLineArgs PartialCommandLineArgs {..}+ = map (\(name, mvalue) -> maybe name (name <>) mvalue)+ (Map.toList partialCommandLineArgsKeyBased)+ <> takeWhileInSequence (Map.toList partialCommandLineArgsIndexBased)+ -- | The monoidial version of 'ProcessConfig'. Used to combine overrides with -- defaults when creating a 'ProcessConfig'. data PartialProcessConfig = PartialProcessConfig- { partialProcessConfigEnvVars :: Lastoid [(String, String)]+ { partialProcessConfigEnvVars :: Lastoid (Map String String) -- ^ A monoid for combine environment variables or replacing them- , partialProcessConfigCmdLine :: Lastoid [String]+ , partialProcessConfigCmdLine :: Lastoid PartialCommandLineArgs -- ^ A monoid for combine command line arguments or replacing them , partialProcessConfigStdIn :: Last Handle -- ^ A monoid for configuring the standard input 'Handle'@@ -81,9 +122,23 @@ -- ^ A monoid for configuring the standard error 'Handle' } deriving stock (Generic)- deriving Semigroup via GenericSemigroup PartialProcessConfig deriving Monoid via GenericMonoid PartialProcessConfig +instance Semigroup PartialProcessConfig where+ x <> y = PartialProcessConfig+ { partialProcessConfigEnvVars = fmap getDual $+ fmap Dual (partialProcessConfigEnvVars x) <>+ fmap Dual (partialProcessConfigEnvVars y)+ , partialProcessConfigCmdLine =+ partialProcessConfigCmdLine x <> partialProcessConfigCmdLine y+ , partialProcessConfigStdIn =+ partialProcessConfigStdIn x <> partialProcessConfigStdIn y+ , partialProcessConfigStdOut =+ partialProcessConfigStdOut x <> partialProcessConfigStdOut y+ , partialProcessConfigStdErr =+ partialProcessConfigStdErr x <> partialProcessConfigStdErr y+ }+ -- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and -- 'stderr' and inherits the environment variables from the calling -- process.@@ -91,7 +146,7 @@ standardProcessConfig = do env <- getEnvironment pure mempty- { partialProcessConfigEnvVars = Replace env+ { partialProcessConfigEnvVars = Replace $ Map.fromList env , partialProcessConfigStdIn = pure stdin , partialProcessConfigStdOut = pure stdout , partialProcessConfigStdErr = pure stderr@@ -112,8 +167,9 @@ completeProcessConfig :: PartialProcessConfig -> Either [String] ProcessConfig completeProcessConfig PartialProcessConfig {..} = validationToEither $ do- let processConfigEnvVars = getLastoid partialProcessConfigEnvVars- processConfigCmdLine = getLastoid partialProcessConfigCmdLine+ let processConfigEnvVars = Map.toList $ getLastoid partialProcessConfigEnvVars+ processConfigCmdLine = completeCommandLineArgs $+ getLastoid partialProcessConfigCmdLine processConfigStdIn <- getOption "partialProcessConfigStdIn" partialProcessConfigStdIn processConfigStdOut <-@@ -197,8 +253,8 @@ -- | Many processes require a \"host\" flag. We can generate one from the -- 'SocketClass'.-socketClassToHostFlag :: SocketClass -> [String]-socketClassToHostFlag x = ["-h", socketClassToHost x]+socketClassToHostFlag :: SocketClass -> [(String, Maybe String)]+socketClassToHostFlag x = [("-h", Just (socketClassToHost x))] -- | Get the IP address, host name or UNIX domain socket directory -- as a 'String'@@ -343,10 +399,12 @@ , partialPlanDataDirectory = pure dataDirectory , partialPlanPostgres = mempty { partialPostgresPlanProcessConfig = mempty- { partialProcessConfigCmdLine = Mappend- [ "-p", show port- , "-D", dataDirectory- ]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased = Map.fromList+ [ ("-p", Just $ show port)+ , ("-D", Just dataDirectory)+ ]+ } } , partialPostgresPlanClientConfig = mempty { Client.host = pure $ socketClassToHost socketClass@@ -354,13 +412,18 @@ } } , partialPlanCreateDb = Mappend $ Just $ mempty- { partialProcessConfigCmdLine = Mappend $- socketClassToHostFlag socketClass <>- ["-p", show port]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased = Map.fromList $+ socketClassToHostFlag socketClass <>+ [("-p ", Just $ show port)]+ } } , partialPlanInitDb = Mappend $ Just $ mempty- { partialProcessConfigCmdLine = Mappend $- ["--pgdata=" <> dataDirectory]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased = Map.fromList $+ [("--pgdata=", Just dataDirectory)]+ }+ } } @@ -422,10 +485,14 @@ Nothing -> mempty Just user -> mempty { partialPlanCreateDb = Mappend $ Just $ mempty- { partialProcessConfigCmdLine = Mappend ["--username=" <> user]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user+ } } , partialPlanInitDb = Mappend $ Just $ mempty- { partialProcessConfigCmdLine = Mappend ["--username=" <> user]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user+ } } } @@ -434,7 +501,9 @@ Nothing -> mempty Just dbName -> mempty { partialPlanCreateDb = Mappend $ Just $ mempty- { partialProcessConfigCmdLine = Mappend [dbName]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsIndexBased = Map.singleton 0 dbName+ } } }
test/Spec.hs view
@@ -19,6 +19,7 @@ import Control.Concurrent import Data.Monoid import Network.Socket.Free (getFreePort)+import qualified Data.Map.Strict as Map main :: IO () main = hspec spec@@ -49,7 +50,7 @@ let Resources {..} = dbResources Plan {..} = resourcesPlan PostgresPlan {..} = planPostgres- Client.dbname postgresPlanClientConfig `shouldBe` pure "test"+ Client.dbname postgresPlanClientConfig `shouldBe` pure "postgres" let Temporary tmpDataDir = resourcesDataDir tmpDataDir `shouldStartWith` "/tmp/tmp-postgres-data" let Just port = getLast $ Client.port postgresPlanClientConfig@@ -84,12 +85,12 @@ } } , partialPlanInitDb = Mappend $ pure $ mempty- { partialProcessConfigCmdLine = Mappend- ["--user", "user-name"- ]- , partialProcessConfigEnvVars = Mappend- [ ("PGPASSWORD", "password")- ]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased =+ Map.singleton "--username=" $ Just "user-name"+ }+ , partialProcessConfigEnvVars = Mappend $+ Map.singleton "PGPASSWORD" "password" } , partialPlanConfig = Mappend [extraConfig] }@@ -97,14 +98,15 @@ -- hmm maybe I should provide lenses let combinedResources = defaultConfig <> customPlan finalCombinedResources = updateCreateDb combinedResources $ Mappend $ pure $ initialCreateDbConfig- { partialProcessConfigCmdLine = Mappend- ["--user", "user-name"- , expectedDbName- ]- , partialProcessConfigEnvVars = Mappend- [ ("PGPASSWORD", "password")- ]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsKeyBased =+ Map.singleton "--username=" $ Just "user-name"+ , partialCommandLineArgsIndexBased =+ Map.singleton 0 expectedDbName }+ , partialProcessConfigEnvVars = Mappend $+ Map.singleton "PGPASSWORD" "password"+ } action finalCombinedResources $ \db@DB {..} -> do bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do@@ -246,19 +248,19 @@ =<< either throwIO pure =<< start) stop f before (pure $ Runner startAction) $ do- someStandardTests "test"+ someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan describe "withRestart" $ do let startAction f = bracket (either throwIO pure =<< start) stop $ \db -> either throwIO pure =<< withRestart db f before (pure $ Runner startAction) $ do- someStandardTests "test"+ someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan describe "start/stop" $ do before (pure $ Runner $ \f -> bracket (either throwIO pure =<< start) stop f) $ do- someStandardTests "test"+ someStandardTests "postgres" defaultConfigShouldMatchDefaultPlan it "stopPostgres cannot be connected to" $ withRunner $ \db -> do stopPostgres db `shouldReturn` ExitSuccess@@ -279,7 +281,10 @@ let invalidCreateDbPlan = updateCreateDb defaultConfig $ Mappend $ pure $ theStandardProcessConfig- { partialProcessConfigCmdLine = Mappend ["template1"]+ { partialProcessConfigCmdLine = Mappend $ mempty+ { partialCommandLineArgsIndexBased =+ Map.singleton 0 "template1"+ } } before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith invalidCreateDbPlan) stop f) $ createDbThrowsIfTheDbExists@@ -299,10 +304,10 @@ someStandardTests "template1" before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith defaultIpPlan) stop f) $- someStandardTests "test"+ someStandardTests "postgres" before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startWith specificHostIpPlan) stop f) $- someStandardTests "test"+ someStandardTests "postgres" thePort <- runIO getFreePort let planFromCustomUserDbConnection = optionsToDefaultConfig mempty
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.0.1.0+version: 1.2.0.0 synopsis: Start and stop a temporary postgres description: @tmp-postgres@ provides functions creating a temporary @postgres@ instance.@@ -64,6 +64,7 @@ , generic-monoid , either , transformers+ , containers ghc-options: -Wall default-language: Haskell2010 @@ -73,6 +74,7 @@ hs-source-dirs: test main-is: Spec.hs build-depends: base+ , containers , postgresql-libpq , tmp-postgres , hspec@@ -88,6 +90,7 @@ , transformers , postgres-options , port-utils+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 default-extensions: LambdaCase