{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}

module Persistence.DBConfig where

import qualified Data.ByteString.Char8 as BS
import qualified Data.Yaml as Yaml
import GHC.Generics
import System.Directory
import qualified Control.Monad.Fail as Fail

data DBContext = DBContext { DBContext -> String
contextFileVersion :: String
                           , DBContext -> String
contextFilePath :: FilePath -- a cache of "head $ infiles opts"
                           } deriving (Int -> DBContext -> ShowS
[DBContext] -> ShowS
DBContext -> String
(Int -> DBContext -> ShowS)
-> (DBContext -> String)
-> ([DBContext] -> ShowS)
-> Show DBContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DBContext] -> ShowS
$cshowList :: [DBContext] -> ShowS
show :: DBContext -> String
$cshow :: DBContext -> String
showsPrec :: Int -> DBContext -> ShowS
$cshowsPrec :: Int -> DBContext -> ShowS
Show, DBContext -> DBContext -> Bool
(DBContext -> DBContext -> Bool)
-> (DBContext -> DBContext -> Bool) -> Eq DBContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DBContext -> DBContext -> Bool
$c/= :: DBContext -> DBContext -> Bool
== :: DBContext -> DBContext -> Bool
$c== :: DBContext -> DBContext -> Bool
Eq)

emptyDBContext :: DBContext
emptyDBContext :: DBContext
emptyDBContext = DBContext :: String -> String -> DBContext
DBContext { contextFileVersion :: String
contextFileVersion = ""
                           , contextFilePath :: String
contextFilePath = ""
                           }

data ExtDBConfig = ExtDBConfig { ExtDBConfig -> Maybe DBConfig
development :: Maybe DBConfig
                               , ExtDBConfig -> Maybe DBConfig
test :: Maybe DBConfig
                               , ExtDBConfig -> Maybe DBConfig
production :: Maybe DBConfig
                               } deriving (Int -> ExtDBConfig -> ShowS
[ExtDBConfig] -> ShowS
ExtDBConfig -> String
(Int -> ExtDBConfig -> ShowS)
-> (ExtDBConfig -> String)
-> ([ExtDBConfig] -> ShowS)
-> Show ExtDBConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtDBConfig] -> ShowS
$cshowList :: [ExtDBConfig] -> ShowS
show :: ExtDBConfig -> String
$cshow :: ExtDBConfig -> String
showsPrec :: Int -> ExtDBConfig -> ShowS
$cshowsPrec :: Int -> ExtDBConfig -> ShowS
Show, (forall x. ExtDBConfig -> Rep ExtDBConfig x)
-> (forall x. Rep ExtDBConfig x -> ExtDBConfig)
-> Generic ExtDBConfig
forall x. Rep ExtDBConfig x -> ExtDBConfig
forall x. ExtDBConfig -> Rep ExtDBConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExtDBConfig x -> ExtDBConfig
$cfrom :: forall x. ExtDBConfig -> Rep ExtDBConfig x
Generic)

data DBConfig = DBConfig { DBConfig -> Maybe String
adapter :: Maybe String
                         , DBConfig -> String
database :: String
                         , DBConfig -> Maybe String
username :: Maybe String
                         , DBConfig -> Maybe String
password :: Maybe String
                         , DBConfig -> Maybe String
host :: Maybe String
                         , DBConfig -> Maybe Int
port :: Maybe Int
                         , DBConfig -> Maybe String
template :: Maybe String
                         , DBConfig -> Maybe String
encoding :: Maybe String
                         , DBConfig -> Maybe String
locale :: Maybe String
                         , DBConfig -> Maybe Int
pool :: Maybe Int
                         -- The `Maybe` is only to skip this key during parsing.
                         -- It is used only for additional information that are
                         -- taken from the HetcatsOpts:
                         , DBConfig -> Maybe Bool
needMigration :: Maybe Bool
                         } deriving (Int -> DBConfig -> ShowS
[DBConfig] -> ShowS
DBConfig -> String
(Int -> DBConfig -> ShowS)
-> (DBConfig -> String) -> ([DBConfig] -> ShowS) -> Show DBConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DBConfig] -> ShowS
$cshowList :: [DBConfig] -> ShowS
show :: DBConfig -> String
$cshow :: DBConfig -> String
showsPrec :: Int -> DBConfig -> ShowS
$cshowsPrec :: Int -> DBConfig -> ShowS
Show, (forall x. DBConfig -> Rep DBConfig x)
-> (forall x. Rep DBConfig x -> DBConfig) -> Generic DBConfig
forall x. Rep DBConfig x -> DBConfig
forall x. DBConfig -> Rep DBConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DBConfig x -> DBConfig
$cfrom :: forall x. DBConfig -> Rep DBConfig x
Generic)

doMigrate :: DBConfig -> Bool
doMigrate :: DBConfig -> Bool
doMigrate = (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Bool -> Bool)
-> (DBConfig -> Maybe Bool) -> DBConfig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBConfig -> Maybe Bool
needMigration

instance Yaml.FromJSON ExtDBConfig
instance Yaml.FromJSON DBConfig

