{-# OPTIONS_HADDOCK prune #-}
{-| This module provides types and functions for combining partial
    configs into a complete configs to ultimately make a 'Plan'.

    This module has two classes of types.

    Types like 'ProcessConfig' that could be used by any
    library that  needs to combine process options.

    Finally it has types and functions for creating 'Plan's that
    use temporary resources. This is used to create the default
    behavior of 'Database.Postgres.Temp.startConfig' and related
    functions.
|-}
module Database.Postgres.Temp.Internal.Config where

import Database.Postgres.Temp.Internal.Core

import           Control.Applicative.Lift
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad (join)
import           Crypto.Hash.SHA1 (hash)
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Cont
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Base64.URL as Base64
import           Data.Char
import qualified Data.Map.Strict as Map
import           Data.Map.Strict (Map)
import           Data.Maybe
import           Data.Monoid
import           Data.Monoid.Generic
import           Data.List
import qualified Database.PostgreSQL.Simple.Options as Client
import           GHC.Generics (Generic)
import           Network.Socket.Free (getFreePort)
import           System.Directory
import           System.Environment
import           System.Exit (ExitCode(..))
import           System.IO
import           System.IO.Error
import           System.IO.Temp (createTempDirectory)
import           System.IO.Unsafe (unsafePerformIO)
import           System.Process
import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>))

{-|

'Accum' is a monoid.

It's '<>' behavior is analogous to 1 and 0 with '*'. Think of 'DontCare'
as 1 and 'Zlich' as 0.

The behavior of 'Merge' is like 'Just's.

@since 1.17.0.0
-}
data Accum a = DontCare | Zlich | Merge a
  deriving stock (Show, Eq, Ord, Functor)

instance Applicative Accum where
  pure = Merge
  af <*> ax = case (af, ax) of
    (Merge f, Merge x) -> Merge $ f x

    (DontCare, _) -> DontCare
    (_, DontCare) -> DontCare

    (Zlich, _) -> Zlich
    (_, Zlich) -> Zlich

instance Semigroup a => Semigroup (Accum a) where
  x <> y = case (x, y) of
    (DontCare,         b) -> b
    (a       , DontCare ) -> a

    (Zlich   , _    ) -> Zlich
    (_       , Zlich) -> Zlich

    (Merge a, Merge b) -> Merge $ a <> b

getAccum :: Accum a -> Maybe a
getAccum = \case
  Merge a -> Just a
  _ -> Nothing

instance Monoid a => Monoid (Accum a) where
  mempty = DontCare

prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc
prettyMap theMap =
  let xs = Map.toList theMap
  in vsep $ map (uncurry prettyKeyPair) xs

-- | The environment variables can be declared to
--   inherit from the running process or they
--   can be specifically added.
--
--   @since 1.12.0.0
data EnvironmentVariables = EnvironmentVariables
  { inherit  :: Last Bool
  , specific :: Map String String
  }
  deriving stock (Generic, Show, Eq)

instance Semigroup EnvironmentVariables where
  x <> y = EnvironmentVariables
    { inherit  =
        inherit x <> inherit y
    , specific =
        specific y <> specific x
    }

instance Monoid EnvironmentVariables where
  mempty = EnvironmentVariables mempty mempty

instance Pretty EnvironmentVariables where
  pretty EnvironmentVariables {..}
    = text "inherit:"
        <+> pretty (getLast inherit)
    <> hardline
    <> text "specific:"
    <> softline
    <> indent 2 (prettyMap specific)

-- | Combine the current environment
--   (if indicated by 'inherit')
--   with 'specific'.
--
--   @since 1.12.0.0
completeEnvironmentVariables
  :: [(String, String)]
  -> EnvironmentVariables
  -> Either [String] [(String, String)]
completeEnvironmentVariables envs EnvironmentVariables {..} = case getLast inherit of
  Nothing -> Left ["Inherit not specified"]
  Just x -> Right $ (if x then envs else [])
    <> Map.toList specific

