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
data Lastoid a = Replace a | Mappend a
deriving (Show, Eq, Functor)
instance Semigroup a => Semigroup (Lastoid a) where
x <> y = case (x, y) of
(_ , r@Replace {}) -> r
(Replace a, Mappend b ) -> Replace $ a <> b
(Mappend a, Mappend b ) -> Mappend $ a <> b
instance Monoid a => Monoid (Lastoid a) where
mempty = Mappend mempty
getLastoid :: Lastoid a -> a
getLastoid = \case
Replace a -> a
Mappend a -> a
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
}
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 :: Lastoid (Map String String)
, partialProcessConfigCmdLine :: Lastoid PartialCommandLineArgs
, partialProcessConfigStdIn :: Last Handle
, partialProcessConfigStdOut :: Last Handle
, partialProcessConfigStdErr :: Last Handle
}
deriving stock (Generic)
deriving Monoid via GenericMonoid PartialProcessConfig
instance Semigroup PartialProcessConfig where
x <> y = PartialProcessConfig
{ partialProcessConfigEnvVars = fmap getDual $
fmap Dual (partialProcessConfigEnvVars x) <>
fmap Dual (partialProcessConfigEnvVars y)
, partialProcessConfigCmdLine =
partialProcessConfigCmdLine x <> partialProcessConfigCmdLine y
, partialProcessConfigStdIn =
partialProcessConfigStdIn x <> partialProcessConfigStdIn y
, partialProcessConfigStdOut =
partialProcessConfigStdOut x <> partialProcessConfigStdOut y
, partialProcessConfigStdErr =
partialProcessConfigStdErr x <> partialProcessConfigStdErr y
}
standardProcessConfig :: IO PartialProcessConfig
standardProcessConfig = do
env <- getEnvironment
pure mempty
{ partialProcessConfigEnvVars = Replace $ Map.fromList env
, 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
:: PartialProcessConfig -> Either [String] ProcessConfig
completeProcessConfig PartialProcessConfig {..} = validationToEither $ do
let processConfigEnvVars = Map.toList $ getLastoid partialProcessConfigEnvVars
processConfigCmdLine = completeCommandLineArgs $
getLastoid partialProcessConfigCmdLine
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
data PartialDirectoryType
= PPermanent FilePath
| PTemporary
deriving(Show, Eq, Ord)
instance Semigroup PartialDirectoryType where
x <> y = case (x, y) of
(a, PTemporary ) -> a
(_, a@PPermanent {}) -> a
instance Monoid PartialDirectoryType where
mempty = PTemporary
initDirectoryType :: String -> PartialDirectoryType -> IO DirectoryType
initDirectoryType 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
shutdownDirectoryType :: DirectoryType -> IO ()
shutdownDirectoryType = \case
Permanent _ -> pure ()
Temporary filePath -> rmDirIgnoreErrors filePath
data SocketClass
= IpSocket String
| UnixSocket DirectoryType
deriving (Show, Eq, Ord, Generic, Typeable)
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 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
initPartialSocketClass :: PartialSocketClass -> IO SocketClass
initPartialSocketClass theClass = case theClass of
PIpSocket mIp -> pure $ IpSocket $ fromMaybe "127.0.0.1" $
getLast mIp
PUnixSocket mFilePath ->
UnixSocket <$> initDirectoryType "tmp-postgres-socket" mFilePath
shutdownSocketConfig :: SocketClass -> IO ()
shutdownSocketConfig = \case
IpSocket {} -> pure ()
UnixSocket dir -> shutdownDirectoryType dir
data PartialPostgresPlan = PartialPostgresPlan
{ partialPostgresPlanProcessConfig :: PartialProcessConfig
, partialPostgresPlanClientConfig :: Client.Options
}
deriving stock (Generic)
deriving Semigroup via GenericSemigroup PartialPostgresPlan
deriving Monoid via GenericMonoid PartialPostgresPlan
completePostgresPlan :: PartialPostgresPlan -> Either [String] PostgresPlan
completePostgresPlan PartialPostgresPlan {..} = validationToEither $ do
let postgresPlanClientConfig = partialPostgresPlanClientConfig
postgresPlanProcessConfig <-
eitherToValidation $ addErrorContext "partialPostgresPlanProcessConfig: " $
completeProcessConfig partialPostgresPlanProcessConfig
pure PostgresPlan {..}
data PartialPlan = PartialPlan
{ partialPlanLogger :: Last Logger
, partialPlanInitDb :: Lastoid (Maybe PartialProcessConfig)
, partialPlanCreateDb :: Lastoid (Maybe PartialProcessConfig)
, partialPlanPostgres :: PartialPostgresPlan
, partialPlanConfig :: Lastoid [String]
, partialPlanDataDirectory :: Last String
}
deriving stock (Generic)
deriving Semigroup via GenericSemigroup PartialPlan
deriving Monoid via GenericMonoid PartialPlan
completePlan :: PartialPlan -> Either [String] Plan
completePlan PartialPlan {..} = validationToEither $ do
planLogger <- getOption "partialPlanLogger" partialPlanLogger
planInitDb <- eitherToValidation $ addErrorContext "partialPlanInitDb: " $
traverse completeProcessConfig $ getLastoid partialPlanInitDb
planCreateDb <- eitherToValidation $ addErrorContext "partialPlanCreateDb: " $
traverse completeProcessConfig $ getLastoid partialPlanCreateDb
planPostgres <- eitherToValidation $ addErrorContext "partialPlanPostgres: " $
completePostgresPlan partialPlanPostgres
let planConfig = unlines $ getLastoid partialPlanConfig
planDataDirectory <- getOption "partialPlanDataDirectory"
partialPlanDataDirectory
pure Plan {..}
data Resources = Resources
{ resourcesPlan :: Plan
, resourcesSocket :: SocketClass
, resourcesDataDir :: DirectoryType
}
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
toPlan
:: Int
-> SocketClass
-> FilePath
-> PartialPlan
toPlan port socketClass dataDirectory = mempty
{ partialPlanConfig = Mappend $ socketClassToConfig socketClass
, partialPlanDataDirectory = pure dataDirectory
, partialPlanPostgres = mempty
{ partialPostgresPlanProcessConfig = mempty
{ partialProcessConfigCmdLine = Mappend $ mempty
{ partialCommandLineArgsKeyBased = Map.fromList
[ ("-p", Just $ show port)
, ("-D", Just dataDirectory)
]
}
}
, partialPostgresPlanClientConfig = mempty
{ Client.host = pure $ socketClassToHost socketClass
, Client.port = pure port
}
}
, partialPlanCreateDb = Mappend $ Just $ mempty
{ partialProcessConfigCmdLine = Mappend $ mempty
{ partialCommandLineArgsKeyBased = Map.fromList $
socketClassToHostFlag socketClass <>
[("-p ", Just $ show port)]
}
}
, partialPlanInitDb = Mappend $ Just $ mempty
{ partialProcessConfigCmdLine = Mappend $ mempty
{ partialCommandLineArgsKeyBased = Map.fromList $
[("--pgdata=", Just dataDirectory)]
}
}
}
initConfig
:: Config
-> IO Resources
initConfig Config {..} = evalContT $ do
port <- lift $ maybe getFreePort pure $ join $ getLast configPort
resourcesSocket <- ContT $ bracketOnError
(initPartialSocketClass configSocket) shutdownSocketConfig
resourcesDataDir <- ContT $ bracketOnError
(initDirectoryType "tmp-postgres-data" configDataDir) shutdownDirectoryType
let hostAndDirPartial = toPlan port resourcesSocket $
toFilePath resourcesDataDir
resourcesPlan <- lift $ either (throwIO . CompletePlanFailed) pure $
completePlan $ hostAndDirPartial <> configPlan
pure Resources {..}
shutdownResources :: Resources -> IO ()
shutdownResources Resources {..} = do
shutdownSocketConfig resourcesSocket
shutdownDirectoryType resourcesDataDir
optionsToConfig :: Client.Options -> Config
optionsToConfig opts@Client.Options {..}
= ( mempty
{ configPlan = optionsToPlan opts
, configPort = maybe (Last Nothing) (pure . pure) $ getLast port
, configSocket = hostToSocketClass $ getLast host
}
)
<> ( mempty
{ configPlan = mempty
{ partialPlanPostgres = mempty
{ partialPostgresPlanClientConfig = opts
}
}
}
)
optionsToPlan :: Client.Options -> PartialPlan
optionsToPlan Client.Options {..}
= dbnameToPlan (getLast dbname)
<> userToPlan (getLast user)
userToPlan :: Maybe String -> PartialPlan
userToPlan = \case
Nothing -> mempty
Just user -> mempty
{ partialPlanCreateDb = Mappend $ Just $ mempty
{ partialProcessConfigCmdLine = Mappend $ mempty
{ partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user
}
}
, partialPlanInitDb = Mappend $ Just $ mempty
{ partialProcessConfigCmdLine = Mappend $ mempty
{ partialCommandLineArgsKeyBased = Map.singleton "--username=" $ Just user
}
}
}
dbnameToPlan :: Maybe String -> PartialPlan
dbnameToPlan = \case
Nothing -> mempty
Just dbName -> mempty
{ partialPlanCreateDb = Mappend $ Just $ mempty
{ partialProcessConfigCmdLine = Mappend $ mempty
{ partialCommandLineArgsIndexBased = Map.singleton 0 dbName
}
}
}
hostToSocketClass :: Maybe String -> PartialSocketClass
hostToSocketClass = \case
Nothing -> mempty
Just hostOrSocketPath -> case hostOrSocketPath of
'/' : _ -> PUnixSocket $ PPermanent hostOrSocketPath
_ -> PIpSocket $ pure hostOrSocketPath