From 8ff57560b6aa6c99b2128fcaad8684a8d5a018ce Mon Sep 17 00:00:00 2001 From: Nicolas Schodet Date: Thu, 30 Aug 2018 23:06:43 +0200 Subject: Mysql: handle classic databases for web applications --- src/Propellor/Property/Mysql.hs | 246 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 246 insertions(+) create mode 100644 src/Propellor/Property/Mysql.hs (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/Mysql.hs b/src/Propellor/Property/Mysql.hs new file mode 100644 index 00000000..e387e2fe --- /dev/null +++ b/src/Propellor/Property/Mysql.hs @@ -0,0 +1,246 @@ +-- | 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, +) 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 username) (Database dbname) privs context = + 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' desc $ \w -> getpassword $ \priv -> do + hash <- liftIO $ hashPassword $ privDataVal priv + curGrants <- liftIO $ getUserGrants + let match = curGrants == (userGrants hash) + ensureProperty w $ setupprop match hash + where + desc = "user " ++ username ++ " granted on database " ++ dbname + + setupprop :: Bool -> String -> Property UnixLike + setupprop True _ = doNothing + setupprop False hash = cmdProperty "mysql" ["-BNre", sql] + `assume` MadeChange + where + sql = "DROP USER IF EXISTS " ++ quser ++ ";" + ++ "GRANT " ++ privList ++ " ON " ++ privLevel + ++ " TO " ++ quser + ++ " IDENTIFIED BY PASSWORD '" ++ hash ++ "'" + + -- 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 + + -- Expected user grants as output by MySQL. + userGrants :: String -> String + userGrants hash = + "GRANT USAGE ON *.* TO " ++ quser + ++ " IDENTIFIED BY PASSWORD '" ++ hash ++ "'\n" + ++ "GRANT " ++ privList ++ " ON " ++ privLevel + ++ " TO " ++ quser ++ "\n" + + -- Privilege level for database access. + privLevel = "`" ++ dbname ++ "`.*" + -- Privilege list as output by MySQL. + privList = intercalate ", " $ map show $ nub $ sort privs + -- Qualified user name. + quser = "'" ++ username ++ "'@'localhost'" -- cgit v1.2.3