-- | A type to help combine command line Args.
--
--   @since 1.12.0.0
data CommandLineArgs = CommandLineArgs
  { keyBased   :: Map String (Maybe String)
  -- ^ Args of the form @-h foo@, @--host=foo@ and @--switch@.
  --   The key is `mappend`ed with value so the key should include
  --   the space or equals (as shown in the first two examples
  --   respectively).
  --   The 'Dual' monoid is used so the last key wins.
  , indexBased :: Map Int String
  -- ^ Args that appear at the end of the key based
  --   Args.
  --   The 'Dual' monoid is used so the last key wins.
  }
  deriving stock (Generic, Show, Eq)
  deriving Monoid via GenericMonoid CommandLineArgs

instance Semigroup CommandLineArgs where
  x <> y = CommandLineArgs
    { keyBased   =
        keyBased y <> keyBased x
    , indexBased =
        indexBased y <> indexBased x
    }

instance Pretty CommandLineArgs where
  pretty p@CommandLineArgs {..}
    = text "keyBased:"
    <> softline
    <> indent 2 (prettyMap keyBased)
    <> hardline
    <> text "indexBased:"
    <> softline
    <> indent 2 (prettyMap indexBased)
    <> hardline
    <> text "completed:" <+> text (unwords (completeCommandLineArgs p))

-- Take values as long as the index is the successor of the
-- last index.
takeWhileInSequence :: [(Int, a)] -> [a]
takeWhileInSequence ((0, x):xs) = x : go 0 xs where
  go _ [] = []
  go prev ((next, a):rest)
    | prev + 1 == next = a : go next rest
    | otherwise = []
takeWhileInSequence _ = []

-- | This convert the 'CommandLineArgs' to '[String]'.
--
--   @since 1.12.0.0
completeCommandLineArgs :: CommandLineArgs -> [String]
completeCommandLineArgs CommandLineArgs {..}
  =  map (\(name, mvalue) -> maybe name (name <>) mvalue)
       (Map.toList keyBased)
  <> takeWhileInSequence (Map.toList indexBased)

-- | Process configuration
--
--   @since 1.12.0.0
data ProcessConfig = ProcessConfig
  { environmentVariables :: EnvironmentVariables
  -- ^ A monoid for combine environment variables or replacing them.
  --   for the maps the 'Dual' monoid is used. So the last key wins.
  , commandLine :: CommandLineArgs
  -- ^ A monoid for combine command line Args or replacing them.
  , stdIn :: Last Handle
  -- ^ A monoid for configuring the standard input 'Handle'.
  , stdOut :: Last Handle
  -- ^ A monoid for configuring the standard output 'Handle'.
  , stdErr :: Last Handle
  -- ^ A monoid for configuring the standard error 'Handle'.
  }
  deriving stock (Generic, Eq, Show)
  deriving Semigroup via GenericSemigroup ProcessConfig
  deriving Monoid    via GenericMonoid ProcessConfig

instance Pretty ProcessConfig where
  pretty ProcessConfig {..}
    = text "environmentVariables:"
    <> softline
    <> indent 2 (pretty environmentVariables)
    <> hardline
    <> text "commandLine:"
    <> softline
    <> indent 2 (pretty environmentVariables)
    <> hardline
    <> text "stdIn:" <+>
        pretty (prettyHandle <$> getLast stdIn)
    <> hardline
    <> text "stdOut:" <+>
        pretty (prettyHandle <$> getLast stdOut)
    <> hardline
    <> text "stdErr:" <+>
        pretty (prettyHandle <$> getLast stdErr)


-- | The 'standardProcessConfig' sets the handles to 'stdin', 'stdout' and
--   'stderr' and inherits the environment variables from the calling
--   process.
--
--   @since 1.12.0.0
standardProcessConfig :: ProcessConfig
standardProcessConfig = mempty
  { environmentVariables = mempty
      { inherit = pure True
      }
  , stdIn  = pure stdin
  , stdOut = pure stdout
  , stdErr = pure stderr
  }

-- | A global reference to @\/dev\/null@ 'Handle'.
--
--   @since 1.12.0.0
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.
--
--   @since 1.12.0.0
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

-- A helper for creating an error if a 'Last' is not defined.
getOption :: String -> Last a -> Errors [String] a
getOption optionName = \case
    Last (Just x) -> pure x
    Last Nothing  -> failure ["Missing " ++ optionName ++ " option"]

