From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 24 Jun 2007 21:43:08 +0000 (+0000)
Subject: Adding database dropping to dbtool
X-Git-Tag: release_2010-11-19~187
X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/35659203a708078cdec25ff74adbe1e9168934d6

Adding database dropping to dbtool
---

diff --git a/configDefault/apache.cfg b/configDefault/apache.cfg
index 053d17a..d7f90c3 100644
--- a/configDefault/apache.cfg
+++ b/configDefault/apache.cfg
@@ -13,7 +13,7 @@ val undown1 = "/usr/bin/sudo /usr/local/sbin/domtool-publish apache1.3-undown"
 val confDir = "/var/domtool/vhosts"
 
 val webNodes_all = [("mire", {version = APACHE_2, auth = MOD_WAKLOG})]
-val webNodes_admin = [("deleuze", {version = APACHE_2, auth = NO_AUTH})]
+val webNodes_admin = [("deleuze", {version = APACHE_2, auth = MOD_WAKLOG})]
 
 val webNodes_default = ["mire"]
 
diff --git a/configDefault/mysql.cfg b/configDefault/mysql.cfg
index 1058bee..e7083e8 100644
--- a/configDefault/mysql.cfg
+++ b/configDefault/mysql.cfg
@@ -3,5 +3,6 @@ structure MySQL :> MYSQL_CONFIG = struct
 val adduser = "/usr/bin/sudo /usr/local/sbin/domtool-mysql adduser "
 val passwd = "/usr/bin/sudo /usr/local/sbin/domtool-mysql passwd "
 val createdb = "/usr/bin/sudo /usr/local/sbin/domtool-mysql createdb "
+val dropdb = "/usr/bin/sudo /usr/local/sbin/domtool-mysql dropdb "
 
 end
diff --git a/configDefault/mysql.csg b/configDefault/mysql.csg
index 39004ff..71bf9dd 100644
--- a/configDefault/mysql.csg
+++ b/configDefault/mysql.csg
@@ -3,5 +3,6 @@ signature MYSQL_CONFIG = sig
 val adduser : string
 val passwd : string
 val createdb : string
+val dropdb : string
 
 end
diff --git a/configDefault/postgres.cfg b/configDefault/postgres.cfg
index 3205fcd..6c91204 100644
--- a/configDefault/postgres.cfg
+++ b/configDefault/postgres.cfg
@@ -2,5 +2,6 @@ structure Postgres :> POSTGRES_CONFIG = struct
 
 val adduser = "/usr/bin/sudo /usr/local/sbin/domtool-postgres adduser "
 val createdb = "/usr/bin/sudo /usr/local/sbin/domtool-postgres createdb "
+val dropdb = "/usr/bin/sudo /usr/local/sbin/domtool-postgres dropdb "
 
 end
diff --git a/configDefault/postgres.csg b/configDefault/postgres.csg
index e09637a..e493dbe 100644
--- a/configDefault/postgres.csg
+++ b/configDefault/postgres.csg
@@ -2,5 +2,6 @@ signature POSTGRES_CONFIG = sig
 
 val adduser : string
 val createdb : string
+val dropdb : string
 
 end
diff --git a/src/dbms.sig b/src/dbms.sig
index deb2127..b600d9d 100644
--- a/src/dbms.sig
+++ b/src/dbms.sig
@@ -25,7 +25,8 @@ signature DBMS = sig
     type handler = {getpass : (unit -> Client.passwd_result) option,
 		    adduser : {user : string, passwd : string option} -> string option,
 		    passwd : {user : string, passwd : string} -> string option,
-		    createdb : {user : string, dbname : string} -> string option}
+		    createdb : {user : string, dbname : string} -> string option,
+		    dropdb : {user : string, dbname : string} -> string option}
 
     val register : string * handler -> unit
     val lookup : string -> handler option
