tmp-postgres 1.14.1.0 → 1.15.0.0
raw patch · 7 files changed
+122/−205 lines, 7 files
Files
- CHANGELOG.md +4/−0
- src/Database/Postgres/Temp.hs +2/−1
- src/Database/Postgres/Temp/Config.hs +1/−3
- src/Database/Postgres/Temp/Internal.hs +11/−15
- src/Database/Postgres/Temp/Internal/Config.hs +52/−147
- test/Main.hs +51/−38
- tmp-postgres.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,9 @@ Changelog for tmp-postgres +1.15.0.0+ #137 Remove SocketClass and listen unconditionally on 127.0.0.1, ::1 and a UNIX socket.+ #138 Fix bug where optionsToDefaultConfig would make createdb plan even if one is not needed.+ 1.14.1.0 #122 Fix bug that would prevent temporary directory removal
src/Database/Postgres/Temp.hs view
@@ -1,7 +1,8 @@ {-| This module provides functions for creating a temporary @postgres@ instance. By default it will create a temporary data directory and-a temporary directory for a UNIX domain socket for @postgres@ to listen on.+a temporary directory for a UNIX domain socket for @postgres@ to listen on in addition to+listening on 127.0.0.1 and ::1. Here is an example using the expection safe 'with' function:
src/Database/Postgres/Temp/Config.hs view
@@ -16,7 +16,7 @@ , prettyPrintConfig -- *** 'Config' Lenses , planL- , socketClassL+ , socketDirectoryL , dataDirectoryL , portL , connectionTimeoutL@@ -54,8 +54,6 @@ , keyBasedL -- ** 'DirectoryType' , DirectoryType (..)- -- ** 'SocketClass'- , SocketClass (..) -- ** 'Logger' , Logger -- * Internal events passed to the 'logger' .
src/Database/Postgres/Temp/Internal.hs view
@@ -221,7 +221,11 @@ } --- @since 1.14.0.0+{-|+A config that logs as little as possible.++@since 1.14.0.0+-} silentPostgresConfig :: [String] silentPostgresConfig = [ "shared_buffers = 12MB"@@ -275,21 +279,13 @@ generated '<>' extra @ -Based on the value of 'socketClass' a \"postgresql.conf\" is created with:-- @- listen_addresses = \'IP_ADDRESS\'- @-- if it is 'IpSocket'. If is 'UnixSocket' then the lines:+Based on the value of 'socketDirectory' a \"postgresql.conf\" is created with: @- listen_addresses = ''+ listen_addresses = '127.0.0.1, ::1' unix_socket_directories = \'SOCKET_DIRECTORY\' @ -are added.- Additionally the @generated@ `Config` also does the following: * Sets a `connectionTimeout` of one minute.@@ -311,7 +307,7 @@ or just use 'withConfig'. If you are calling 'startConfig' you probably want 'withConfig' anyway. -@since 1.12.0.0+@since 1.15.0.0 -} startConfig :: Config -- ^ @extra@ configuration that is 'mappend'ed last to the generated `Config`.@@ -376,7 +372,7 @@ Exception safe database create with options. See 'startConfig' for more details. Calls 'stop' even in the face of exceptions. -@since 1.12.0.0+@since 1.15.0.0 -} withConfig :: Config -- ^ @extra@. 'Config' combined with the generated 'Config'. See@@ -393,7 +389,7 @@ 'with' = 'withConfig' 'defaultConfig' @ -@since 1.12.0.0+@since 1.15.0.0 -} with :: (DB -> IO a) -- ^ @action@ continuation.@@ -411,7 +407,7 @@ -- want to create a database owned by a specific user you will also login -- with among other use cases. ----- @since 1.13.1.0+-- @since 1.15.0.0 optionsToDefaultConfig :: Client.Options -> Config optionsToDefaultConfig opts@Client.Options {..} = let generated = optionsToConfig opts
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -26,7 +26,6 @@ import Data.Maybe import Data.Monoid import Data.Monoid.Generic-import Data.Typeable import qualified Database.PostgreSQL.Simple.Options as Client import GHC.Generics (Generic) import Network.Socket.Free (getFreePort)@@ -341,100 +340,6 @@ CPermanent _ -> pure () CTemporary filePath -> rmDirIgnoreErrors filePath --- | A type for configuring the listening address of the @postgres@ process.--- @postgres@ can listen on several types of sockets simulatanously but we--- don't support that behavior. One can either listen on a IP based socket--- or a UNIX domain socket.------ @since 1.12.0.0-data CompleteSocketClass- = CIpSocket String- -- ^ IP socket type. The 'String' is either an IP address or- -- a host that will resolve to an IP address.- | CUnixSocket CompleteDirectoryType- -- ^ UNIX domain socket- deriving (Show, Eq, Ord, Generic, Typeable)--instance Pretty CompleteSocketClass where- pretty = \case- CIpSocket x -> text "CIpSocket:" <+> pretty x- CUnixSocket x -> text "CUnixSocket:" <+> pretty x---- | Create the extra config lines for listening based on the 'CompleteSocketClass'.-socketClassToConfig :: CompleteSocketClass -> [String]-socketClassToConfig = \case- CIpSocket ip -> ["listen_addresses = '" <> ip <> "'"]- CUnixSocket dir ->- [ "listen_addresses = ''"- , "unix_socket_directories = '" <> toFilePath dir <> "'"- ]---- | Many processes require a \"host\" flag. We can generate one from the--- 'CompleteSocketClass'.-socketClassToHostFlag :: CompleteSocketClass -> [(String, Maybe String)]-socketClassToHostFlag x = [("-h", Just (socketClassToHost x))]---- | Get the IP address, host name or UNIX domain socket directory--- as a 'String'.-socketClassToHost :: CompleteSocketClass -> String-socketClassToHost = \case- CIpSocket ip -> ip- CUnixSocket dir -> toFilePath dir---- | 'SocketClass' is used to specify how @postgres@ should listen for connections--- The two main options are a `IpSocket` which takes a hostname or IP address.--- if not is given the default it "127.0.0.1". Alternatively one can--- specify 'UnixSocket' for a UNIX domain socket. If a directory is--- specified the socket will live in that folder. Otherwise a--- temporary folder will get created for the socket.------ @since 1.12.0.0-data SocketClass- = IpSocket (Last String)- -- ^ The monoid for combining IP address configuration.- | UnixSocket DirectoryType- -- ^ The monoid for combining UNIX socket configuration.- deriving stock (Show, Eq, Ord, Generic, Typeable)--instance Pretty SocketClass where- pretty = \case- IpSocket x -> "CIpSocket:" <+> pretty (getLast x)- UnixSocket x -> "CUnixSocket" <+> pretty x---- | Last 'IpSocket' wins. 'UnixSocket' 'DirectoryType' as--- 'mappend'ed together.-instance Semigroup SocketClass where- x <> y = case (x, y) of- (IpSocket a, IpSocket b) -> IpSocket $ a <> b- (a@(IpSocket _), UnixSocket _) -> a- (UnixSocket _, a@(IpSocket _)) -> a- (UnixSocket a, UnixSocket b) -> UnixSocket $ a <> b---- | Treats 'UnixSocket' 'mempty' as 'mempty'.-instance Monoid SocketClass where- mempty = UnixSocket mempty---- | Turn a 'SocketClass' to a 'CompleteSocketClass'. If the 'IpSocket' is--- 'Nothing' default to \"127.0.0.1\". If the is a 'UnixSocket'--- optionally create a temporary directory if configured to do so.-setupSocketClass- :: String- -- ^ Temporary directory.- -> SocketClass- -- ^ The type of socket.- -> IO CompleteSocketClass-setupSocketClass tempDir theClass = case theClass of- IpSocket mIp -> pure $ CIpSocket $ fromMaybe "127.0.0.1" $- getLast mIp- UnixSocket mFilePath ->- CUnixSocket <$> setupDirectoryType tempDir "tmp-postgres-socket" mFilePath---- | Cleanup the UNIX socket temporary directory if one was created.-cleanupSocketConfig :: CompleteSocketClass -> IO ()-cleanupSocketConfig = \case- CIpSocket {} -> pure ()- CUnixSocket dir -> cleanupDirectoryType dir- -- | @postgres@ process config and corresponding client connection -- 'Client.Options'. --@@ -542,13 +447,13 @@ -- | The high level options for overriding default behavior. ----- @since 1.12.0.0+-- @since 1.15.0.0 data Config = Config { plan :: Plan -- ^ Extend or replace any of the configuration used to create a final -- 'CompletePlan'.- , socketClass :: SocketClass- -- ^ Override the default 'CompleteSocketClass' by setting this.+ , socketDirectory :: DirectoryType+ -- ^ Override the default temporary UNIX socket directory by setting this. , dataDirectory :: DirectoryType -- ^ Override the default temporary data directory by passing in -- 'Permanent' @DIRECTORY@.@@ -569,9 +474,9 @@ <> softline <> pretty plan <> hardline- <> text "socketClass:"+ <> text "socketDirectory:" <> softline- <> pretty socketClass+ <> pretty socketDirectory <> hardline <> text "dataDirectory:" <> softline@@ -583,6 +488,12 @@ <> softline <> pretty (getLast temporaryDirectory) +socketDirectoryToConfig :: FilePath -> [String]+socketDirectoryToConfig dir =+ [ "listen_addresses = '127.0.0.1, ::1'"+ , "unix_socket_directories = '" <> dir <> "'"+ ]+ -- | Create a 'Plan' that sets the command line options of all processes -- (@initdb@, @postgres@ and @createdb@). This the @generated@ plan -- that is combined with the @extra@ plan from@@ -594,13 +505,13 @@ -- ^ Make @createdb@ options -> Int -- ^ port- -> CompleteSocketClass- -- ^ Whether to listen on a IP address or UNIX domain socket -> FilePath+ -- ^ Socket directory+ -> FilePath -- ^ The @postgres@ data directory -> Plan-toPlan makeInitDb makeCreateDb port socketClass dataDirectoryString = mempty- { postgresConfigFile = socketClassToConfig socketClass+toPlan makeInitDb makeCreateDb port socketDirectory dataDirectoryString = mempty+ { postgresConfigFile = socketDirectoryToConfig socketDirectory , dataDirectoryString = pure dataDirectoryString , connectionTimeout = pure (60 * 1000000) -- 1 minute , logger = pure print@@ -614,7 +525,7 @@ } } , connectionOptions = mempty- { Client.host = pure $ socketClassToHost socketClass+ { Client.host = pure socketDirectory , Client.port = pure port , Client.dbname = pure "postgres" }@@ -623,8 +534,9 @@ then pure $ standardProcessConfig { commandLine = mempty { keyBased = Map.fromList $- socketClassToHostFlag socketClass <>- [("-p ", Just $ show port)]+ [ ("-h", Just socketDirectory)+ , ("-p ", Just $ show port)+ ] } } else Nothing@@ -650,15 +562,15 @@ envs <- lift getEnvironment thePort <- lift $ maybe getFreePort pure $ join $ getLast port let resourcesTemporaryDir = fromMaybe "/tmp" $ getLast temporaryDirectory- resourcesSocket <- ContT $ bracketOnError- (setupSocketClass resourcesTemporaryDir socketClass) cleanupSocketConfig+ resourcesSocketDirectory <- ContT $ bracketOnError+ (setupDirectoryType resourcesTemporaryDir "tmp-postgres-socket" socketDirectory) cleanupDirectoryType resourcesDataDir <- ContT $ bracketOnError (setupDirectoryType resourcesTemporaryDir "tmp-postgres-data" dataDirectory) cleanupDirectoryType let hostAndDir = toPlan (hasInitDb plan) (hasCreateDb plan) thePort- resourcesSocket+ (toFilePath resourcesSocketDirectory) (toFilePath resourcesDataDir) finalPlan = hostAndDir <> plan resourcesPlan <- lift $@@ -669,7 +581,7 @@ -- | Free the temporary resources created by 'setupConfig'. cleanupConfig :: Resources -> IO () cleanupConfig Resources {..} = do- cleanupSocketConfig resourcesSocket+ cleanupDirectoryType resourcesSocketDirectory cleanupDirectoryType resourcesDataDir -- | Display a 'Config'.@@ -686,9 +598,8 @@ data Resources = Resources { resourcesPlan :: CompletePlan -- ^ Final 'CompletePlan'. See 'startPlan' for information on 'CompletePlan's.- , resourcesSocket :: CompleteSocketClass- -- ^ The 'CompleteSocketClass'. Used to track if a temporary directory was made- -- as the socket location.+ , resourcesSocketDirectory :: CompleteDirectoryType+ -- ^ The used to potentially cleanup the temporary unix socket directory. , resourcesDataDir :: CompleteDirectoryType -- ^ The data directory. Used to track if a temporary directory was used. , resourcesTemporaryDir :: FilePath@@ -703,7 +614,7 @@ <> indent 2 (pretty resourcesPlan) <> hardline <> text "resourcesSocket:"- <+> pretty resourcesSocket+ <+> pretty resourcesSocketDirectory <> hardline <> text "resourcesDataDir:" <+> pretty resourcesDataDir@@ -728,14 +639,14 @@ = ( mempty { plan = optionsToPlan opts , port = maybe (Last Nothing) (pure . pure) $ getLast port- , socketClass = maybe mempty hostToSocketClass $ getLast host+ , socketDirectory = maybe mempty hostToSocketClass $ getLast host } ) -- Convert the 'Client.Options' to a 'Plan' that can -- be connected to with the 'Client.Options'. optionsToPlan :: Client.Options -> Plan optionsToPlan opts@Client.Options {..}- = maybe mempty dbnameToPlan (getLast dbname)+ = maybe mempty (dbnameToPlan (getLast user) (getLast password)) (getLast dbname) <> maybe mempty userToPlan (getLast user) <> maybe mempty passwordToPlan (getLast password) <> clientOptionsToPlan opts@@ -752,12 +663,7 @@ -- Create a 'Plan' given a user. userToPlan :: String -> Plan userToPlan user = mempty- { createDbConfig = pure $ mempty- { commandLine = mempty- { keyBased = Map.singleton "--username=" $ Just user- }- }- , initDbConfig = pure $ mempty+ { initDbConfig = pure $ mempty { commandLine = mempty { keyBased = Map.singleton "--username=" $ Just user }@@ -768,14 +674,18 @@ -- as the database name. -- It does nothing if the db names are "template1" or -- "postgres"-dbnameToPlan :: String -> Plan-dbnameToPlan dbName+dbnameToPlan :: Maybe String -> Maybe String -> String -> Plan+dbnameToPlan muser mpassword dbName | dbName == "template1" || dbName == "postgres" = mempty | otherwise = mempty { createDbConfig = pure $ mempty { commandLine = mempty { indexBased = Map.singleton 0 dbName+ , keyBased = maybe mempty (Map.singleton "--username=" . Just) muser }+ , environmentVariables = mempty+ { specific = maybe mempty (Map.singleton "PGPASSWORD") mpassword+ } } } @@ -787,19 +697,14 @@ { specific = Map.singleton "PGPASSWORD" password } }- , createDbConfig = pure mempty- { environmentVariables = mempty- { specific = Map.singleton "PGPASSWORD" password- }- } } -- Parse a host string as either an UNIX domain socket directory -- or a domain or IP.-hostToSocketClass :: String -> SocketClass+hostToSocketClass :: String -> DirectoryType hostToSocketClass hostOrSocketPath = case hostOrSocketPath of- '/' : _ -> UnixSocket $ Permanent hostOrSocketPath- _ -> IpSocket $ pure hostOrSocketPath+ '/' : _ -> Permanent hostOrSocketPath+ _ -> Temporary ------------------------------------------------------------------------------- -- Lenses@@ -1007,14 +912,14 @@ (f resourcesPlan) {-# INLINE resourcesPlanL #-} --- | Lens for 'resourcesSocket'.+-- | Lens for 'resourcesSocketDirectory'. ----- @since 1.12.0.0-resourcesSocketL :: Lens' Resources CompleteSocketClass-resourcesSocketL f (resources@Resources {..})- = fmap (\x -> resources { resourcesSocket = x })- (f resourcesSocket)-{-# INLINE resourcesSocketL #-}+-- @since 1.15.0.0+resourcesSocketDirectoryL :: Lens' Resources CompleteDirectoryType+resourcesSocketDirectoryL f (resources@Resources {..})+ = fmap (\x -> resources { resourcesSocketDirectory = x })+ (f resourcesSocketDirectory)+{-# INLINE resourcesSocketDirectoryL #-} -- | Lens for 'dataDirectory'. --@@ -1043,16 +948,16 @@ (f port) {-# INLINE portL #-} --- | Lens for 'socketClass'.+-- | Lens for 'socketDirectory'. -- -- @since 1.12.0.0-socketClassL :: Lens' Config SocketClass-socketClassL f (config@Config{..})- = fmap (\ x -> config { socketClass = x } )- (f socketClass)-{-# INLINE socketClassL #-}+socketDirectoryL :: Lens' Config DirectoryType+socketDirectoryL f (config@Config{..})+ = fmap (\ x -> config { socketDirectory = x } )+ (f socketDirectory)+{-# INLINE socketDirectoryL #-} --- | Lens for 'socketClass'.+-- | Lens for 'socketDirectory'. -- -- @since 1.12.0.0 temporaryDirectoryL :: Lens' Config (Last FilePath)
test/Main.hs view
@@ -14,7 +14,7 @@ import Database.Postgres.Temp.Internal.Config import Database.Postgres.Temp.Internal.Core import GHC.Generics (Generic)-import qualified Network.Socket as N+-- import qualified Network.Socket as N import Network.Socket.Free import System.Directory import System.Environment@@ -27,7 +27,9 @@ import Test.Hspec withConn :: DB -> (PG.Connection -> IO a) -> IO a-withConn db = bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close+withConn db f = do+ let connStr = toConnectionString db+ bracket (PG.connectPostgreSQL connStr) PG.close f withConfig' :: Config -> (DB -> IO a) -> IO a withConfig' config = either throwIO pure <=< withConfig config@@ -147,15 +149,15 @@ optionsToDefaultConfigFilledOutConfigAssert :: Int -> ConfigAndAssertion optionsToDefaultConfigFilledOutConfigAssert expectedPort = let- expectedDbName = "fancy"+ expectedDbName = "foobar" expectedUser = "some_user" expectedPassword = "password" expectedHost = "localhost" cConfig = optionsToDefaultConfig mempty- { Client.dbname = pure expectedDbName+ { Client.port = pure expectedPort+ , Client.dbname = pure expectedDbName , Client.user = pure expectedUser- , Client.port = pure expectedPort , Client.password = pure expectedPassword , Client.host = pure expectedHost }@@ -164,9 +166,9 @@ let Client.Options {..} = toConnectionOptions db port `shouldBe` pure expectedPort user `shouldBe` pure expectedUser- host `shouldBe` pure expectedHost- password `shouldBe` pure expectedPassword dbname `shouldBe` pure expectedDbName+ password `shouldBe` pure expectedPassword+ host `shouldBe` pure expectedHost in ConfigAndAssertion {..} @@ -189,7 +191,13 @@ defaultIpConfig = let cConfig = mempty- { socketClass = IpSocket $ Last Nothing+ { plan = mempty+ { postgresPlan = mempty+ { connectionOptions = mempty+ { Client.host = pure "127.0.0.1"+ }+ }+ } } cAssert db = do@@ -198,25 +206,12 @@ in ConfigAndAssertion {..} --- TODO add check of actual host-specificHostIpConfigAssert :: ConfigAndAssertion-specificHostIpConfigAssert =- let- cConfig = mempty- { socketClass = IpSocket $ pure "localhost"- } - cAssert db = do- let Client.Options {..} = toConnectionOptions db- host `shouldBe` pure "localhost"-- in ConfigAndAssertion {..}- specificUnixSocket :: FilePath -> ConfigAndAssertion specificUnixSocket filePath = let cConfig = mempty- { socketClass = UnixSocket $ Permanent filePath+ { socketDirectory = Permanent filePath } cAssert db = do let@@ -264,7 +259,7 @@ happyPaths = describe "succeeds with" $ do it "mempty and extra postgresql.conf" $ testWithTemporaryDirectory- (silentConfigAssert <> memptyConfigAndAssertion <> extraConfigAssert)+ (defaultConfigAssert <> memptyConfigAndAssertion <> extraConfigAssert) testSuccessfulConfig it "optionsToDefaultConfig mempty is the same as mempty Config" $@@ -305,11 +300,6 @@ (silentConfigAssert <> defaultIpConfig) testSuccessfulConfig - it "specific ip option works" $- testWithTemporaryDirectory- (defaultConfigAssert <> specificHostIpConfigAssert)- testSuccessfulConfig- it "specific unix socket works" $ withTempDirectory "/tmp" "tmp-postgres-spec-socket" $ \socketFilePath -> testWithTemporaryDirectory@@ -377,6 +367,7 @@ } timeout 100000 (withConfig (silentConfig <> invalidConfig) (const $ pure ())) `shouldReturn` Nothing+{- it "throws StartPostgresFailed if the port is taken" $ bracket openFreePort (N.close . snd) $ \(thePort, _) -> do let invalidConfig = optionsToDefaultConfig mempty@@ -385,21 +376,33 @@ } withConfig invalidConfig (const $ pure ()) `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1)-+-} it "throws StartPostgresFailed if the host does not exist" $ do let invalidConfig = optionsToDefaultConfig mempty { Client.host = pure "focalhost" }- withConfig invalidConfig (const $ pure ())- `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + invalidConfig' = invalidConfig+ { plan = (plan invalidConfig)+ { connectionTimeout = pure 100000+ }+ }+ withConfig invalidConfig' (const $ pure ())+ `shouldReturn` Left ConnectionTimedOut+ it "throws StartPostgresFailed if the host does not resolve to ip that is local" $ do let invalidConfig = optionsToDefaultConfig mempty { Client.host = pure "yahoo.com" }- withConfig invalidConfig (const $ pure ())- `shouldReturn` Left (StartPostgresFailed $ ExitFailure 1) + invalidConfig' = invalidConfig+ { plan = (plan invalidConfig)+ { connectionTimeout = pure 100000+ }+ }+ withConfig invalidConfig' (const $ pure ())+ `shouldReturn` Left ConnectionTimedOut+ it "throws StartPostgresFailed if the host path does not exist" $ do let invalidConfig = optionsToDefaultConfig mempty { Client.host = pure "/focalhost"@@ -583,7 +586,7 @@ , "postgresConfig:" , "postgresConfigFile:" , "postgresPlan:"- , "socketClass:"+ , "socketDirectory:" , "specific:" , "stdErr:" , "stdIn:"@@ -613,7 +616,7 @@ , "fsync=on" , "synchronous_commit=on" ]- backupResources = silentConfig <> justBackupResources+ backupResources = justBackupResources it "can support backup and restore" $ withConfig' backupResources $ \db@DB {..} -> do let dataDir = toFilePath (resourcesDataDir dbResources)@@ -631,10 +634,20 @@ let Just port = getLast $ Client.port $ postgresProcessClientOptions dbPostgresProcess Just host = getLast $ Client.host $ postgresProcessClientOptions dbPostgresProcess- backupCommand = "pg_basebackup -D " ++ baseBackupFile ++ " --format=tar -p"- ++ show port ++ " -h" ++ host+ backupCommandFlags =+ [ "-D" ++ baseBackupFile+ , "--format=tar"+ , "-p" ++ show port+ , "-h" ++ host+ ] - system backupCommand `shouldReturn` ExitSuccess+ (exitCode, stdouts, errs) <- readProcessWithExitCode "pg_basebackup" backupCommandFlags []+ case exitCode of+ ExitSuccess -> pure ()+ ExitFailure _ -> do+ putStrLn stdouts+ putStrLn errs+ fail $ "pg_basebackup failed with flags " ++ unwords backupCommandFlags bracket (PG.connectPostgreSQL $ toConnectionString db ) PG.close $ \conn -> do _ <- PG.execute_ conn "CREATE TABLE foo(id int PRIMARY KEY);"
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.14.1.0+version: 1.15.0.0 synopsis: Start and stop a temporary postgres description: Start and stop a temporary postgres. See README.md homepage: https://github.com/jfischoff/tmp-postgres#readme