Adding database dropping to dbtool

[hcoop/domtool2.git] / src / main.sml

diff --git a/src/main.sml b/src/main.sml
index f3bedc2..db657da 100644 (file)
--- 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