diff --git a/src/dbms.sml b/src/dbms.sml
index fd04fd7..cc00d04 100644
--- a/src/dbms.sml
+++ b/src/dbms.sml
@@ -27,7 +27,8 @@ val validDbname = CharVector.all Char.isAlpha
 type handler = {getpass : (unit -> Client.passwd_result) option,
 		adduser : {user : string, passwd : string option} -> string option,
 		passwd : {user : string, passwd : string} -> string option,
-		createdb : {user : string, dbname : string} -> string option}
+		createdb : {user : string, dbname : string} -> string option,
+		dropdb : {user : string, dbname : string} -> string option}
 	       
 val dbmses : handler StringMap.map ref = ref StringMap.empty
 		  
diff --git a/src/main-dbtool.sml b/src/main-dbtool.sml
index a571159..f969c76 100644
--- a/src/main-dbtool.sml
+++ b/src/main-dbtool.sml
@@ -58,4 +58,9 @@ val _ =
 		    Main.requestDbTable {dbtype = dbtype, dbname = dbname}
 		else
 		    print ("Invalid database name " ^ dbname ^ ".\n")
+	      | ["dropdb", dbname] =>
+		if Dbms.validDbname dbname then
+		    Main.requestDbDrop {dbtype = dbtype, dbname = dbname}
+		else
+		    print ("Invalid database name " ^ dbname ^ ".\n")
 	      | _ => print "Invalid command-line arguments\n"
diff --git a/src/main.sig b/src/main.sig
index cddbeba..39c7810 100644
--- a/src/main.sig
+++ b/src/main.sig
@@ -58,6 +58,7 @@ signature MAIN = sig
     val requestDbUser : {dbtype : string, passwd : string option} -> unit
     val requestDbPasswd : {dbtype : string, passwd : string} -> unit
     val requestDbTable : {dbtype : string, dbname : string} -> unit
+    val requestDbDrop : {dbtype : string, dbname : string} -> unit
 
     val requestListMailboxes : string -> Vmail.listing
     val requestNewMailbox : {domain : string, user : string,
diff --git a/src/main.sml b/src/main.sml
index f3bedc2..db657da 100644
--- a/src/main.sml
+++ b/src/main.sml
@@ -534,6 +534,21 @@ fun requestDbTable p =
 	OpenSSL.close bio
     end
 
+fun requestDbDrop p =
+    let
+	val (user, bio) = requestBio (fn () => ())
+    in
+	Msg.send (bio, MsgDropDb p);
+	case Msg.recv bio of
+	    NONE => print "Server closed connection unexpectedly.\n"
+	  | SOME m =>
+	    case m of
+		MsgOk => print ("Your database " ^ user ^ "_" ^ #dbname p ^ " has been dropped.\n")
+	      | MsgError s => print ("Drop failed: " ^ s ^ "\n")
+	      | _ => print "Unexpected server reply.\n";
+	OpenSSL.close bio
+    end
+
 fun requestListMailboxes domain =
     let
 	val (_, bio) = requestBio (fn () => ())
@@ -1254,6 +1269,23 @@ fun service () =
 					      SOME ("Invalid database name " ^ dbname)))
 				     (fn () => ())
 
