summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Property/Mysql.hs246
1 files changed, 246 insertions, 0 deletions
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 <nico@ni.fr.eu.org>
+--
+-- 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'"