tmp-postgres 1.9.0.2 → 1.10.0.0
raw patch · 7 files changed
+190/−99 lines, 7 files
Files
- CHANGELOG.md +7/−0
- src/Database/Postgres/Temp.hs +4/−1
- src/Database/Postgres/Temp/Internal.hs +19/−5
- src/Database/Postgres/Temp/Internal/Config.hs +59/−50
- src/Database/Postgres/Temp/Internal/Core.hs +71/−25
- test/Spec.hs +28/−17
- tmp-postgres.cabal +2/−1
CHANGELOG.md view
@@ -18,3 +18,10 @@ 1.9.0.2 Documentation fixes++1.10.0.0+ #58 Add connection timeout+ Rename partialPlanLoggerL to loggerL+ Add temporaryDirectoryL+ #31 A silent defaults+ #20 Include stderr in errors
src/Database/Postgres/Temp.hs view
@@ -72,6 +72,8 @@ , defaultConfig , defaultPostgresConf , standardProcessConfig+ , silentConfig+ , silentProcessConfig -- ** Custom Config builder helpers , optionsToDefaultConfig -- ** 'Config'@@ -82,6 +84,7 @@ , socketClassL , dataDirectoryL , portL+ , connectionTimeoutL -- ** 'Plan' , Plan (..) -- *** 'Plan' lenses@@ -89,7 +92,7 @@ , createDbConfigL , dataDirectoryStringL , initDbConfigL- , partialPlanLoggerL+ , loggerL , postgresPlanL -- ** 'PostgresPlan' , PostgresPlan (..)
src/Database/Postgres/Temp/Internal.hs view
@@ -164,7 +164,8 @@ defaultConfig :: Config defaultConfig = mempty { plan = mempty- { logger = pure mempty+ { connectionTimeout = pure (60 * 1000000) -- 1 minute+ , logger = pure mempty , postgresConfigFile = defaultPostgresConfig , createDbConfig = Nothing , initDbConfig = pure standardProcessConfig@@ -204,6 +205,18 @@ } } +-- | The same as 'defaultConfig' but all the handles are set to \"/dev/null\".+-- See 'silentProcessConfig' as well.+silentConfig :: Config+silentConfig = defaultConfig <> mempty+ { plan = mempty+ { initDbConfig = pure silentProcessConfig+ , postgresPlan = mempty+ { postgresConfig = silentProcessConfig+ }+ }+ }+ {-| Create zero or more temporary resources and use them to make a 'Config'.@@ -276,10 +289,11 @@ restart :: DB -> IO (Either StartError DB) restart db@DB{..} = try $ do void $ stopPostgres db- let plan = resourcesPlan dbResources- bracketOnError (startPostgresProcess (completePlanLogger plan) $ completePlanPostgres plan)- stopPostgresProcess $ \result ->- pure $ db { dbPostgresProcess = result }+ let CompletePlan{..} = resourcesPlan dbResources+ startAction = startPostgresProcess completePlanConnectionTimeout completePlanLogger+ completePlanPostgres+ bracketOnError startAction stopPostgresProcess $ \result ->+ pure $ db { dbPostgresProcess = result } -- | Reload the configuration file without shutting down. Calls -- @pg_reload_conf()@.
src/Database/Postgres/Temp/Internal/Config.hs view
@@ -35,6 +35,7 @@ import System.IO import System.IO.Error import System.IO.Temp (createTempDirectory)+import System.IO.Unsafe (unsafePerformIO) import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc@@ -190,6 +191,22 @@ , stdErr = pure stderr } +devNull :: Handle+devNull = unsafePerformIO (openFile "/dev/null" WriteMode)+{-# NOINLINE devNull #-}++-- | 'silentProcessConfig' sets the handles to \"/dev/null\" and+-- inherits the environment variables from the calling process+silentProcessConfig :: ProcessConfig+silentProcessConfig = mempty+ { environmentVariables = mempty+ { inherit = pure True+ }+ , stdIn = pure devNull+ , stdOut = pure devNull+ , stdErr = pure devNull+ }+ -- A helper to add more info to all the error messages. addErrorContext :: String -> Either [String] a -> Either [String] a addErrorContext cxt = either (Left . map (cxt <>)) Right@@ -421,6 +438,9 @@ , postgresPlan :: PostgresPlan , postgresConfigFile :: [String] , dataDirectoryString :: Last String+ , connectionTimeout :: Last Int+ -- ^ Max time to spend attempting to connection to @postgres@.+ -- Time is in microseconds. } deriving stock (Generic) deriving Semigroup via GenericSemigroup Plan@@ -445,6 +465,8 @@ <> indent 2 (vsep $ map text postgresConfigFile) <> hardline <> text "dataDirectoryString:" <+> pretty (getLast dataDirectoryString)+ <> hardline+ <> text "connectionTimeout:" <+> pretty (getLast connectionTimeout) -- | Turn a 'Plan' into a 'CompletePlan'. Fails if any values are missing. completePlan :: [(String, String)] -> Plan -> Either [String] CompletePlan@@ -459,6 +481,8 @@ let completePlanConfig = unlines postgresConfigFile completePlanDataDirectory <- getOption "dataDirectoryString" dataDirectoryString+ completePlanConnectionTimeout <- getOption "connectionTimeout"+ connectionTimeout pure CompletePlan {..} @@ -805,76 +829,54 @@ -- | Lens for 'postgresConfigFile' postgresConfigFileL :: Lens' Plan [String]-postgresConfigFileL- f_amcw- (Plan x_amcx x_amcy x_amcz x_amcA x_amcB x_amcC)- = fmap- (\ y_amcD- -> Plan x_amcx x_amcy x_amcz x_amcA y_amcD- x_amcC)- (f_amcw x_amcB)+postgresConfigFileL f (plan@Plan{..})+ = fmap (\x -> plan { postgresConfigFile = x })+ (f postgresConfigFile) {-# INLINE postgresConfigFileL #-} -- | Lens for 'createDbConfig' createDbConfigL :: Lens' Plan (Maybe ProcessConfig)-createDbConfigL- f_amcE- (Plan x_amcF x_amcG x_amcH x_amcI x_amcJ x_amcK)- = fmap- (\ y_amcL- -> Plan x_amcF x_amcG y_amcL x_amcI x_amcJ- x_amcK)- (f_amcE x_amcH)+createDbConfigL f (plan@Plan{..})+ = fmap (\x -> plan { createDbConfig = x })+ (f createDbConfig) {-# INLINE createDbConfigL #-} -- | Lens for 'dataDirectoryString' dataDirectoryStringL :: Lens' Plan (Last String)-dataDirectoryStringL- f_amcM- (Plan x_amcN x_amcO x_amcP x_amcQ x_amcR x_amcS)- = fmap- (Plan x_amcN x_amcO x_amcP x_amcQ x_amcR)- (f_amcM x_amcS)+dataDirectoryStringL f (plan@Plan{..})+ = fmap (\x -> plan { dataDirectoryString = x })+ (f dataDirectoryString) {-# INLINE dataDirectoryStringL #-} -- | Lens for 'initDbConfig'-initDbConfigL ::- Lens' Plan (Maybe ProcessConfig)-initDbConfigL- f_amcU- (Plan x_amcV x_amcW x_amcX x_amcY x_amcZ x_amd0)- = fmap- (\ y_amd1- -> Plan x_amcV y_amd1 x_amcX x_amcY x_amcZ- x_amd0)- (f_amcU x_amcW)+initDbConfigL :: Lens' Plan (Maybe ProcessConfig)+initDbConfigL f (plan@Plan{..})+ = fmap (\x -> plan { initDbConfig = x })+ (f initDbConfig) {-# INLINE initDbConfigL #-} -- | Lens for 'logger'-partialPlanLoggerL :: Lens' Plan (Last Logger)-partialPlanLoggerL- f_amd2- (Plan x_amd3 x_amd4 x_amd5 x_amd6 x_amd7 x_amd8)- = fmap- (\ y_amd9- -> Plan y_amd9 x_amd4 x_amd5 x_amd6 x_amd7- x_amd8)- (f_amd2 x_amd3)-{-# INLINE partialPlanLoggerL #-}+loggerL :: Lens' Plan (Last Logger)+loggerL f (plan@Plan{..})+ = fmap (\x -> plan { logger = x })+ (f logger)+{-# INLINE loggerL #-} -- | Lens for 'postgresPlan' postgresPlanL :: Lens' Plan PostgresPlan-postgresPlanL- f_amda- (Plan x_amdb x_amdc x_amdd x_amde x_amdf x_amdg)- = fmap- (\ y_amdh- -> Plan x_amdb x_amdc x_amdd y_amdh x_amdf- x_amdg)- (f_amda x_amde)+postgresPlanL f (plan@Plan{..})+ = fmap (\x -> plan { postgresPlan = x })+ (f postgresPlan) {-# INLINE postgresPlanL #-} +-- | Lens for 'connectionTimeout'+connectionTimeoutL :: Lens' Plan (Last Int)+connectionTimeoutL f (plan@Plan{..})+ = fmap (\x -> plan { connectionTimeout = x })+ (f connectionTimeout)+{-# INLINE connectionTimeoutL #-}+ -- | Lens for 'resourcesDataDir' resourcesDataDirL :: Lens' Resources CompleteDirectoryType resourcesDataDirL f (resources@Resources {..})@@ -923,6 +925,13 @@ = fmap (\ x -> config { socketClass = x } ) (f socketClass) {-# INLINE socketClassL #-}++-- | Lens for 'socketClass'+temporaryDirectoryL :: Lens' Config (Last FilePath)+temporaryDirectoryL f (config@Config{..})+ = fmap (\ x -> config { temporaryDirectory = x } )+ (f temporaryDirectory)+{-# INLINE temporaryDirectoryL #-} -- | Lens for 'indexBased' indexBasedL ::
src/Database/Postgres/Temp/Internal/Core.hs view
@@ -7,11 +7,12 @@ module Database.Postgres.Temp.Internal.Core where import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (race_)+import Control.Concurrent.Async (race_, withAsync) import Control.Exception import Control.Monad (forever, (>=>)) import qualified Data.ByteString.Char8 as BSC import Data.Foldable (for_)+import Data.IORef import Data.Monoid import Data.String import Data.Typeable@@ -22,6 +23,7 @@ import System.Posix.Signals (sigINT, signalProcess) import System.Process import System.Process.Internals+import System.Timeout import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -- | Internal events for debugging@@ -48,15 +50,24 @@ = StartPostgresFailed ExitCode -- ^ @postgres@ failed before a connection succeeded. Most likely this -- is due to invalid configuration- | InitDbFailed ExitCode+ | InitDbFailed+ { startErrorStdOut :: String+ , startErrorStdErr :: String+ , startErrorExitCode :: ExitCode+ } -- ^ @initdb@ failed. This can be from invalid configuration or using a -- non-empty data directory- | CreateDbFailed ExitCode+ | CreateDbFailed+ { startErrorStdOut :: String+ , startErrorStdErr :: String+ , startErrorExitCode :: ExitCode+ } -- ^ @createdb@ failed. This can be from invalid configuration or -- the database might already exist. | CompletePlanFailed String [String] -- ^ The 'Database.Postgres.Temp.Config.Plan' was missing info and a complete 'CompletePlan' could -- not be created.+ | ConnectionTimedOut deriving (Show, Eq, Ord, Typeable) instance Exception StartError@@ -64,7 +75,6 @@ -- | A way to log internal 'Event's type Logger = Event -> IO () --- TODO. Add a Retrying Event -- | @postgres@ is not ready until we are able to successfully connect. -- 'waitForDB' attempts to connect over and over again and returns -- after the first successful connection.@@ -77,6 +87,20 @@ Left (_ :: IOError) -> threadDelay 10000 >> waitForDB logger options Right () -> return () +-- Only useful if we believe the output is finite+teeHandle :: Handle -> (Handle -> IO a) -> IO (a, String)+teeHandle orig f =+ bracket createPipe (\(x, y) -> hClose x >> hClose y) $ \(readEnd, writeEnd) -> do+ outputRef <- newIORef []++ let readerLoop = forever $ do+ theLine <- hGetLine readEnd+ modifyIORef outputRef (<>theLine)+ hPutStrLn orig theLine++ res <- withAsync readerLoop $ \_ -> f writeEnd+ (res,) <$> readIORef outputRef+ -- | 'CompleteProcessConfig' contains the configuration necessary for starting a -- process. It is essentially a stripped down 'System.Process.CreateProcess'. data CompleteProcessConfig = CompleteProcessConfig@@ -132,6 +156,22 @@ -- ^ Process config -> IO ExitCode executeProcess name = startProcess name >=> waitForProcess++-- | Start a process and block until it finishes return the 'ExitCode' and the+-- stderr output.+executeProcessAndTee+ :: String+ -- ^ Process name+ -> CompleteProcessConfig+ -- ^ Process config+ -> IO (ExitCode, String, String)+executeProcessAndTee name config = fmap (\((x, y), z) -> (x, z, y)) $+ teeHandle (completeProcessConfigStdOut config) $ \newOut ->+ teeHandle (completeProcessConfigStdErr config) $ \newErr ->+ executeProcess name $ config+ { completeProcessConfigStdErr = newErr+ , completeProcessConfigStdOut = newOut+ } ------------------------------------------------------------------------------- -- PostgresProcess Life cycle management -------------------------------------------------------------------------------@@ -205,8 +245,8 @@ -- | Start the @postgres@ process and block until a successful connection -- occurs. A separate thread we continously check to see if the @postgres@ -- process has crashed.-startPostgresProcess :: Logger -> CompletePostgresPlan -> IO PostgresProcess-startPostgresProcess logger CompletePostgresPlan {..} = do+startPostgresProcess :: Int -> Logger -> CompletePostgresPlan -> IO PostgresProcess+startPostgresProcess time logger CompletePostgresPlan {..} = do logger StartPostgres let startAction = PostgresProcess completePostgresPlanClientOptions@@ -215,11 +255,6 @@ -- Start postgres and stop if an exception occurs bracketOnError startAction stopPostgresProcess $ \result@PostgresProcess {..} -> do- -- A helper to check if the process has died- let checkForCrash = do- mExitCode <- getProcessExitCode postgresProcessHandle- for_ mExitCode (throwIO . StartPostgresFailed)- logger WaitForDB -- We assume that 'template1' exist and make connection -- options to test if postgres is ready.@@ -227,10 +262,18 @@ { Client.dbname = pure "template1" } - -- Block until a connection succeeds or postgres crashes- waitForDB logger options- `race_` forever (checkForCrash >> threadDelay 100000)+ -- A helper to check if the process has died+ checkForCrash = do+ mExitCode <- getProcessExitCode postgresProcessHandle+ for_ mExitCode (throwIO . StartPostgresFailed) + timeoutAndThrow = timeout time (waitForDB logger options) >>= \case+ Just () -> pure ()+ Nothing -> throwIO ConnectionTimedOut++ -- Block until a connection succeeds, postgres crashes or we timeout+ timeoutAndThrow `race_` forever (checkForCrash >> threadDelay 100000)+ -- Postgres is now ready so return return result -------------------------------------------------------------------------------@@ -243,12 +286,13 @@ -- are valid. 'CompletePlan's are used internally but are exposed if the higher -- level plan generation is not sufficent. data CompletePlan = CompletePlan- { completePlanLogger :: Logger- , completePlanInitDb :: Maybe CompleteProcessConfig- , completePlanCreateDb :: Maybe CompleteProcessConfig- , completePlanPostgres :: CompletePostgresPlan- , completePlanConfig :: String- , completePlanDataDirectory :: FilePath+ { completePlanLogger :: Logger+ , completePlanInitDb :: Maybe CompleteProcessConfig+ , completePlanCreateDb :: Maybe CompleteProcessConfig+ , completePlanPostgres :: CompletePostgresPlan+ , completePlanConfig :: String+ , completePlanDataDirectory :: FilePath+ , completePlanConnectionTimeout :: Int } instance Pretty CompletePlan where@@ -286,19 +330,21 @@ startPlan :: CompletePlan -> IO PostgresProcess startPlan plan@CompletePlan {..} = do completePlanLogger $ StartPlan $ show $ pretty plan- for_ completePlanInitDb $ executeProcess "initdb" >=>- throwIfNotSuccess InitDbFailed+ for_ completePlanInitDb $ executeProcessAndTee "initdb" >=>+ \(res, stdOut, stdErr) -> throwIfNotSuccess (InitDbFailed stdOut stdErr) res -- We must provide a config file before we can start postgres. writeFile (completePlanDataDirectory <> "/postgresql.conf") completePlanConfig - let startAction = startPostgresProcess completePlanLogger completePlanPostgres+ let startAction = startPostgresProcess+ completePlanConnectionTimeout completePlanLogger completePlanPostgres bracketOnError startAction stopPostgresProcess $ \result -> do- for_ completePlanCreateDb $ executeProcess "createdb" >=>- throwIfNotSuccess CreateDbFailed+ for_ completePlanCreateDb $ executeProcessAndTee "createdb" >=>+ \(res, stdOut, stdErr) -> throwIfNotSuccess (CreateDbFailed stdOut stdErr) res pure result+ -- | Stop the @postgres@ process. See 'stopPostgresProcess' for more details. stopPlan :: PostgresProcess -> IO ExitCode
test/Spec.hs view
@@ -81,7 +81,7 @@ , Client.dbname = pure expectedDbName } }- , initDbConfig = pure standardProcessConfig+ , initDbConfig = pure silentProcessConfig { commandLine = mempty { keyBased = Map.singleton "--username=" $ Just "user-name"@@ -91,7 +91,7 @@ , inherit = pure True } }- , createDbConfig = pure standardProcessConfig+ , createDbConfig = pure silentProcessConfig { commandLine = mempty { keyBased = Map.singleton "--username=" $ Just "user-name"@@ -108,7 +108,7 @@ } } -- hmm maybe I should provide lenses- let combinedResources = defaultConfig <> customPlan+ let combinedResources = silentConfig <> customPlan initialFiles <- listDirectory tmpDir @@ -138,7 +138,7 @@ ] } }- timeout 5000000 (action $ defaultConfig <> customPlan) `shouldThrow`+ timeout 5000000 (action $ silentConfig <> customPlan) `shouldThrow` (== StartPostgresFailed (ExitFailure 1)) @@ -198,15 +198,16 @@ createDbThrowsIfTheDbExists :: SpecWith Runner createDbThrowsIfTheDbExists = describe "createdb" $ it "throws if the db is not there" $ \(Runner runner) ->- runner (const $ pure ()) `shouldThrow` (== CreateDbFailed (ExitFailure 1))+ runner (const $ pure ()) `shouldThrow` (\(CreateDbFailed theOut theErr code) -> do+ code == ExitFailure 1 && length theErr > 0 && theOut == "") spec :: Spec spec = do- let defaultIpPlan = defaultConfig+ let defaultIpPlan = silentConfig { socketClass = IpSocket $ Last Nothing } - specificHostIpPlan = defaultConfig+ specificHostIpPlan = silentConfig { socketClass = IpSocket $ pure "localhost" } @@ -215,7 +216,7 @@ throwsIfInitDbIsNotOnThePath startAction describe "startConfig" $ do let startAction plan = bracket (either throwIO pure =<< startConfig plan) stop pure- throwsIfInitDbIsNotOnThePath $ startAction defaultConfig+ throwsIfInitDbIsNotOnThePath $ startAction silentConfig invalidConfigFailsQuickly $ void . startAction customConfigWork $ \config@Config{..} f -> bracket (either throwIO pure =<< startConfig config) stop f@@ -226,8 +227,7 @@ let startAction plan = either throwIO pure =<< withConfig plan pure - throwsIfInitDbIsNotOnThePath $ startAction defaultConfig--- throwsIfCreateDbIsNotOnThePath $ startAction defaultConfig+ throwsIfInitDbIsNotOnThePath $ startAction silentConfig invalidConfigFailsQuickly $ void . startAction customConfigWork $ \plan f -> either throwIO pure =<< withConfig plan f@@ -275,8 +275,8 @@ [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement" actualDuration `shouldBe` expectedDuration - let invalidCreateDbPlan = defaultConfig <> fromCreateDb- ( pure $ standardProcessConfig+ let invalidCreateDbPlan = silentConfig <> fromCreateDb+ ( pure $ silentProcessConfig { commandLine = mempty { indexBased = Map.singleton 0 "template1"@@ -316,21 +316,32 @@ before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig planFromCustomUserDbConnection) stop f) $ someStandardTests "fancy" + let immediantlyTimeout = silentConfig <> mempty+ { plan = mempty+ { connectionTimeout = pure 0+ }+ }++ before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig immediantlyTimeout) stop f) $+ it "should timeout" $ \(Runner runner) ->+ runner (const $ pure ()) `shouldThrow` (== ConnectionTimedOut)+ before (createTempDirectory "/tmp" "tmp-postgres-test") $ after rmDirIgnoreErrors $ do it "fails on non-empty data directory" $ \dirPath -> do writeFile (dirPath <> "/PG_VERSION") "1 million"- let nonEmptyFolderPlan = defaultConfig+ let nonEmptyFolderPlan = silentConfig { dataDirectory = Permanent dirPath } startAction = bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ const $ pure () - startAction `shouldThrow` (== InitDbFailed (ExitFailure 1))+ startAction `shouldThrow` (\(InitDbFailed theOut theErr code) -> do+ code == ExitFailure 1 && length theOut > 0 && length theErr > 0) it "works if on non-empty if initdb is disabled" $ \dirPath -> do throwIfNotSuccess id =<< system ("initdb " <> dirPath)- let nonEmptyFolderPlan = defaultConfig+ let nonEmptyFolderPlan = silentConfig { dataDirectory = Permanent dirPath- , plan = (plan defaultConfig)+ , plan = (plan silentConfig) { initDbConfig = Nothing } }@@ -352,7 +363,7 @@ ] } }- backupResources = defaultConfig <> justBackupResources+ backupResources = silentConfig <> justBackupResources before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig backupResources) stop f) $ it "can support backup and restore" $ withRunner $ \db@DB {..} -> do let dataDir = toFilePath (resourcesDataDir dbResources)
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name: tmp-postgres-version: 1.9.0.2+version: 1.10.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@@ -33,6 +33,7 @@ , RecordWildCards , ScopedTypeVariables , TemplateHaskell+ , TupleSections , ViewPatterns build-depends: base >= 4.6 && < 5 , ansi-wl-pprint