+			      | MsgDropDb {dbtype, dbname} =>
+				doIt (fn () =>
+					 if Dbms.validDbname dbname then
+					     case Dbms.lookup dbtype of
+						 NONE => ("Database drop request with unknown datatype type " ^ dbtype,
+							  SOME ("Unknown database type " ^ dbtype))
+					       | SOME handler =>
+						 case #dropdb handler {user = user, dbname = dbname} of
+						     NONE => ("Drop database " ^ user ^ "_" ^ dbname ^ ".",
+							      NONE)
+						   | SOME msg => ("Error dropping database " ^ user ^ "_" ^ dbname ^ ": " ^ msg,
+								  SOME ("Error dropping database: " ^ msg))
+					 else
+					     ("Invalid database name " ^ user ^ "_" ^ dbname,
+					      SOME ("Invalid database name " ^ dbname)))
+				     (fn () => ())
+
 			      | MsgListMailboxes domain =>
 				doIt (fn () =>
 					 if not (Domain.yourDomain domain) then
diff --git a/src/msg.sml b/src/msg.sml
index 19a84b4..bbaf24a 100644
--- a/src/msg.sml
+++ b/src/msg.sml
@@ -222,6 +222,9 @@ fun send (bio, m) =
       | MsgFirewall ls => (OpenSSL.writeInt (bio, 34);
 			   sendList OpenSSL.writeString (bio, ls))
       | MsgRegenerateTc => OpenSSL.writeInt (bio, 35)
+      | MsgDropDb {dbtype, dbname} => (OpenSSL.writeInt (bio, 36);
+				       OpenSSL.writeString (bio, dbtype);
+				       OpenSSL.writeString (bio, dbname))
 
 fun checkIt v =
     case v of
@@ -323,6 +326,10 @@ fun recv bio =
 		   | 33 => Option.map MsgSocket (recvSockPerm bio)
 		   | 34 => Option.map MsgFirewall (recvList OpenSSL.readString bio)
 		   | 35 => SOME MsgRegenerateTc
+		   | 36 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of
+				(SOME dbtype, SOME dbname) =>
+				SOME (MsgDropDb {dbtype = dbtype, dbname = dbname})
+			      | _ => NONE)
 		   | _ => NONE)
 	 
 end
diff --git a/src/msgTypes.sml b/src/msgTypes.sml
index 00dc82a..8f15ad7 100644
--- a/src/msgTypes.sml
+++ b/src/msgTypes.sml
@@ -77,7 +77,9 @@ datatype msg =
        | MsgCreateDbUser of {dbtype : string, passwd : string option}
        (* Request creation of a user for the named DBMS type *)
        | MsgCreateDbTable of {dbtype : string, dbname : string}
-       (* Request creation of a DBMS table *)
+       (* Request creation of a DBMS database *)
+       | MsgDropDb of {dbtype : string, dbname : string}
+       (* Request dropping of a DBMS database *)
        | MsgNewMailbox of {domain : string, user : string,
 			   passwd : string, mailbox : string}
        (* Request creation of a new vmail mapping *)
diff --git a/src/plugins/mysql.sml b/src/plugins/mysql.sml
index dae75cc..7f55e5f 100644
--- a/src/plugins/mysql.sml
+++ b/src/plugins/mysql.sml
@@ -53,9 +53,16 @@ fun createdb {user, dbname} =
     else
 	SOME "Error executing CREATE DATABASE script"
 
+fun dropdb {user, dbname} =
+    if Slave.shell [Config.MySQL.dropdb, user, " ", dbname] then
+	NONE
+    else
+	SOME "Error executing DROP DATABASE script"
+
 val _ = Dbms.register ("mysql", {getpass = SOME Client.getpass,
 				 adduser = adduser,
 				 passwd = passwd,
-				 createdb = createdb})
+				 createdb = createdb,
+				 dropdb = dropdb})
 
 end
diff --git a/src/plugins/postgres.sml b/src/plugins/postgres.sml
index 1689840..b92a5cf 100644
--- a/src/plugins/postgres.sml
+++ b/src/plugins/postgres.sml
@@ -34,9 +34,16 @@ fun createdb {user, dbname} =
     else
 	SOME "Error executing CREATE DATABASE script"
 
+fun dropdb {user, dbname} =
+    if Slave.shell [Config.Postgres.dropdb, user, " ", dbname] then
+	NONE
+    else
+	SOME "Error executing DROP DATABASE script"
+
 val _ = Dbms.register ("postgres", {getpass = NONE,
 				    adduser = adduser,
 				    passwd = passwd,
-				    createdb = createdb})
+				    createdb = createdb,
+				    dropdb = dropdb})
 
 end