{-# OPTIONS_HADDOCK prune #-}
module Database.Postgres.Temp.Internal.Partial where
import Database.Postgres.Temp.Internal.Core
import qualified Database.PostgreSQL.Simple.Options as Client
import GHC.Generics (Generic)
import Data.Monoid.Generic
import Data.Monoid
import Data.Typeable
import System.IO
import System.Environment
import Data.Maybe
import Control.Exception
import System.IO.Temp (createTempDirectory)
import Network.Socket.Free (getFreePort)
import Control.Monad (join)
import System.Directory
import Data.Either.Validation
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Class
import System.IO.Error
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
prettyMap :: (Pretty a, Pretty b) => Map a b -> Doc
prettyMap theMap =
let xs = Map.toList theMap
in vsep $ map (uncurry prettyKeyPair) xs
data PartialEnvVars = PartialEnvVars
{ partialEnvVarsInherit :: Last Bool
, partialEnvVarsSpecific :: Map String String
}
deriving stock (Generic, Show, Eq)
instance Semigroup PartialEnvVars where
x <> y = PartialEnvVars
{ partialEnvVarsInherit =
partialEnvVarsInherit x <> partialEnvVarsInherit y
, partialEnvVarsSpecific =
partialEnvVarsSpecific y <> partialEnvVarsSpecific x
}
instance Monoid PartialEnvVars where
mempty = PartialEnvVars mempty mempty
instance Pretty PartialEnvVars where
pretty PartialEnvVars {..}
= text "partialEnvVarsInherit:"
<+> pretty (getLast partialEnvVarsInherit)
<> hardline
<> text "partialEnvVarsSpecific:"
<> softline
<> indent 2 (prettyMap partialEnvVarsSpecific)
completePartialEnvVars :: [(String, String)] -> PartialEnvVars -> Either [String] [(String, String)]
completePartialEnvVars envs PartialEnvVars {..} = case getLast partialEnvVarsInherit of
Nothing -> Left ["Inherit not specified"]
Just x -> Right $ (if x then envs else [])
<> Map.toList partialEnvVarsSpecific
data PartialCommandLineArgs = PartialCommandLineArgs
{ partialCommandLineArgsKeyBased :: Map String (Maybe String)
, partialCommandLineArgsIndexBased :: Map Int String
}
deriving stock (Generic, Show, Eq)
deriving Monoid via GenericMonoid PartialCommandLineArgs
instance Semigroup PartialCommandLineArgs where
x <> y = PartialCommandLineArgs
{ partialCommandLineArgsKeyBased =
partialCommandLineArgsKeyBased y <> partialCommandLineArgsKeyBased x
, partialCommandLineArgsIndexBased =
partialCommandLineArgsIndexBased y <> partialCommandLineArgsIndexBased x
}
instance Pretty PartialCommandLineArgs where
pretty p@PartialCommandLineArgs {..}
= text "partialCommandLineArgsKeyBased:"
<> softline
<> indent 2 (prettyMap partialCommandLineArgsKeyBased)
<> hardline
<> text "partialCommandLineArgsIndexBased:"
<> softline
<> indent 2 (prettyMap partialCommandLineArgsIndexBased)
<> hardline
<> text "completed:" <+> text (unwords (completeCommandLineArgs p))
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 _ = []
completeCommandLineArgs :: PartialCommandLineArgs -> [String]
completeCommandLineArgs PartialCommandLineArgs {..}
= map (\(name, mvalue) -> maybe name (name <>) mvalue)
(Map.toList partialCommandLineArgsKeyBased)
<> takeWhileInSequence (Map.toList partialCommandLineArgsIndexBased)
data PartialProcessConfig = PartialProcessConfig
{ partialProcessConfigEnvVars :: PartialEnvVars
, partialProcessConfigCmdLine :: PartialCommandLineArgs
, partialProcessConfigStdIn :: Last Handle
, partialProcessConfigStdOut :: Last Handle
, partialProcessConfigStdErr :: Last Handle
}
deriving stock (Generic, Eq, Show)
deriving Semigroup via GenericSemigroup PartialProcessConfig
deriving Monoid via GenericMonoid PartialProcessConfig
prettyHandle :: Handle -> Doc
prettyHandle _ = text "[HANDLE]"
instance Pretty PartialProcessConfig where
pretty PartialProcessConfig {..}
= text "partialProcessConfigEnvVars:"
<> softline
<> indent 2 (pretty partialProcessConfigEnvVars)
<> hardline
<> text "partialProcessConfigCmdLine:"
<> softline
<> indent 2 (pretty partialProcessConfigEnvVars)
<> hardline
<> text "partialProcessConfigStdIn:" <+>
pretty (prettyHandle <$> getLast partialProcessConfigStdIn)
<> hardline
<> text "partialProcessConfigStdOut:" <+>
pretty (prettyHandle <$> getLast partialProcessConfigStdOut)
<> hardline
<> text "partialProcessConfigStdErr:" <+>
pretty (prettyHandle <$> getLast partialProcessConfigStdErr)
standardProcessConfig :: PartialProcessConfig
standardProcessConfig = mempty
{ partialProcessConfigEnvVars = mempty
{ partialEnvVarsInherit = pure True
}
, partialProcessConfigStdIn = pure stdin
, partialProcessConfigStdOut = pure stdout
, partialProcessConfigStdErr = pure stderr
}
addErrorContext :: String -> Either [String] a -> Either [String] a
addErrorContext cxt = either (Left . map (cxt <>)) Right
getOption :: String -> Last a -> Validation [String] a
getOption optionName = \case
Last (Just x) -> pure x
Last Nothing -> Failure ["Missing " ++ optionName ++ " option"]
completeProcessConfig
:: [(String, String)] -> PartialProcessConfig -> Either [String] ProcessConfig
completeProcessConfig envs PartialProcessConfig {..} = validationToEither $ do
let processConfigCmdLine = completeCommandLineArgs partialProcessConfigCmdLine
processConfigEnvVars <- eitherToValidation $
completePartialEnvVars envs partialProcessConfigEnvVars
processConfigStdIn <-
getOption "partialProcessConfigStdIn" partialProcessConfigStdIn
processConfigStdOut <-
getOption "partialProcessConfigStdOut" partialProcessConfigStdOut
processConfigStdErr <-
getOption "partialProcessConfigStdErr" partialProcessConfigStdErr
pure ProcessConfig {..}
data DirectoryType = Permanent FilePath | Temporary FilePath
deriving(Show, Eq, Ord)
toFilePath :: DirectoryType -> FilePath
toFilePath = \case
Permanent x -> x
Temporary x -> x
instance Pretty DirectoryType where
pretty = \case
Permanent x -> text "Permanent" <+> pretty x
Temporary x -> text "Temporary" <+> pretty x
data PartialDirectoryType
= PPermanent FilePath
| PTemporary
deriving(Show, Eq, Ord)
instance Pretty PartialDirectoryType where
pretty = \case
PPermanent x -> text "Permanent" <+> pretty x
PTemporary -> text "Temporary"
instance Semigroup PartialDirectoryType where
x <> y = case (x, y) of
(a, PTemporary ) -> a
(_, a@PPermanent {}) -> a
instance Monoid PartialDirectoryType where
mempty = PTemporary
setupDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType
setupDirectoryType pattern = \case
PTemporary -> Temporary <$> createTempDirectory "/tmp" pattern
PPermanent x -> pure $ Permanent x
rmDirIgnoreErrors :: FilePath -> IO ()
rmDirIgnoreErrors mainDir = do
let ignoreDirIsMissing e
| isDoesNotExistError e = return ()
| otherwise = throwIO e
removeDirectoryRecursive mainDir `catch` ignoreDirIsMissing
cleanupDirectoryType :: DirectoryType -> IO ()
cleanupDirectoryType = \case
Permanent _ -> pure ()
Temporary filePath -> rmDirIgnoreErrors filePath
data SocketClass
= IpSocket String
| UnixSocket DirectoryType
deriving (Show, Eq, Ord, Generic, Typeable)
instance Pretty SocketClass where
pretty = \case
IpSocket x -> text "IpSocket:" <+> pretty x
UnixSocket x -> text "UnixSocket:" <+> pretty x
socketClassToConfig :: SocketClass -> [String]
socketClassToConfig = \case
IpSocket ip -> ["listen_addresses = '" <> ip <> "'"]
UnixSocket dir ->
[ "listen_addresses = ''"
, "unix_socket_directories = '" <> toFilePath dir <> "'"
]
socketClassToHostFlag :: SocketClass -> [(String, Maybe String)]
socketClassToHostFlag x = [("-h", Just (socketClassToHost x))]
socketClassToHost :: SocketClass -> String
socketClassToHost = \case
IpSocket ip -> ip
UnixSocket dir -> toFilePath dir
data PartialSocketClass
= PIpSocket (Last String)
| PUnixSocket PartialDirectoryType
deriving stock (Show, Eq, Ord, Generic, Typeable)
instance Pretty PartialSocketClass where
pretty = \case
PIpSocket x -> "IpSocket:" <+> pretty (getLast x)
PUnixSocket x -> "UnixSocket" <+> pretty x
instance Semigroup PartialSocketClass where
x <> y = case (x, y) of
(PIpSocket a, PIpSocket b) -> PIpSocket $ a <> b
(a@(PIpSocket _), PUnixSocket _) -> a
(PUnixSocket _, a@(PIpSocket _)) -> a
(PUnixSocket a, PUnixSocket b) -> PUnixSocket $ a <> b
instance Monoid PartialSocketClass where
mempty = PUnixSocket mempty
setupPartialSocketClass :: PartialSocketClass -> IO SocketClass
setupPartialSocketClass theClass = case theClass of
PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $
getLast mIp
PUnixSocket mFilePath ->
UnixSocket <$> setupDirectoryType "tmp-postgres-socket" mFilePath
cleanupSocketConfig :: SocketClass -> IO ()
cleanupSocketConfig = \case
IpSocket {} -> pure ()
UnixSocket dir -> cleanupDirectoryType dir
data PartialPostgresPlan = PartialPostgresPlan
{ partialPostgresPlanProcessConfig :: PartialProcessConfig
, partialPostgresPlanClientConfig :: Client.Options
}
deriving stock (Generic)
deriving Semigroup via GenericSemigroup PartialPostgresPlan
deriving Monoid via GenericMonoid PartialPostgresPlan
instance Pretty PartialPostgresPlan where
pretty PartialPostgresPlan {..}
= text "partialPostgresPlanProcessConfig:"
<> softline
<> indent 2 (pretty partialPostgresPlanProcessConfig)
<> hardline
<> text "partialPostgresPlanClientConfig:"
<> softline
<> indent 2 (prettyOptions partialPostgresPlanClientConfig)
completePostgresPlan :: [(String, String)] -> PartialPostgresPlan -> Either [String] PostgresPlan
completePostgresPlan envs PartialPostgresPlan {..} = validationToEither $ do
let postgresPlanClientOptions = partialPostgresPlanClientConfig
postgresPlanProcessConfig <-
eitherToValidation $ addErrorContext "partialPostgresPlanProcessConfig: " $
completeProcessConfig envs partialPostgresPlanProcessConfig
pure PostgresPlan {..}
data PartialPlan = PartialPlan
{ partialPlanLogger :: Last Logger
, partialPlanInitDb :: Maybe PartialProcessConfig
, partialPlanCreateDb :: Maybe PartialProcessConfig
, partialPlanPostgres :: PartialPostgresPlan
, partialPlanConfig :: [String]
, partialPlanDataDirectory :: Last String
}
deriving stock (Generic)
deriving Semigroup via GenericSemigroup PartialPlan
deriving Monoid via GenericMonoid PartialPlan
instance Pretty PartialPlan where
pretty PartialPlan {..}
= text "partialPlanInitDb:"
<> softline
<> indent 2 (pretty partialPlanInitDb)
<> hardline
<> text "partialPlanInitDb:"
<> softline
<> indent 2 (pretty partialPlanCreateDb)
<> hardline
<> text "partialPlanPostgres:"
<> softline
<> indent 2 (pretty partialPlanPostgres)
<> hardline
<> text "partialPlanConfig:"
<> softline
<> indent 2 (vsep $ map text partialPlanConfig)
<> hardline
<> text "partialPlanDataDirectory:" <+> pretty (getLast partialPlanDataDirectory)
completePlan :: [(String, String)] -> PartialPlan -> Either [String] Plan
completePlan envs PartialPlan {..} = validationToEither $ do
planLogger <- getOption "partialPlanLogger" partialPlanLogger
planInitDb <- eitherToValidation $ addErrorContext "partialPlanInitDb: " $
traverse (completeProcessConfig envs) partialPlanInitDb
planCreateDb <- eitherToValidation $ addErrorContext "partialPlanCreateDb: " $
traverse (completeProcessConfig envs) partialPlanCreateDb
planPostgres <- eitherToValidation $ addErrorContext "partialPlanPostgres: " $
completePostgresPlan envs partialPlanPostgres
let planConfig = unlines partialPlanConfig
planDataDirectory <- getOption "partialPlanDataDirectory"
partialPlanDataDirectory
pure Plan {..}
hasInitDb :: PartialPlan -> Bool
hasInitDb PartialPlan {..} = isJust partialPlanInitDb
hasCreateDb :: PartialPlan -> Bool
hasCreateDb PartialPlan {..} = isJust partialPlanCreateDb
data Resources = Resources
{ resourcesPlan :: Plan
, resourcesSocket :: SocketClass
, resourcesDataDir :: DirectoryType
}
instance Pretty Resources where
pretty Resources {..}
= text "resourcePlan:"
<> softline
<> indent 2 (pretty resourcesPlan)
<> hardline
<> text "resourcesSocket:"
<+> pretty resourcesSocket
<> hardline
<> text "resourcesDataDir:"
<+> pretty resourcesDataDir
data Config = Config
{ configPlan :: PartialPlan
, configSocket :: PartialSocketClass
, configDataDir :: PartialDirectoryType
, configPort :: Last (Maybe Int)
}
deriving stock (Generic)
deriving Semigroup via GenericSemigroup Config
deriving Monoid via GenericMonoid Config
instance Pretty Config where
pretty Config {..}
= text "configPlan:"
<> softline
<> pretty configPlan
<> hardline
<> text "configSocket:"
<> softline
<> pretty configSocket
<> hardline
<> text "configDataDir:"
<> softline
<> pretty configDataDir
<> hardline
<> text "configPort:" <+> pretty (getLast configPort)
toPlan
:: Bool
-> Bool
-> Int
-> SocketClass
-> FilePath
-> PartialPlan
toPlan makeInitDb makeCreateDb port socketClass dataDirectory = mempty
{ partialPlanConfig = socketClassToConfig socketClass
, partialPlanDataDirectory = pure dataDirectory
, partialPlanPostgres = mempty
{ partialPostgresPlanProcessConfig = mempty
{ partialProcessConfigCmdLine = mempty
{ partialCommandLineArgsKeyBased = Map.fromList
[ ("-p", Just $ show port)
, ("-D", Just dataDirectory)
]
}
}
, partialPostgresPlanClientConfig = mempty
{ Client.host = pure $ socketClassToHost socketClass
, Client.port = pure port
, Client.dbname = pure "postgres"
}
}
, 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
}
setupConfig
:: Config
-> IO Resources
setupConfig Config {..} = evalContT $ do
envs <- lift getEnvironment
port <- lift $ maybe getFreePort pure $ join $ getLast configPort
resourcesSocket <- ContT $ bracketOnError
(setupPartialSocketClass configSocket) cleanupSocketConfig
resourcesDataDir <- ContT $ bracketOnError
(setupDirectoryType "tmp-postgres-data" configDataDir) cleanupDirectoryType
let hostAndDirPartial = toPlan
(hasInitDb configPlan)
(hasCreateDb configPlan)
port
resourcesSocket
(toFilePath resourcesDataDir)
finalPlan = hostAndDirPartial <> configPlan
resourcesPlan <- lift $ either (throwIO . CompletePlanFailed) pure $
completePlan envs finalPlan
pure Resources {..}
cleanupResources :: Resources -> IO ()
cleanupResources Resources {..} = do
cleanupSocketConfig resourcesSocket
cleanupDirectoryType resourcesDataDir
optionsToConfig :: Client.Options -> Config
optionsToConfig opts@Client.Options {..}
= ( mempty
{ configPlan = optionsToPlan opts
, configPort = maybe (Last Nothing) (pure . pure) $ getLast port
, configSocket = maybe mempty hostToSocketClass $ getLast host
}
)
optionsToPlan :: Client.Options -> PartialPlan
optionsToPlan opts@Client.Options {..}
= maybe mempty dbnameToPlan (getLast dbname)
<> maybe mempty userToPlan (getLast user)
<> clientOptionsToPlan opts
clientOptionsToPlan :: Client.Options -> PartialPlan
clientOptionsToPlan opts = mempty
{ partialPlanPostgres = mempty
{ partialPostgresPlanClientConfig = opts
}
}
userToPlan :: String -> PartialPlan
userToPlan user = mempty
{ partialPlanCreateDb = pure $ mempty
{ partialProcessConfigCmdLine = mempty
{ partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user
}
}
, partialPlanInitDb = pure $ mempty
{ partialProcessConfigCmdLine = mempty
{ partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user
}
}
}
dbnameToPlan :: String -> PartialPlan
dbnameToPlan dbName = mempty
{ partialPlanCreateDb = pure $ mempty
{ partialProcessConfigCmdLine = mempty
{ partialCommandLineArgsIndexBased = Map.singleton 0 dbName
}
}
}
hostToSocketClass :: String -> PartialSocketClass
hostToSocketClass hostOrSocketPath = case hostOrSocketPath of
'/' : _ -> PUnixSocket $ PPermanent hostOrSocketPath
_ -> PIpSocket $ pure hostOrSocketPath