1a879e0f576d139dcd52e6d8ec958b4a3c169846Jens Elkner{-# LANGUAGE CPP, DeriveGeneric #-}
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksaimport qualified Data.ByteString.Char8 as BS
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksaimport qualified Data.Yaml as Yaml
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksadata DBContext = DBContext { contextFileVersion :: String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , contextFilePath :: FilePath -- a cache of "head $ infiles opts"
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa } deriving (Show, Eq)
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaemptyDBContext :: DBContext
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaemptyDBContext = DBContext { contextFileVersion = ""
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , contextFilePath = ""
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksadata ExtDBConfig = ExtDBConfig { development :: Maybe DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , test :: Maybe DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , production :: Maybe DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa } deriving (Show, Generic)
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksadata DBConfig = DBConfig { adapter :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , database :: String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , username :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , password :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , host :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , port :: Maybe Int
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , template :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , encoding :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , locale :: Maybe String
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , pool :: Maybe Int
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa -- The `Maybe` is only to skip this key during parsing.
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa -- It is used only for additional information that are
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa -- taken from the HetcatsOpts:
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , needMigration :: Maybe Bool
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa } deriving (Show, Generic)
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksadoMigrate :: DBConfig -> Bool
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksadoMigrate = (Just True ==) . needMigration
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksainstance FromJSON ExtDBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksainstance FromJSON DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaemptyDBConfig :: DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaemptyDBConfig = DBConfig { adapter = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , database = ""
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , username = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , password = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , host = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , port = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , template = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , encoding = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , locale = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , pool = Nothing
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , needMigration = Just True
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaisMySql :: DBConfig -> Bool
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaisMySql dbConfig = case adapter dbConfig of
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa Just "mysql" -> True
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa Just "mysql2" -> True
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaparseDatabaseConfig :: FilePath -> FilePath -> String -> Bool -> IO DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen KuksaparseDatabaseConfig dbFile dbConfigFile subconfigKey performMigration =
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa case (null dbFile, null dbConfigFile) of
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa (True, True) -> fail ("No database configuration supplied. "
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa ++ "Please specify either --database-config "
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa ++ "or --database-file.")
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa (_, False) -> do
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa config <- configFromYaml
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa return config { needMigration = Just performMigration }
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa (False, _) -> return sqliteConfig { needMigration = Just performMigration }
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa sqliteConfig :: DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa sqliteConfig = emptyDBConfig { adapter = Just "sqlite"
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa , database = dbFile
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa configFromYaml :: IO DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa configFromYaml = do
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa fileExist <- doesFileExist dbConfigFile
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa if fileExist
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa content <- BS.readFile dbConfigFile
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa case subconfigKey of
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa "" -> parseDBConfig content
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa _ | subconfigKey `elem` ["production", "development", "test"] ->
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa parseExtDBConfig subconfigKey content
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa _ -> fail "Persistence.DBConfig: Bad database-subconfig specified."
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa fail "Persistence.DBConfig: Database configuration file does not exist."
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa parseDBConfig :: BS.ByteString -> IO DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa parseDBConfig content =
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa let parsedContent = Yaml.decode content :: Maybe DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa in case parsedContent of
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa fail "Persistence.DBConfig: Could not parse database config file."
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa Just dbConfig -> return dbConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa parseExtDBConfig :: String -> BS.ByteString -> IO DBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa parseExtDBConfig key content =
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa let parsedContent = Yaml.decode content :: Maybe ExtDBConfig
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa in case parsedContent of
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa fail "Persistence.DBConfig: Could not parse database config file."
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa Just extDbConfig ->
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa let field = if key == "production" then production
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa else if key == "development" then development
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa in case field extDbConfig of
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa fail ("Persistence.DBConfig: Could not find subconfig "
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa ++ key ++ " in database configuration file.")
a389e88e0acb83d8489bdc5e55bc5522b152bbecEugen Kuksa Just dbConfig -> return dbConfig