-- | Turn a 'ProcessConfig' into a 'ProcessConfig'. Fails if
--   any values are missing.
--
--   @since 1.12.0.0
completeProcessConfig
  :: [(String, String)] -> ProcessConfig -> Either [String] CompleteProcessConfig
completeProcessConfig envs ProcessConfig {..} = runErrors $ do
  let completeProcessConfigCmdLine = completeCommandLineArgs commandLine
  completeProcessConfigEnvVars <- eitherToErrors $
    completeEnvironmentVariables envs environmentVariables
  completeProcessConfigStdIn  <-
    getOption "stdIn" stdIn
  completeProcessConfigStdOut <-
    getOption "stdOut" stdOut
  completeProcessConfigStdErr <-
    getOption "stdErr" stdErr

  pure CompleteProcessConfig {..}

-- | A type to track whether a file is temporary and needs to be cleaned up.
--
--   @since 1.12.0.0
data CompleteDirectoryType = CPermanent FilePath | CTemporary FilePath
  deriving stock (Show, Eq, Ord, Generic)
  deriving anyclass (NFData)

-- | Get the file path of a 'CompleteDirectoryType', regardless if it is a
-- 'CPermanent' or 'CTemporary' type.
--
--   @since 1.12.0.0
toFilePath :: CompleteDirectoryType -> FilePath
toFilePath = \case
  CPermanent x -> x
  CTemporary x -> x

instance Pretty CompleteDirectoryType where
  pretty = \case
    CPermanent x -> text "CPermanent" <+> pretty x
    CTemporary x -> text "CTemporary" <+> pretty x

makePermanent :: CompleteDirectoryType -> CompleteDirectoryType
makePermanent = \case
  CTemporary x -> CPermanent x
  x -> x

-- | Used to specify a 'Temporary' folder that is automatically
--   cleaned up or a 'Permanent' folder which is not
--   automatically cleaned up.
--
--   @since 1.12.0.0
data DirectoryType
  = Permanent FilePath
  -- ^ A permanent file that should not be generated.
  | Temporary
  -- ^ A temporary file that needs to generated.
  deriving(Show, Eq, Ord)

instance Pretty DirectoryType where
  pretty = \case
    Permanent x -> text "Permanent" <+> pretty x
    Temporary   -> text "Temporary"

-- | Takes the last 'Permanent' value.
instance Semigroup DirectoryType where
  x <> y = case (x, y) of
    (a, Temporary     ) -> a
    (_, a@Permanent {}) -> a

-- | 'Temporary' as 'mempty'
instance Monoid DirectoryType where
  mempty = Temporary

-- | Either create a'CTemporary' directory or do nothing to a 'CPermanent'
--   one.
--
--   @since 1.12.0.0
setupDirectoryType
  :: String
  -- ^ Temporary directory configuration
  -> String
  -- ^ Directory pattern
  -> DirectoryType
  -> IO CompleteDirectoryType
setupDirectoryType tempDir pat = \case
  Temporary -> CTemporary <$> createTempDirectory tempDir pat
  Permanent x  -> CPermanent <$> case x of
    '~':rest -> do
      homeDir <- getHomeDirectory
      pure $ homeDir <> "/" <> rest
    xs -> pure xs

-- Remove a temporary directory and ignore errors
-- about it not being there.
rmDirIgnoreErrors :: FilePath -> IO ()
rmDirIgnoreErrors mainDir = do
  let ignoreDirIsMissing e
        | isDoesNotExistError e = return ()
        | otherwise = throwIO e

  -- Files are continued to be written after the delete starts. This
  -- seems to fix it. #122
  -- TODO come up with a better way to deal with this. Probably
  -- need to lock the directories recursively before deleting.
  handle ignoreDirIsMissing $
    try (removePathForcibly mainDir) >>= \case
    Left (_ :: IOError) -> try (removePathForcibly mainDir) >>= \case
      Left (_ :: IOError) -> removePathForcibly mainDir
      Right _ -> pure ()
    Right _ -> pure ()

-- | Either remove a 'CTemporary' directory or do nothing to a 'CPermanent'
-- one.
cleanupDirectoryType :: CompleteDirectoryType -> IO ()
cleanupDirectoryType = \case
  CPermanent _ -> pure ()
  CTemporary filePath -> rmDirIgnoreErrors filePath

