packages feed

tmp-postgres 1.4.0.0 → 1.5.0.0

raw patch · 5 files changed

+89/−81 lines, 5 files

Files

src/Database/Postgres/Temp.hs view
@@ -60,6 +60,8 @@   , defaultConfig   , defaultPostgresConf   , standardProcessConfig+  -- ** Custom Config builder helpers+  , optionsToDefaultConfig   -- * Starting and Stopping postgres without removing the temporary directory   , restart   , stopPostgres@@ -78,6 +80,10 @@   -- ** Listening socket configuration   , SocketClass (..)   , PartialSocketClass (..)+  -- ** An environment variables monoid+  , PartialEnvVars (..)+  -- ** An command line monoid+  , PartialCommandLineArgs (..)   -- ** Process configuration   , PartialProcessConfig (..)   , ProcessConfig (..)@@ -89,8 +95,6 @@   -- ** Database plans. This is used to call @initdb@, @postgres@ and @createdb@   , PartialPlan (..)   , Plan (..)-  -- ** Custom Config builder helpers-  , optionsToDefaultConfig   ) where import Database.Postgres.Temp.Internal import Database.Postgres.Temp.Internal.Core
src/Database/Postgres/Temp/Internal.hs view
@@ -88,7 +88,7 @@   { configPlan = mempty     { partialPlanLogger = pure mempty     , partialPlanConfig = defaultPostgresConfig-    , partialPlanCreateDb = Accum Nothing+    , partialPlanCreateDb = Nothing     , partialPlanInitDb = pure standardProcessConfig       { partialProcessConfigCmdLine = mempty           { partialCommandLineArgsKeyBased = Map.singleton "--no-sync" Nothing@@ -211,21 +211,9 @@       startingConfig =         if partialPlanCreateDb (configPlan generated) == mempty           then defaultConfig-          else setCreateDb defaultConfig $ pure standardProcessConfig+          else defaultConfig <> mempty+            { configPlan = mempty+              { partialPlanCreateDb = pure standardProcessConfig+              }+            }   in startingConfig <> generated---- | Set a 'Config's 'partialPlanCreateDb' value.-setCreateDb :: Config -> Accum PartialProcessConfig -> Config-setCreateDb config@Config {..} new = config-  { configPlan = configPlan-      { partialPlanCreateDb = new-      }-  }---- | Set a 'Config's 'partialPlanInitDb' value.-setInitDb :: Config -> Accum PartialProcessConfig -> Config-setInitDb config@Config {..} new = config-  { configPlan = configPlan-      { partialPlanInitDb = new-      }-  }
src/Database/Postgres/Temp/Internal/Partial.hs view
@@ -1,8 +1,7 @@ {-| This module provides types and functions for combining partial     configs into a complete configs to ultimately make a 'Plan'. -    This module has three classes of types. Types like 'Accum' that-    are generic and could live in a module like "base".+    This module has two classes of types.      Types like 'PartialProcessConfig' that could be used by any     library that  needs to combine process options.@@ -34,20 +33,6 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map --- | Another 'Maybe' 'Monoid' newtype. This one combines 'Just's---   monoidially, with @Just mempty@ as @mempty@ and 'Nothing'---   annihilates.-newtype Accum a = Accum { getAccum :: Maybe a }-  deriving (Show, Eq, Ord, Functor, Applicative)--instance Semigroup a => Semigroup (Accum a) where-  Accum x <> Accum y = Accum $ case (x, y) of-    (Just a, Just b) -> Just $ a <> b-    _ -> Nothing--instance Monoid a => Monoid (Accum a) where-  mempty = Accum $ Just $ mempty- -- | The environment variables can be declared to --   inherit from the running process or they --   can be specifically added.@@ -325,8 +310,8 @@ --   when creating a plan. data PartialPlan = PartialPlan   { partialPlanLogger        :: Last Logger-  , partialPlanInitDb        :: Accum PartialProcessConfig-  , partialPlanCreateDb      :: Accum PartialProcessConfig+  , partialPlanInitDb        :: Maybe PartialProcessConfig+  , partialPlanCreateDb      :: Maybe PartialProcessConfig   , partialPlanPostgres      :: PartialPostgresPlan   , partialPlanConfig        :: [String]   , partialPlanDataDirectory :: Last String@@ -340,9 +325,9 @@ completePlan envs PartialPlan {..} = validationToEither $ do   planLogger   <- getOption "partialPlanLogger" partialPlanLogger   planInitDb   <- eitherToValidation $ addErrorContext "partialPlanInitDb: " $-    traverse (completeProcessConfig envs) (getAccum partialPlanInitDb)+    traverse (completeProcessConfig envs) partialPlanInitDb   planCreateDb <- eitherToValidation $ addErrorContext "partialPlanCreateDb: " $-    traverse (completeProcessConfig envs) (getAccum partialPlanCreateDb)+    traverse (completeProcessConfig envs) partialPlanCreateDb   planPostgres <- eitherToValidation $ addErrorContext "partialPlanPostgres: " $     completePostgresPlan envs partialPlanPostgres   let planConfig = unlines partialPlanConfig@@ -351,6 +336,16 @@    pure Plan {..} +-- | Returns 'True' if the 'PartialPlan' has a+--   'Just' 'partialPlanInitDb'+hasInitDb :: PartialPlan -> Bool+hasInitDb PartialPlan {..} = isJust partialPlanInitDb++-- | Returns 'True' if the 'PartialPlan' has a+--   'Just' 'partialPlanCreateDb'+hasCreateDb :: PartialPlan -> Bool+hasCreateDb PartialPlan {..} = isJust partialPlanCreateDb+ -- | 'Resources' holds a description of the temporary folders (if there are any) --   and includes the final 'Plan' that can be used with 'initPlan'. --   See 'initConfig' for an example of how to create a 'Resources'.@@ -385,14 +380,18 @@ -- | Create a 'PartialPlan' that sets the command line options of all processes --   (@initdb@, @postgres@ and @createdb@) using a toPlan-  :: Int+  :: Bool+  -- ^ Make @initdb@ options+  -> Bool+  -- ^ Make @createdb@ options+  -> Int   -- ^ port   -> SocketClass   -- ^ Whether to listen on a IP address or UNIX domain socket   -> FilePath   -- ^ The @postgres@ data directory   -> PartialPlan-toPlan port socketClass dataDirectory = mempty+toPlan makeInitDb makeCreateDb port socketClass dataDirectory = mempty   { partialPlanConfig = socketClassToConfig socketClass   , partialPlanDataDirectory = pure dataDirectory   , partialPlanPostgres = mempty@@ -410,20 +409,24 @@           , Client.dbname = pure "postgres"           }       }-  , partialPlanCreateDb = pure $ mempty-      { partialProcessConfigCmdLine = mempty-          { partialCommandLineArgsKeyBased = Map.fromList $-              socketClassToHostFlag socketClass <>-              [("-p ", Just $ show port)]-          }-      }-  , partialPlanInitDb = pure $ mempty-      { partialProcessConfigCmdLine = mempty-          { partialCommandLineArgsKeyBased = Map.fromList $-              [("--pgdata=", Just dataDirectory)]-          }+  , partialPlanCreateDb = if makeCreateDb+      then pure $ mempty+        { partialProcessConfigCmdLine = mempty+            { partialCommandLineArgsKeyBased = Map.fromList $+                socketClassToHostFlag socketClass <>+                [("-p ", Just $ show port)]+            }+        }+      else Nothing+  , partialPlanInitDb = if makeInitDb+      then pure $ mempty+        { partialProcessConfigCmdLine = mempty+            { partialCommandLineArgsKeyBased = Map.fromList $+                [("--pgdata=", Just dataDirectory)]+            } -      }+        }+      else Nothing   }  @@ -440,10 +443,15 @@     (initPartialSocketClass configSocket) shutdownSocketConfig   resourcesDataDir <- ContT $ bracketOnError     (initDirectoryType "tmp-postgres-data" configDataDir) shutdownDirectoryType-  let hostAndDirPartial = toPlan port resourcesSocket $-        toFilePath resourcesDataDir+  let hostAndDirPartial = toPlan+          (hasInitDb configPlan)+          (hasCreateDb configPlan)+          port+          resourcesSocket+          (toFilePath resourcesDataDir)+      finalPlan = hostAndDirPartial <> configPlan   resourcesPlan <- lift $ either (throwIO . CompletePlanFailed) pure $-    completePlan envs $ hostAndDirPartial <> configPlan+    completePlan envs finalPlan   pure Resources {..}  -- | Free the temporary resources created by 'initConfig'
test/Spec.hs view
@@ -29,6 +29,13 @@  -- Cleanup +fromCreateDb :: Maybe PartialProcessConfig -> Config+fromCreateDb createDb = mempty+  { configPlan = mempty+      { partialPlanCreateDb = createDb+      }+  }+ newtype Runner =  Runner (forall a. (DB -> IO a) -> IO a)  withRunner :: (DB -> IO ()) -> Runner -> IO ()@@ -83,24 +90,24 @@                       , partialEnvVarsInherit = pure True                       }                   }+              , partialPlanCreateDb = pure standardProcessConfig+                { partialProcessConfigCmdLine = mempty+                  { partialCommandLineArgsKeyBased =+                      Map.singleton "--username=" $ Just "user-name"+                  , partialCommandLineArgsIndexBased =+                      Map.singleton 0 expectedDbName+                  }+                , partialProcessConfigEnvVars =+                    mempty+                      { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password"+                      , partialEnvVarsInherit = pure True+                      }+                }               , partialPlanConfig = [extraConfig]               }           }     -- hmm maybe I should provide lenses-    let createDb = pure standardProcessConfig-          { partialProcessConfigCmdLine = mempty-            { partialCommandLineArgsKeyBased =-                Map.singleton "--username=" $ Just "user-name"-            , partialCommandLineArgsIndexBased =-                Map.singleton 0 expectedDbName-            }-          , partialProcessConfigEnvVars =-              mempty-                { partialEnvVarsSpecific = Map.singleton "PGPASSWORD" "password"-                , partialEnvVarsInherit = pure True-                }-          }-        combinedResources = setCreateDb defaultConfig createDb <> customPlan+    let combinedResources = defaultConfig <> customPlan      action combinedResources $ \db@DB {..} -> do       bracket (PG.connectPostgreSQL $ toConnectionString db) PG.close $ \conn -> do@@ -268,19 +275,20 @@           [PG.Only actualDuration] <- PG.query_ conn "SHOW log_min_duration_statement"           actualDuration `shouldBe` expectedDuration -    let invalidCreateDbPlan = setCreateDb defaultConfig $-          pure $ standardProcessConfig-            { partialProcessConfigCmdLine = mempty-              { partialCommandLineArgsIndexBased =-                  Map.singleton 0 "template1"+    let invalidCreateDbPlan = defaultConfig <> fromCreateDb+          ( pure $ standardProcessConfig+              { partialProcessConfigCmdLine = mempty+                { partialCommandLineArgsIndexBased =+                    Map.singleton 0 "template1"+                }               }-            }+          )     before (pure $ Runner $ \f -> bracket (either throwIO pure =<< startConfig invalidCreateDbPlan) stop f) $       createDbThrowsIfTheDbExists      let noCreateTemplate1 = mempty           { configPlan = mempty-              { partialPlanCreateDb = Accum Nothing+              { partialPlanCreateDb = Nothing               , partialPlanPostgres = mempty                   { partialPostgresPlanClientConfig = mempty                     { Client.dbname = pure "template1"@@ -323,7 +331,7 @@         let nonEmptyFolderPlan = defaultConfig               { configDataDir = PPermanent dirPath               , configPlan = (configPlan defaultConfig)-                  { partialPlanInitDb = Accum Nothing+                  { partialPlanInitDb = Nothing                   }               }         bracket (either throwIO pure =<< startConfig nonEmptyFolderPlan) stop $ \db -> do
tmp-postgres.cabal view
@@ -1,5 +1,5 @@ name:                tmp-postgres-version:             1.4.0.0+version:             1.5.0.0 synopsis: Start and stop a temporary postgres description:  @tmp-postgres@ provides functions creating a temporary @postgres@ instance.