-- | 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, databaseExists, userGrantedOnDatabase, userGranted, ) where import Propellor import Propellor.Base import Data.List import qualified Propellor.Property.Apt as Apt 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) instance Show Privilege where show Select = "SELECT" show Insert = "INSERT" show Update = "UPDATE" show Delete = "DELETE" show Create = "CREATE" show Drop = "DROP" show Index = "INDEX" show Alter = "ALTER" show CreateTemporaryTables = "CREATE TEMPORARY TABLES" show LockTables = "LOCK TABLES" show Execute = "EXECUTE" show CreateView = "CREATE VIEW" show ShowView = "SHOW VIEW" show CreateRoutine = "CREATE ROUTINE" show AlterRoutine = "ALTER ROUTINE" show Event = "EVENT" show Trigger = "TRIGGER" -- | All privileges allPrivileges :: [Privilege] allPrivileges = [ Select , Insert , Update , Delete , Create , Drop , Index , Alter , CreateTemporaryTables , LockTables , Execute , CreateView , ShowView , CreateRoutine , AlterRoutine , Event , 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"] -- | Create a database if it does not exist. When reverted, remove the -- database. databaseExists :: Database -> RevertableProperty DebianLike DebianLike databaseExists (Database dbname) = setup cleanup where setup :: Property DebianLike setup = setup' `requires` installed cleanup :: Property DebianLike cleanup = cleanup' `requires` installed -- 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 '" ++ 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) DebianLike 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 = "`" ++ dbname ++ "`.*" -- Create an user and make sure he has global grants but no other grant. userGranted :: IsContext c => User -> [Privilege] -> c -> RevertableProperty (HasInfo + DebianLike) DebianLike 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) DebianLike userGranted' (User username) privs context setupDesc setupSql userGrants = setup cleanup where setup :: Property (HasInfo + DebianLike) setup = setup' `requires` installed cleanup :: Property DebianLike cleanup = cleanup' `requires` installed -- 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('" ++ 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 show $ nub $ sort privs -- Qualified user name. quser = "'" ++ username ++ "'@'localhost'"