-- | Maintainer: Nicolas Schodet -- -- Support for MySQL/MariaDB server. -- -- Enough to setup a database with a dedicated user for web applications. module Propellor.Property.Mysql ( Database(..), Privilege(..), allPrivileges, basicPrivileges, basicStructurePrivileges, installed, installedAndReady, databaseExists, userGrantedOnDatabase, userGranted, ) where import Propellor import Propellor.Base import Data.List import qualified Propellor.Property.Apt as Apt -- | A database is defined by its name. newtype Database = Database String data Privilege = Select | Insert | Update | Delete | Create | Drop | Index | Alter | CreateTemporaryTables | LockTables | Execute | CreateView | ShowView | CreateRoutine | AlterRoutine | Event | Trigger deriving (Eq, Ord, Enum) sqlPrivilege :: Privilege -> String sqlPrivilege Select = "SELECT" sqlPrivilege Insert = "INSERT" sqlPrivilege Update = "UPDATE" sqlPrivilege Delete = "DELETE" sqlPrivilege Create = "CREATE" sqlPrivilege Drop = "DROP" sqlPrivilege Index = "INDEX" sqlPrivilege Alter = "ALTER" sqlPrivilege CreateTemporaryTables = "CREATE TEMPORARY TABLES" sqlPrivilege LockTables = "LOCK TABLES" sqlPrivilege Execute = "EXECUTE" sqlPrivilege CreateView = "CREATE VIEW" sqlPrivilege ShowView = "SHOW VIEW" sqlPrivilege CreateRoutine = "CREATE ROUTINE" sqlPrivilege AlterRoutine = "ALTER ROUTINE" sqlPrivilege Event = "EVENT" sqlPrivilege Trigger = "TRIGGER" -- | All privileges allPrivileges :: [Privilege] allPrivileges = [Select .. Trigger] -- | Basic privileges needed to use a classic database already created. basicPrivileges :: [Privilege] basicPrivileges = [ Select , Insert , Update , Delete ] -- | Classic privileges needed to create a database and its structure. basicStructurePrivileges :: [Privilege] basicStructurePrivileges = [ Select , Insert , Update , Delete , Create , Drop , Index , Alter ] -- | Make sure a server is installed. installed :: RevertableProperty DebianLike DebianLike installed = install remove where install = Apt.installed server remove = Apt.removed server server = ["default-mysql-server"] -- | Make sure a server is installed and ready. installedAndReady :: Property DebianLike installedAndReady = ready `requires` installed where ready = scriptProperty ["mysqladmin -w3 ping > /dev/null"] `assume` NoChange -- | Check whether server is installed. isInstalled :: IO Bool isInstalled = Apt.isInstalled server where server = "default-mysql-server" -- | Create a database if it does not exist. When reverted, remove the -- database. databaseExists :: Database -> RevertableProperty DebianLike UnixLike databaseExists (Database dbname) = setup cleanup where setup :: Property DebianLike setup = setup' `requires` installedAndReady cleanup :: Property UnixLike cleanup = check isInstalled $ cleanup' -- Test for database existance and create it if needed. setup' :: Property UnixLike setup' = property' desc $ \w -> do present <- liftIO $ dbPresent ensureProperty w $ setupprop present where desc = "database " ++ dbname ++ " exists" setupprop :: Bool -> Property UnixLike setupprop True = doNothing setupprop False = cmdProperty "mysqladmin" ["create", dbname] `assume` MadeChange -- Test for database existance and drop it if needed. cleanup' :: Property UnixLike cleanup' = property' desc $ \w -> do present <- liftIO $ dbPresent ensureProperty w $ cleanupprop present where desc = "database " ++ dbname ++ " does not exist" cleanupprop :: Bool -> Property UnixLike cleanupprop True = cmdProperty "mysqladmin" ["drop", "-f", dbname] `assume` MadeChange cleanupprop False = doNothing -- Is database present? dbPresent :: IO Bool dbPresent = (== trueResult) <$> readProcess "mysql" ["-BNre", sql] where sql = "SHOW DATABASES LIKE " ++ qdbname qdbname = sqlQuote '\'' dbname trueResult = dbname ++ "\n" -- Create an user and make sure he has grants on the specific database but no -- other grant. userGrantedOnDatabase :: IsContext c => User -> Database -> [Privilege] -> c -> RevertableProperty (HasInfo + DebianLike) UnixLike userGrantedOnDatabase user@(User username) (Database dbname) privs context = userGranted' user privs context setupDesc setupSql userGrants where setupDesc = "user " ++ username ++ " granted on database " ++ dbname setupSql quser hash privList = "GRANT " ++ privList ++ " ON " ++ privLevel ++ " TO " ++ quser ++ " IDENTIFIED BY PASSWORD '" ++ hash ++ "'" -- Expected user grants as output by MySQL. userGrants quser hash privList = "GRANT USAGE ON *.* TO " ++ quser ++ " IDENTIFIED BY PASSWORD '" ++ hash ++ "'\n" ++ "GRANT " ++ privList ++ " ON " ++ privLevel ++ " TO " ++ quser ++ "\n" -- Privilege level for database access. privLevel = (sqlQuote '`' dbname) ++ ".*" -- Create an user and make sure he has global grants but no other grant. userGranted :: IsContext c => User -> [Privilege] -> c -> RevertableProperty (HasInfo + DebianLike) UnixLike userGranted user@(User username) privs context = userGranted' user privs context setupDesc setupSql userGrants where setupDesc = "user " ++ username ++ " granted" setupSql quser hash privList = "GRANT " ++ privList ++ " ON *.*" ++ " TO " ++ quser ++ " IDENTIFIED BY PASSWORD '" ++ hash ++ "'" -- Expected user grants as output by MySQL. userGrants quser hash privList = "GRANT " ++ privList ++ " ON *.* TO " ++ quser ++ " IDENTIFIED BY PASSWORD '" ++ hash ++ "'\n" -- Common code to grant or remove an user. userGranted' :: IsContext c => User -> [Privilege] -> c -> String -> (String -> String -> String -> String) -> (String -> String -> String -> String) -> RevertableProperty (HasInfo + DebianLike) UnixLike userGranted' (User username) privs context setupDesc setupSql userGrants = setup cleanup where setup :: Property (HasInfo + DebianLike) setup = setup' `requires` installedAndReady cleanup :: Property UnixLike cleanup = check isInstalled $ cleanup' -- Check user grants and reset them if needed. setup' :: Property (HasInfo + UnixLike) setup' = withPrivData (Password username) context $ \getpassword -> property' setupDesc $ \w -> getpassword $ \priv -> do hash <- liftIO $ hashPassword $ privDataVal priv curGrants <- liftIO $ getUserGrants let match = curGrants == (userGrants quser hash privList) ensureProperty w $ setupprop match hash setupprop :: Bool -> String -> Property UnixLike setupprop True _ = doNothing setupprop False hash = cmdProperty "mysql" ["-BNre", sql] `assume` MadeChange where sql = "DROP USER IF EXISTS " ++ quser ++ ";" ++ (setupSql quser hash privList) -- Test for user existance and drop it if needed. cleanup' :: Property UnixLike cleanup' = property' desc $ \w -> do curGrants <- liftIO $ getUserGrants ensureProperty w $ cleanupprop $ curGrants /= "" where desc = "user " ++ username ++ " does not exist" cleanupprop :: Bool -> Property UnixLike cleanupprop False = doNothing cleanupprop True = cmdProperty "mysql" ["-BNre", sql] `assume` MadeChange where sql = "DROP USER " ++ quser -- Request MySQL to hash a password. hashPassword :: String -> IO String hashPassword password = Data.List.head . lines <$> writeReadProcessEnv "mysql" ["-BNr"] Nothing (Just writer) Nothing where writer h = hPutStr h sql sql = "SELECT PASSWORD(" ++ qpassword ++ ")" qpassword = sqlQuote '\'' password -- Request current user grants from MySQL. getUserGrants :: IO String getUserGrants = catchDefaultIO "" $ readProcess "mysql" ["-BNre", sql] where sql = "SHOW GRANTS FOR " ++ quser -- Privilege list as output by MySQL. privList = intercalate ", " $ map sqlPrivilege $ nub $ sort privs -- Qualified user name. quser = (sqlQuote '\'' username) ++ "@'localhost'" -- | Quote a string using the given quote character. sqlQuote :: Char -> String -> String sqlQuote quote s = [quote] ++ (concatMap escape s) ++ [quote] where escape c | c == quote = [quote, quote] | otherwise = [c]