-- | Turn a 'Config' into a 'CompletePostgresPlan'. Fails if any
--   values are missing.
completePostgresPlan :: [(String, String)] -> Config -> Either [String] CompletePostgresPlan
completePostgresPlan envs Config {..} = runErrors $ do
  let completePostgresPlanClientOptions = connectionOptions
  completePostgresPlanProcessConfig <-
    eitherToErrors $ addErrorContext "postgresConfig: " $
      completeProcessConfig envs postgresConfig

  pure CompletePostgresPlan {..}

flattenConfig :: [(String, String)] -> String
flattenConfig = unlines . map (\(x, y) -> x <> "=" <> y) .
  Map.toList . Map.fromList

-- | Turn a 'Config' into a 'Plan'. Fails if any values are missing.
completePlan :: [(String, String)] -> String -> Config -> Either [String] Plan
completePlan envs dataDirectoryString config@Config {..} = do
  (   completePlanLogger
    , completePlanInitDb
    , completePlanCreateDb
    , completePlanPostgres
    , completePlanDataDirectory
    , completePlanConnectionTimeout
    ) <- runErrors
         $ (,,,,,)
        <$> getOption "logger" logger
        <*> eitherToErrors (addErrorContext "initDbConfig: " $
              traverse (completeProcessConfig envs) $ getAccum initDbConfig)
        <*> eitherToErrors (addErrorContext "createDbConfig: " $
              traverse (completeProcessConfig envs) $ getAccum createDbConfig)
        <*> eitherToErrors (addErrorContext "postgresPlan: "
              (completePostgresPlan envs config))
        <*> pure dataDirectoryString
        <*> getOption "connectionTimeout" connectionTimeout

  let completePlanConfig = flattenConfig postgresConfigFile
      completePlanCopy = completeCopyDirectory completePlanDataDirectory <$>
        join (getLast copyConfig)

  pure Plan {..}

-- Returns 'True' if the 'Config' has a
-- 'Just' 'initDbConfig'.
hasInitDb :: Config -> Bool
hasInitDb Config {..} = isJust $ getAccum initDbConfig

-- Returns 'True' if the 'Config' has a
-- 'Just' 'createDbConfig'.
hasCreateDb :: Config -> Bool
hasCreateDb Config {..} = isJust $ getAccum createDbConfig

-- | The high level options for overriding default behavior.
--
--   @since 1.22.0.0
data Config = Config
  { logger :: Last Logger
  -- ^ Internal 'Event' logger.
  , initDbConfig :: Accum ProcessConfig
  -- ^ Monoid for accumulating @initdb@ configuration.
  , copyConfig :: Last (Maybe CopyDirectoryCommand)
  -- ^ An optional data directory copy command.
  , createDbConfig :: Accum ProcessConfig
  -- ^ Monoid for accumulating @createdb@ configuration.
  , postgresConfig :: ProcessConfig
  -- ^ The @postgres@ process configuration.
  , connectionOptions :: Client.Options
  -- ^ The additional client connection options.
  , postgresConfigFile :: [(String, String)]
  -- ^ The @postgresql.conf@ configuration file.
  , connectionTimeout :: Last Int
  -- ^ The amount of microseconds to attempt to connect
  --   to @postgres@ before throwing 'ConnectionTimedOut'
  , 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@.
  , port    :: Last (Maybe Int)
  -- ^ A monoid for using an existing port (via 'Just' @PORT_NUMBER@) or
  -- requesting a free port (via a 'Nothing').
  , temporaryDirectory :: Last FilePath
  -- ^ The directory used to create other temporary directories. Defaults
  --   to @/tmp@.
  , initDbCache :: Last (Maybe (Bool, FilePath))
  }
  deriving stock (Generic)
  deriving Semigroup via GenericSemigroup Config
  deriving Monoid    via GenericMonoid Config

