diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ Changelog for tmp-postgres +1.16.0.0 + #149 CopyDirectoryCommand partial and rename the old CopyDirectoryCommand to + CompleteCopyDirectoryCommand. + 1.15.1.1 #141 Documentation fixes. diff --git a/src/Database/Postgres/Temp/Config.hs b/src/Database/Postgres/Temp/Config.hs --- a/src/Database/Postgres/Temp/Config.hs +++ b/src/Database/Postgres/Temp/Config.hs @@ -26,6 +26,7 @@ , postgresConfigFileL , createDbConfigL , dataDirectoryStringL + , copyConfigL , initDbConfigL , loggerL , postgresPlanL @@ -34,6 +35,10 @@ -- *** 'PostgresPlan' lenses , connectionOptionsL , postgresConfigL + -- ** 'CopyDirectoryCommand' + , sourceDirectoryL + , destinationDirectoryL + , useCopyOnWriteL -- ** 'ProcessConfig' , ProcessConfig (..) -- *** 'ProcessConfig' Lenses 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 @@ -392,7 +392,7 @@ ------------------------------------------------------------------------------- -- | Describe how to run @initdb@, @createdb@ and @postgres@ -- --- @since 1.12.0.0 +-- @since 1.16.0.0 data Plan = Plan { logger :: Last Logger , initDbConfig :: Maybe ProcessConfig @@ -436,20 +436,28 @@ -- | Turn a 'Plan' into a 'CompletePlan'. Fails if any values are missing. completePlan :: [(String, String)] -> Plan -> Either [String] CompletePlan -completePlan envs Plan {..} = runErrors $ do - completePlanLogger <- getOption "logger" logger - completePlanInitDb <- eitherToErrors $ addErrorContext "initDbConfig: " $ - traverse (completeProcessConfig envs) initDbConfig - completePlanCopy <- getOption "dataDirectoryString" copyConfig - completePlanCreateDb <- eitherToErrors $ addErrorContext "createDbConfig: " $ - traverse (completeProcessConfig envs) createDbConfig - completePlanPostgres <- eitherToErrors $ addErrorContext "postgresPlan: " $ - completePostgresPlan envs postgresPlan +completePlan envs Plan {..} = do + ( completePlanLogger + , completePlanInitDb + , completePlanCreateDb + , completePlanPostgres + , completePlanDataDirectory + , completePlanConnectionTimeout + ) <- runErrors + $ (,,,,,) + <$> getOption "logger" logger + <*> eitherToErrors (addErrorContext "initDbConfig: " $ + traverse (completeProcessConfig envs) initDbConfig) + <*> eitherToErrors (addErrorContext "createDbConfig: " $ + traverse (completeProcessConfig envs) createDbConfig) + <*> eitherToErrors (addErrorContext "postgresPlan: " + (completePostgresPlan envs postgresPlan)) + <*> getOption "dataDirectoryString" dataDirectoryString + <*> getOption "connectionTimeout" connectionTimeout + let completePlanConfig = unlines postgresConfigFile - completePlanDataDirectory <- getOption "dataDirectoryString" - dataDirectoryString - completePlanConnectionTimeout <- getOption "connectionTimeout" - connectionTimeout + completePlanCopy =completeCopyDirectory completePlanDataDirectory <$> + join (getLast copyConfig) pure CompletePlan {..} @@ -465,7 +473,7 @@ -- | The high level options for overriding default behavior. -- --- @since 1.15.0.0 +-- @since 1.16.0.0 data Config = Config { plan :: Plan -- ^ Extend or replace any of the configuration used to create a final @@ -518,6 +526,45 @@ ------------------------------------------------------------------------------- -- Caching ------------------------------------------------------------------------------- +{-| +Copy command used to create a data directory. If @initdb@ used to create the +data directory directly this is not needed. + +If 'destinationDirectory' is Nothing then the 'dataDirectoryString' +(which might be generated) is used. + +@since 1.16.0.0 +-} +data CopyDirectoryCommand = CopyDirectoryCommand + { sourceDirectory :: FilePath + , destinationDirectory :: Maybe FilePath + , useCopyOnWrite :: Bool + } deriving (Show, Eq, Ord) + +instance Pretty CopyDirectoryCommand where + pretty CopyDirectoryCommand {..} + = text "sourceDirectory:" + <> softline + <> indent 2 (text sourceDirectory) + <> hardline + <> text "destinationDirectory:" + <> softline + <> indent 2 (pretty destinationDirectory) + <> hardline + <> text "useCopyOnWrite:" + <+> (pretty useCopyOnWrite) + +completeCopyDirectory + :: FilePath + -> CopyDirectoryCommand + -> CompleteCopyDirectoryCommand +completeCopyDirectory theDataDirectory CopyDirectoryCommand {..} = + CompleteCopyDirectoryCommand + { copyDirectoryCommandSrc = sourceDirectory + , copyDirectoryCommandDst = fromMaybe theDataDirectory destinationDirectory + , copyDirectoryCommandCow = useCopyOnWrite + } + getInitDbVersion :: IO String getInitDbVersion = readProcessWithExitCode "initdb" ["--version"] "" >>= \case (ExitSuccess, outputString, _) -> do @@ -549,7 +596,6 @@ let theHash = makeArgumentHash cmdLine pure $ cacheFolder <> "/" <> version <> "/" <> theHash - splitDataDirectory :: CompleteProcessConfig -> (Maybe String, CompleteProcessConfig) splitDataDirectory old = let isDataDirectoryFlag xs = "-D" `isPrefixOf` xs || "--pgdata=" `isPrefixOf` xs @@ -602,7 +648,7 @@ pure $ pure $ addDataDirectory cachedDataDirectory clearedConfig pure plan - { completePlanCopy = pure $ CopyDirectoryCommand + { completePlanCopy = pure $ CompleteCopyDirectoryCommand { copyDirectoryCommandSrc = cachedDataDirectory , copyDirectoryCommandDst = theDataDirectory , copyDirectoryCommandCow = cow @@ -976,6 +1022,15 @@ (f dataDirectoryString) {-# INLINE dataDirectoryStringL #-} +-- | Lens for 'copyConfig'. +-- +-- @since 1.16.0.0 +copyConfigL :: Lens' Plan (Last (Maybe CopyDirectoryCommand)) +copyConfigL f (plan@Plan{..}) + = fmap (\x -> plan { copyConfig = x }) + (f copyConfig) +{-# INLINE copyConfigL #-} + -- | Lens for 'initDbConfig'. -- -- @since 1.12.0.0 @@ -1107,3 +1162,30 @@ = fmap (`CommandLineArgs` x_amNx) (f_amNv x_amNw) {-# INLINE keyBasedL #-} + +-- | Lens for 'sourceDirectory'. +-- +-- @since 1.16.0.0 +sourceDirectoryL :: Lens' CopyDirectoryCommand FilePath +sourceDirectoryL f (cmd@CopyDirectoryCommand{..}) + = fmap (\x -> cmd { sourceDirectory = x }) + (f sourceDirectory) +{-# INLINE sourceDirectoryL #-} + +-- | Lens for 'destinationDirectory'. +-- +-- @since 1.16.0.0 +destinationDirectoryL :: Lens' CopyDirectoryCommand (Maybe FilePath) +destinationDirectoryL f (cmd@CopyDirectoryCommand{..}) + = fmap (\x -> cmd { destinationDirectory = x }) + (f destinationDirectory) +{-# INLINE destinationDirectoryL #-} + +-- | Lens for 'useCopyOnWrite'. +-- +-- @since 1.16.0.0 +useCopyOnWriteL :: Lens' CopyDirectoryCommand Bool +useCopyOnWriteL f (cmd@CopyDirectoryCommand{..}) + = fmap (\x -> cmd { useCopyOnWrite = x }) + (f useCopyOnWrite) +{-# INLINE useCopyOnWriteL #-} 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 @@ -305,14 +305,14 @@ (res, stdOut, stdErr) <- executeProcessAndTee "initdb" config throwIfNotSuccess (InitDbFailed stdOut stdErr) res -data CopyDirectoryCommand = CopyDirectoryCommand +data CompleteCopyDirectoryCommand = CompleteCopyDirectoryCommand { copyDirectoryCommandSrc :: FilePath , copyDirectoryCommandDst :: FilePath , copyDirectoryCommandCow :: Bool } deriving (Show, Eq, Ord) -instance Pretty CopyDirectoryCommand where - pretty CopyDirectoryCommand {..} +instance Pretty CompleteCopyDirectoryCommand where + pretty CompleteCopyDirectoryCommand {..} = text "copyDirectoryCommandSrc:" <> softline <> indent 2 (text copyDirectoryCommandSrc) @@ -324,8 +324,8 @@ <> text "copyDirectoryCommandCow:" <+> (pretty copyDirectoryCommandCow) -executeCopyDirectoryCommand :: CopyDirectoryCommand -> IO () -executeCopyDirectoryCommand CopyDirectoryCommand {..} = do +executeCopyDirectoryCommand :: CompleteCopyDirectoryCommand -> IO () +executeCopyDirectoryCommand CompleteCopyDirectoryCommand {..} = do let #ifdef darwin_HOST_OS cpFlags = if copyDirectoryCommandCow then "cp -Rc " else "cp -R " @@ -347,7 +347,7 @@ data CompletePlan = CompletePlan { completePlanLogger :: Logger , completePlanInitDb :: Maybe CompleteProcessConfig - , completePlanCopy :: Maybe CopyDirectoryCommand + , completePlanCopy :: Maybe CompleteCopyDirectoryCommand , completePlanCreateDb :: Maybe CompleteProcessConfig , completePlanPostgres :: CompletePostgresPlan , completePlanConfig :: String 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.15.1.1 +version: 1.16.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