diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/Database/Postgres/Temp.hs b/src/Database/Postgres/Temp.hs --- a/src/Database/Postgres/Temp.hs +++ b/src/Database/Postgres/Temp.hs @@ -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 (..) diff --git a/src/Database/Postgres/Temp/Internal.hs b/src/Database/Postgres/Temp/Internal.hs --- a/src/Database/Postgres/Temp/Internal.hs +++ b/src/Database/Postgres/Temp/Internal.hs @@ -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()@. diff --git a/src/Database/Postgres/Temp/Internal/Config.hs b/src/Database/Postgres/Temp/Internal/Config.hs --- a/src/Database/Postgres/Temp/Internal/Config.hs +++ b/src/Database/Postgres/Temp/Internal/Config.hs @@ -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 :: diff --git a/src/Database/Postgres/Temp/Internal/Core.hs b/src/Database/Postgres/Temp/Internal/Core.hs --- a/src/Database/Postgres/Temp/Internal/Core.hs +++ b/src/Database/Postgres/Temp/Internal/Core.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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) diff --git a/tmp-postgres.cabal b/tmp-postgres.cabal --- a/tmp-postgres.cabal +++ b/tmp-postgres.cabal @@ -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