instance Pretty Config where
  pretty Config {..}
    =  text "socketDirectory:"
    <> softline
    <> pretty socketDirectory
    <> hardline
    <> text "dataDirectory:"
    <> softline
    <> pretty dataDirectory
    <> hardline
    <> text "port:" <+> pretty (getLast port)
    <> hardline
    <> text "temporaryDirectory:"
    <> softline
    <> pretty (getLast temporaryDirectory)
    <> hardline
    <> text "initDbCache:" <+> pretty (getLast initDbCache)
    <> hardline
    <> text "initDbConfig:"
    <> softline
    <> indent 2 (pretty $ getAccum initDbConfig)
    <> hardline
    <> text "initDbConfig:"
    <> softline
    <> indent 2 (pretty $ getAccum createDbConfig)
    <> text "copyConfig:"
    <> softline
    <> indent 2 (pretty (getLast copyConfig))
    <> hardline
    <> text "postgresConfig:"
    <> softline
    <> indent 2 (pretty postgresConfig)
    <> hardline
    <> text "connectionOptions:"
    <> softline
    <> indent 2 (prettyOptions connectionOptions)
    <> hardline
    <> text "postgresConfigFile:"
    <> softline
    <> indent 2 (vsep $ map (\(x, y) -> text x <> "=" <> text y) postgresConfigFile)
    <> hardline
    <> text "connectionTimeout:" <+> pretty (getLast connectionTimeout)

socketDirectoryToConfig :: FilePath -> [(String, String)]
socketDirectoryToConfig dir =
    [ ("listen_addresses", "'127.0.0.1,::1'")
    , ("unix_socket_directories", "'" <> dir <> "'")
    ]