emptyDBConfig :: DBConfig
emptyDBConfig :: DBConfig
emptyDBConfig = DBConfig :: Maybe String
-> String
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe Int
-> Maybe String
-> Maybe String
-> Maybe String
-> Maybe Int
-> Maybe Bool
-> DBConfig
DBConfig { adapter :: Maybe String
adapter = Maybe String
forall a. Maybe a
Nothing
                         , database :: String
database = ""
                         , username :: Maybe String
username = Maybe String
forall a. Maybe a
Nothing
                         , password :: Maybe String
password = Maybe String
forall a. Maybe a
Nothing
                         , host :: Maybe String
host = Maybe String
forall a. Maybe a
Nothing
                         , port :: Maybe Int
port = Maybe Int
forall a. Maybe a
Nothing
                         , template :: Maybe String
template = Maybe String
forall a. Maybe a
Nothing
                         , encoding :: Maybe String
encoding = Maybe String
forall a. Maybe a
Nothing
                         , locale :: Maybe String
locale = Maybe String
forall a. Maybe a
Nothing
                         , pool :: Maybe Int
pool = Maybe Int
forall a. Maybe a
Nothing
                         , needMigration :: Maybe Bool
needMigration = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                         }
#ifdef MYSQL
isMySql :: DBConfig -> Bool
isMySql dbConfig = case adapter dbConfig of
  Just "mysql" -> True
  Just "mysql2" -> True
  _ -> False
#endif

parseDatabaseConfig :: FilePath -> FilePath -> String -> Bool -> IO DBConfig
parseDatabaseConfig :: String -> String -> String -> Bool -> IO DBConfig
parseDatabaseConfig dbFile :: String
dbFile dbConfigFile :: String
dbConfigFile subconfigKey :: String
subconfigKey performMigration :: Bool
performMigration =
  case (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dbFile, String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dbConfigFile) of
     (True, True) -> String -> IO DBConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("No database configuration supplied. "
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Please specify either --database-config "
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ "or --database-file.")
     (_, False) -> do
       DBConfig
config <- IO DBConfig
configFromYaml
       DBConfig -> IO DBConfig
forall (m :: * -> *) a. Monad m => a -> m a
return DBConfig
config { needMigration :: Maybe Bool
needMigration = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
performMigration }
     (False, _) -> DBConfig -> IO DBConfig
forall (m :: * -> *) a. Monad m => a -> m a
return DBConfig
sqliteConfig { needMigration :: Maybe Bool
needMigration = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
performMigration }
  where
    sqliteConfig :: DBConfig
    sqliteConfig :: DBConfig
sqliteConfig = DBConfig
emptyDBConfig { adapter :: Maybe String
adapter = String -> Maybe String
forall a. a -> Maybe a
Just "sqlite"
                                 , database :: String
database = String
dbFile
                                 }

    configFromYaml :: IO DBConfig
    configFromYaml :: IO DBConfig
configFromYaml = do
      Bool
fileExist <- String -> IO Bool
doesFileExist String
dbConfigFile
      if Bool
fileExist
       then do
         ByteString
content <- String -> IO ByteString
BS.readFile String
dbConfigFile
         case String
subconfigKey of
           "" -> ByteString -> IO DBConfig
parseDBConfig ByteString
content
           _ | String
subconfigKey String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["production", "development", "test"] ->
             String -> ByteString -> IO DBConfig
parseExtDBConfig String
subconfigKey ByteString
content
           _ -> String -> IO DBConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Persistence.DBConfig: Bad database-subconfig specified."
       else
         String -> IO DBConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Persistence.DBConfig: Database configuration file does not exist."

    parseDBConfig :: BS.ByteString -> IO DBConfig
    parseDBConfig :: ByteString -> IO DBConfig
parseDBConfig content :: ByteString
content =
      let parsedContent :: Maybe DBConfig
parsedContent = ByteString -> Maybe DBConfig
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
content :: Maybe DBConfig
      in case Maybe DBConfig
parsedContent of
        Nothing ->
          String -> IO DBConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Persistence.DBConfig: Could not parse database config file."
        Just dbConfig :: DBConfig
dbConfig -> DBConfig -> IO DBConfig
forall (m :: * -> *) a. Monad m => a -> m a
return DBConfig
dbConfig

    parseExtDBConfig :: String -> BS.ByteString -> IO DBConfig
    parseExtDBConfig :: String -> ByteString -> IO DBConfig
parseExtDBConfig key :: String
key content :: ByteString
content =
      let parsedContent :: Maybe ExtDBConfig
parsedContent = ByteString -> Maybe ExtDBConfig
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
Yaml.decodeThrow ByteString
content :: Maybe ExtDBConfig
      in case Maybe ExtDBConfig
parsedContent of
        Nothing ->
          String -> IO DBConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "Persistence.DBConfig: Could not parse database config file."
        Just extDbConfig :: ExtDBConfig
extDbConfig ->
          let field :: ExtDBConfig -> Maybe DBConfig
field = if String
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "production" then ExtDBConfig -> Maybe DBConfig
production
                      else if String
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "development" then ExtDBConfig -> Maybe DBConfig
development
                      else ExtDBConfig -> Maybe DBConfig
test
          in case ExtDBConfig -> Maybe DBConfig
field ExtDBConfig
extDbConfig of
            Nothing ->
              String -> IO DBConfig
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("Persistence.DBConfig: Could not find subconfig "
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ " in database configuration file.")
            Just dbConfig :: DBConfig
dbConfig -> DBConfig -> IO DBConfig
forall (m :: * -> *) a. Monad m => a -> m a
return DBConfig
dbConfig