From: Clinton Ebadi Date: Thu, 25 Nov 2010 06:03:40 +0000 (-0500) Subject: Attempt to move Dbms handling into slave X-Git-Tag: release-2010-12-01_1^2~2 X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/c362e4cc29d981936644c90c71e9d2127b5ea6d3 Attempt to move Dbms handling into slave * It typechecks and compiles... and looks like it ought to work * `requestDbFoo' functions make an ad-hoc connection to a slave. There is much room for cleanup here. * /Factored/ doIt function from `service' so that the Dbms message handling could be cut and pasted into the slave function * Added Dbms.dbmsNode configuration option * Note that dbms operations *always* occur on a slave now--if the machine is also the dispatcher node it will now need to run a slave instance as well --- diff --git a/configDefault/dbms.cfg b/configDefault/dbms.cfg new file mode 100644 index 0000000..2a7e6e2 --- /dev/null +++ b/configDefault/dbms.cfg @@ -0,0 +1,5 @@ +structure Dbms :> DBMS_CONFIG = struct + +val dbmsNode = "fritz" + +end diff --git a/configDefault/dbms.cfs b/configDefault/dbms.cfs new file mode 100644 index 0000000..4f29c01 --- /dev/null +++ b/configDefault/dbms.cfs @@ -0,0 +1 @@ +structure Dbms : DBMS_CONFIG diff --git a/configDefault/dbms.csg b/configDefault/dbms.csg new file mode 100644 index 0000000..a9f05e2 --- /dev/null +++ b/configDefault/dbms.csg @@ -0,0 +1,5 @@ +signature DBMS_CONFIG = sig + + val dbmsNode : string + +end diff --git a/src/main.sml b/src/main.sml index d46deac..cf53af0 100644 --- a/src/main.sml +++ b/src/main.sml @@ -535,7 +535,9 @@ fun requestRmuser user = fun requestDbUser dbtype = let - val (_, bio) = requestBio (fn () => ()) + val (_, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, + Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort) in Msg.send (bio, MsgCreateDbUser dbtype); case Msg.recv bio of @@ -550,7 +552,9 @@ fun requestDbUser dbtype = fun requestDbPasswd rc = let - val (_, bio) = requestBio (fn () => ()) + val (_, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, + Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort) in Msg.send (bio, MsgDbPasswd rc); case Msg.recv bio of @@ -565,7 +569,9 @@ fun requestDbPasswd rc = fun requestDbTable p = let - val (user, bio) = requestBio (fn () => ()) + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, + Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort) in Msg.send (bio, MsgCreateDb p); case Msg.recv bio of @@ -580,7 +586,9 @@ fun requestDbTable p = fun requestDbDrop p = let - val (user, bio) = requestBio (fn () => ()) + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, + Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort) in Msg.send (bio, MsgDropDb p); case Msg.recv bio of @@ -595,7 +603,9 @@ fun requestDbDrop p = fun requestDbGrant p = let - val (user, bio) = requestBio (fn () => ()) + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, + Config.Dbms.dbmsNode ^ ":" ^ Int.toString Config.slavePort) in Msg.send (bio, MsgGrantDb p); case Msg.recv bio of @@ -1162,6 +1172,43 @@ fun describeQuery q = | QSocket user => "Asked about socket permissions for user " ^ user | QFirewall user => "Asked about firewall rules for user " ^ user +fun doIt' loop bio f cleanup = + ((case f () of + (msgLocal, SOME msgRemote) => + (print msgLocal; + print "\n"; + Msg.send (bio, MsgError msgRemote)) + | (msgLocal, NONE) => + (print msgLocal; + print "\n"; + Msg.send (bio, MsgOk))) + handle e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + Msg.send (bio, MsgError ("OpenSSL error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | OS.SysErr (s, _) => + (print "System error: "; + print s; + print "\n"; + Msg.send (bio, MsgError ("System error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | Fail s => + (print "Failure: "; + print s; + print "\n"; + Msg.send (bio, MsgError ("Failure: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | ErrorMsg.Error => + (print "Compilation error\n"; + Msg.send (bio, MsgError "Error during configuration evaluation") + handle OpenSSL.OpenSSL _ => ()); + (cleanup (); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + fun service () = let val host = Slave.hostname () @@ -1183,43 +1230,7 @@ fun service () = val user = OpenSSL.peerCN bio val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n") val () = Domain.setUser user - - fun doIt f cleanup = - ((case f () of - (msgLocal, SOME msgRemote) => - (print msgLocal; - print "\n"; - Msg.send (bio, MsgError msgRemote)) - | (msgLocal, NONE) => - (print msgLocal; - print "\n"; - Msg.send (bio, MsgOk))) - handle e as (OpenSSL.OpenSSL s) => - (print ("OpenSSL error: " ^ s ^ "\n"); - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); - Msg.send (bio, MsgError ("OpenSSL error: " ^ s)) - handle OpenSSL.OpenSSL _ => ()) - | OS.SysErr (s, _) => - (print "System error: "; - print s; - print "\n"; - Msg.send (bio, MsgError ("System error: " ^ s)) - handle OpenSSL.OpenSSL _ => ()) - | Fail s => - (print "Failure: "; - print s; - print "\n"; - Msg.send (bio, MsgError ("Failure: " ^ s)) - handle OpenSSL.OpenSSL _ => ()) - | ErrorMsg.Error => - (print "Compilation error\n"; - Msg.send (bio, MsgError "Error during configuration evaluation") - handle OpenSSL.OpenSSL _ => ()); - (cleanup (); - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + val doIt = doIt' loop bio fun doConfig codes = let @@ -1380,89 +1391,6 @@ fun service () = SOME "Not authorized to remove users")) (fn () => ()) - | MsgCreateDbUser {dbtype, passwd} => - doIt (fn () => - case Dbms.lookup dbtype of - NONE => ("Database user creation request with unknown datatype type " ^ dbtype, - SOME ("Unknown database type " ^ dbtype)) - | SOME handler => - case #adduser handler {user = user, passwd = passwd} of - NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".", - NONE) - | SOME msg => - ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg, - SOME ("Error adding user: " ^ msg))) - (fn () => ()) - - | MsgDbPasswd {dbtype, passwd} => - doIt (fn () => - case Dbms.lookup dbtype of - NONE => ("Database passwd request with unknown datatype type " ^ dbtype, - SOME ("Unknown database type " ^ dbtype)) - | SOME handler => - case #passwd handler {user = user, passwd = passwd} of - NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".", - NONE) - | SOME msg => - ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg, - SOME ("Error adding user: " ^ msg))) - (fn () => ()) - - | MsgCreateDb {dbtype, dbname, encoding} => - doIt (fn () => - if Dbms.validDbname dbname then - case Dbms.lookup dbtype of - NONE => ("Database creation request with unknown datatype type " ^ dbtype, - SOME ("Unknown database type " ^ dbtype)) - | SOME handler => - if not (Dbms.validEncoding encoding) then - ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.", - SOME "Invalid encoding") - else - case #createdb handler {user = user, dbname = dbname, encoding = encoding} of - NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".", - NONE) - | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, - SOME ("Error creating database: " ^ msg)) - else - ("Invalid database name " ^ user ^ "_" ^ dbname, - 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 () => ()) - - | MsgGrantDb {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 #grant handler {user = user, dbname = dbname} of - NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".", - NONE) - | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, - SOME ("Error granting permissions to database: " ^ msg)) - else - ("Invalid database name " ^ user ^ "_" ^ dbname, - SOME ("Invalid database name " ^ dbname))) - (fn () => ()) - | MsgListMailboxes domain => doIt (fn () => if not (Domain.yourDomain domain) then @@ -1720,14 +1648,106 @@ fun slave () = | _ => (OpenSSL.close bio; loop ()) else - case Msg.recv bio of - SOME (MsgQuery q) => (print (describeQuery q ^ "\n"); - Msg.send (bio, answerQuery q); - ignore (OpenSSL.readChar bio); - OpenSSL.close bio; - loop ()) - | _ => (OpenSSL.close bio; - loop ()) + let + val doIt = doIt' loop bio + val user = peer + in + case Msg.recv bio of + NONE => (OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME m => + case m of + (MsgQuery q) => (print (describeQuery q ^ "\n"); + Msg.send (bio, answerQuery q); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio; + loop ()) + | MsgCreateDbUser {dbtype, passwd} => + doIt (fn () => + case Dbms.lookup dbtype of + NONE => ("Database user creation request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #adduser handler {user = user, passwd = passwd} of + NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".", + NONE) + | SOME msg => + ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg, + SOME ("Error adding user: " ^ msg))) + (fn () => ()) + + | MsgDbPasswd {dbtype, passwd} => + doIt (fn () => + case Dbms.lookup dbtype of + NONE => ("Database passwd request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #passwd handler {user = user, passwd = passwd} of + NONE => ("Changed " ^ dbtype ^ " password of user " ^ user ^ ".", + NONE) + | SOME msg => + ("Error setting " ^ dbtype ^ " password of user " ^ user ^ ": " ^ msg, + SOME ("Error adding user: " ^ msg))) + (fn () => ()) + + | MsgCreateDb {dbtype, dbname, encoding} => + doIt (fn () => + if Dbms.validDbname dbname then + case Dbms.lookup dbtype of + NONE => ("Database creation request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + if not (Dbms.validEncoding encoding) then + ("Invalid encoding " ^ valOf encoding ^ " requested for database creation.", + SOME "Invalid encoding") + else + case #createdb handler {user = user, dbname = dbname, encoding = encoding} of + NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".", + NONE) + | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, + SOME ("Error creating database: " ^ msg)) + else + ("Invalid database name " ^ user ^ "_" ^ dbname, + 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 () => ()) + + | MsgGrantDb {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 #grant handler {user = user, dbname = dbname} of + NONE => ("Grant permissions to database " ^ user ^ "_" ^ dbname ^ ".", + NONE) + | SOME msg => ("Error granting permissions to database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, + SOME ("Error granting permissions to database: " ^ msg)) + else + ("Invalid database name " ^ user ^ "_" ^ dbname, + SOME ("Invalid database name " ^ dbname))) + (fn () => ()) + | _ => (OpenSSL.close bio; + loop ()) + end end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: " ^ s ^ "\n"); OpenSSL.close bio