-------------------------------------------------------------------------------
-- 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 'dataDirectory'
(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 :: String
getInitDbVersion = unsafePerformIO $ readProcessWithExitCode "initdb" ["--version"] "" >>= \case
  (ExitSuccess, outputString, _) -> do
    let
      theLastPart = last $ words outputString
      versionPart = takeWhile (\x -> isDigit x || x == '.' || x == '-') theLastPart
      humanReadable = if last versionPart == '.'
        then init versionPart
        else versionPart
    pure $ humanReadable <> take 8 (makeArgumentHash outputString)

  (startErrorExitCode, startErrorStdOut, startErrorStdErr) ->
    throwIO InitDbFailed {..}
{-# NOINLINE getInitDbVersion #-}

makeCommandLine :: String -> CompleteProcessConfig -> String
makeCommandLine command CompleteProcessConfig {..} =
  let envs = unwords $ map (\(x, y) -> x <> "=" <> y) completeProcessConfigEnvVars
      args = unwords completeProcessConfigCmdLine
  in envs <> " " <> command <> args

makeInitDbCommandLine :: CompleteProcessConfig -> String
makeInitDbCommandLine = makeCommandLine "initdb"

makeArgumentHash :: String -> String
makeArgumentHash = BSC.unpack . Base64.encode . hash . BSC.pack

makeCachePath :: FilePath -> String -> String
makeCachePath cacheFolder cmdLine =
  let
    version = getInitDbVersion
    theHash = makeArgumentHash cmdLine
  in cacheFolder <> "/" <> version <> "/" <> theHash

splitDataDirectory :: CompleteProcessConfig -> (Maybe String, CompleteProcessConfig)
splitDataDirectory old =
  let isDataDirectoryFlag xs = "-D" `isPrefixOf` xs || "--pgdata=" `isPrefixOf` xs
      (dataDirectoryArgs, otherArgs) =
        partition isDataDirectoryFlag $ completeProcessConfigCmdLine old

      firstDataDirectoryArg = flip fmap (listToMaybe dataDirectoryArgs) $ \case
        '-':'D':' ':theDir -> theDir
        '-':'D':theDir -> theDir
        '-':'-':'p':'g':'d':'a':'t':'a':'=':theDir -> theDir
        _ -> error "splitDataDirectory not possible"

      filteredEnvs = filter (("PGDATA" /=) . fst) $
        completeProcessConfigEnvVars old

      clearedConfig = old
        { completeProcessConfigCmdLine = otherArgs
        , completeProcessConfigEnvVars = filteredEnvs
        }

  in (firstDataDirectoryArg, clearedConfig)

addDataDirectory :: String -> CompleteProcessConfig -> CompleteProcessConfig
addDataDirectory theDataDirectory x = x
  { completeProcessConfigCmdLine =
      ("--pgdata=" <> theDataDirectory) : completeProcessConfigCmdLine x
  }

cachePlan :: Plan -> Bool -> FilePath -> IO Plan
cachePlan plan@Plan {..} cow cacheDirectory = case completePlanInitDb of
  Nothing -> pure plan
  Just theConfig -> do
    let (mtheDataDirectory, clearedConfig) = splitDataDirectory theConfig
    theDataDirectory <- maybe
      (throwIO $ FailedToFindDataDirectory (show $ pretty clearedConfig))
      pure
      mtheDataDirectory

    let
      theCommandLine = makeInitDbCommandLine clearedConfig
      cachePath = makeCachePath cacheDirectory theCommandLine
      cachedDataDirectory = cachePath <> "/data"

    theInitDbPlan <- doesDirectoryExist cachePath >>= \case
      True -> pure Nothing
      False -> do
        createDirectoryIfMissing True cachePath
        writeFile (cachePath <> "/commandLine.log") theCommandLine
        pure $ pure $ addDataDirectory cachedDataDirectory clearedConfig

    pure plan
      { completePlanCopy = pure $ CompleteCopyDirectoryCommand
        { copyDirectoryCommandSrc = cachedDataDirectory
        , copyDirectoryCommandDst = theDataDirectory
        , copyDirectoryCommandCow = cow
        }
      , completePlanInitDb = theInitDbPlan
      }

-- | Create a 'Config' 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
--   'Database.Postgres.Temp.startConfig'.
toPlan
  :: Bool
  -- ^ Make @initdb@ options.
  -> Bool
  -- ^ Make @createdb@ options.
  -> Int
  -- ^ The port.
  -> FilePath
  -- ^ Socket directory.
  -> FilePath
  -- ^ The @postgres@ data directory.
  -> Config
toPlan _makeInitDb makeCreateDb port socketDirectory dataDirectoryString = mempty
  { postgresConfigFile = socketDirectoryToConfig socketDirectory
  , connectionTimeout = pure (60 * 1000000) -- 1 minute
  , logger = pure $ const $ pure ()
  , postgresConfig = silentProcessConfig
    { commandLine = mempty
        { keyBased = Map.fromList
            [ ("-p", Just $ show port)
            , ("-D", Just dataDirectoryString)
            ]
        }
    }
  , connectionOptions = mempty
    { Client.host   = pure socketDirectory
    , Client.port   = pure port
    , Client.dbname = pure "postgres"
    }
  , createDbConfig = if makeCreateDb
      then pure silentProcessConfig
        { commandLine = mempty
            { keyBased = Map.fromList
                [ ("-h", Just socketDirectory)
                , ("-p ", Just $ show port)
                ]
            }
        }
      else mempty

  , initDbConfig = pure silentProcessConfig
        { commandLine = mempty
            { keyBased = Map.fromList
                [("--pgdata=", Just dataDirectoryString)]
            }
        }
  , copyConfig = pure Nothing
  }

-- | Create all the temporary resources from a 'Config'. This also combines the
-- 'Config' from 'toPlan' with the @extra@ 'Config' passed in.
setupConfig
  :: Config
  -- ^ @extra@ 'Config' to 'mappend' after the @generated@ 'Config'.
  -> IO Resources
setupConfig config@Config {..} = evalContT $ do
  envs <- lift getEnvironment
  thePort <- lift $ maybe getFreePort pure $ join $ getLast port
  let resourcesTemporaryDir = fromMaybe "/tmp" $ getLast temporaryDirectory
      resourcesInitDbCache = join $ getLast initDbCache
  resourcesSocketDirectory <- ContT $ bracketOnError
    (setupDirectoryType resourcesTemporaryDir "tmp-postgres-socket" socketDirectory) cleanupDirectoryType
  resourcesDataDir <- ContT $ bracketOnError
    (setupDirectoryType resourcesTemporaryDir "tmp-postgres-data" dataDirectory) cleanupDirectoryType
  let hostAndDir = toPlan
        (hasInitDb config)
        (hasCreateDb config)
        thePort
        (toFilePath resourcesSocketDirectory)
        (toFilePath resourcesDataDir)
      finalPlan = hostAndDir <> config
  uncachedPlan <- lift $
    either (throwIO . PlanFailed (show $ pretty finalPlan)) pure $
      completePlan envs (toFilePath resourcesDataDir) finalPlan
  resourcesPlan <- lift $ maybe (pure uncachedPlan) (uncurry $ cachePlan uncachedPlan) resourcesInitDbCache
  pure Resources {..}

-- | Free the temporary resources created by 'setupConfig'.
cleanupConfig :: Resources -> IO ()
cleanupConfig Resources {..} = do
  cleanupDirectoryType resourcesSocketDirectory
  cleanupDirectoryType resourcesDataDir

-- | Display a 'Config'.
--
--   @since 1.12.0.0
prettyPrintConfig :: Config -> String
prettyPrintConfig = show . pretty

-- | 'Resources' holds a description of the temporary folders (if there are any)
--   and includes the final 'Plan' that can be used with 'startPlan'.
--   See 'setupConfig' for an example of how to create a 'Resources'.
--
--   @since 1.12.0.0
data Resources = Resources
  { resourcesPlan    :: Plan
  -- ^ Final 'Plan'. See 'startPlan' for information on 'Plan's.
  , 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
  -- ^ The directory where other temporary directories are created.
  --   Usually @/tmp.
  , resourcesInitDbCache :: Maybe (Bool, FilePath)
  }

instance Pretty Resources where
  pretty Resources {..}
    =   text "resourcePlan:"
    <>  softline
    <>  indent 2 (pretty resourcesPlan)
    <>  hardline
    <>  text "resourcesSocket:"
    <+> pretty resourcesSocketDirectory
    <>  hardline
    <>  text "resourcesDataDir:"
    <+> pretty resourcesDataDir

-- | Make the 'resourcesDataDir' 'CPermanent' so it will not
--   get cleaned up.
--
--   @since 1.12.0.0
makeResourcesDataDirPermanent :: Resources -> Resources
makeResourcesDataDirPermanent r = r
  { resourcesDataDir = makePermanent $ resourcesDataDir r
  }
-------------------------------------------------------------------------------
-- Config Generation
-------------------------------------------------------------------------------
-- | Attempt to create a config from a 'Client.Options'. This is useful if
--   want to create a database owned by a specific user you will also log in as
--   among other use cases. It is possible some 'Client.Options' are not
--   supported so don't hesitate to open an issue on github if you find one.
optionsToConfig :: Client.Options -> Config
optionsToConfig opts@Client.Options {..}
  =  ( mempty
       { port = maybe (Last Nothing) (pure . pure) $ getLast port
       , socketDirectory = maybe mempty hostToSocketClass $ getLast host
       }
     ) <> optionsToPlan opts
-- Convert the 'Client.Options' to a 'Config' that can
-- be connected to with the 'Client.Options'.
optionsToPlan :: Client.Options -> Config
optionsToPlan opts@Client.Options {..}
  =  maybe mempty (dbnameToPlan (getLast user) (getLast password)) (getLast dbname)
  <> maybe mempty userToPlan (getLast user)
  <> maybe mempty passwordToPlan (getLast password)
  <> clientOptionsToPlan opts

-- Wrap the 'Client.Options' in an appropiate
-- 'PostgresPlan'.
clientOptionsToPlan :: Client.Options -> Config
clientOptionsToPlan opts = mempty
  { connectionOptions = opts
  }

-- Create a 'Config' given a user.
userToPlan :: String -> Config
userToPlan user = mempty
  { initDbConfig = pure mempty
    { commandLine = mempty
        { keyBased = Map.singleton "--username=" $ Just user
        }
    }
  }

-- Adds a @createdb@ ProcessPlan with the argument
-- as the database name.
-- It does nothing if the db names are "template1" or
-- "postgres"
dbnameToPlan :: Maybe String -> Maybe String -> String -> Config
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
        }
      }
    }

-- Adds the 'PGPASSWORD' to both @initdb@ and @createdb@
passwordToPlan :: String -> Config
passwordToPlan password = mempty
  { initDbConfig = 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 -> DirectoryType
hostToSocketClass hostOrSocketPath = case hostOrSocketPath of
  '/' : _ -> Permanent hostOrSocketPath
  _ -> Temporary