X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/9b8c6dc8df86d6ba1c7512cb12445912a9035a89..167cffff3b3a976d4bf454808d3054fdb323b1a1:/src/main.sml diff --git a/src/main.sml b/src/main.sml index d46deac..5783348 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 @@ -725,7 +735,9 @@ fun requestSmtpLog domain = fun requestMysqlFixperms () = 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, MsgMysqlFixperms); case Msg.recv bio of @@ -741,7 +753,7 @@ fun requestMysqlFixperms () = fun requestApt {node, pkg} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect true (context, if node = Config.masterNode then + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then dispatcher else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) @@ -767,10 +779,42 @@ fun requestApt {node, pkg} = before OpenSSL.close bio end +fun requestAptExists {node, pkg} = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then + dispatcher + else + Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + + val _ = Msg.send (bio, MsgQuery (QAptExists pkg)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgAptQuery {section,description} => (print "Package exists.\n"; + print ("Section: " ^ section ^ "\n"); + print ("Description: " ^ description ^ "\n"); + OS.Process.success) + | MsgNo => (print "Package does not exist.\n"; + OS.Process.failure + (* It might be the Wrong Thing (tm) to use MsgNo like this *)) + | MsgError s => (print ("APT existence query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun requestCron {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect true (context, if node = Config.masterNode then + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then dispatcher else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) @@ -799,7 +843,7 @@ fun requestCron {node, uname} = fun requestFtp {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect true (context, if node = Config.masterNode then + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then dispatcher else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) @@ -828,7 +872,7 @@ fun requestFtp {node, uname} = fun requestTrustedPath {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect true (context, if node = Config.masterNode then + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then dispatcher else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) @@ -857,7 +901,7 @@ fun requestTrustedPath {node, uname} = fun requestSocketPerm {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect true (context, if node = Config.masterNode then + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then dispatcher else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) @@ -888,12 +932,12 @@ fun requestSocketPerm {node, uname} = fun requestFirewall {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect true (context, if node = Config.masterNode then + val bio = OpenSSL.connect true (context, if node = Config.dispatcherName then dispatcher else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) - val _ = Msg.send (bio, MsgQuery (QFirewall uname)) + val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname})) fun loop () = case Msg.recv bio of @@ -942,6 +986,31 @@ fun requestReUsers () = OpenSSL.close bio end +fun requestFirewallRegen node = + let + val (user, context) = requestContext (fn () => ()) + val bio = OpenSSL.connect true (context, Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + (* Only supporting on slave nodes *) + + val _ = Msg.send (bio, MsgFirewallRegen) + + fun handleResult () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgOk => (print "Firewall regenerated.\n"; + OS.Process.success) + | MsgError s => (print ("Firewall regeneration failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + handleResult() + before OpenSSL.close bio + end + structure SS = StringSet fun domainList dname = @@ -1147,20 +1216,61 @@ fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) fun answerQuery q = case q of QApt pkg => if Apt.installed pkg then MsgYes else MsgNo + | QAptExists pkg => (case Apt.info pkg of + SOME {section, description} => MsgAptQuery {section = section, description = description} + | NONE => MsgNo) | QCron user => if Cron.allowed user then MsgYes else MsgNo | QFtp user => if Ftp.allowed user then MsgYes else MsgNo | QTrustedPath user => if TrustedPath.query user then MsgYes else MsgNo | QSocket user => MsgSocket (SocketPerm.query user) - | QFirewall user => MsgFirewall (Firewall.query user) + | QFirewall {node, user} => MsgFirewall (Firewall.query (node, user)) fun describeQuery q = case q of QApt pkg => "Requested installation status of package " ^ pkg + | QAptExists pkg => "Requested if package " ^ pkg ^ " exists" | QCron user => "Asked about cron permissions for user " ^ user | QFtp user => "Asked about FTP permissions for user " ^ user | QTrustedPath user => "Asked about trusted path settings for user " ^ user | QSocket user => "Asked about socket permissions for user " ^ user - | QFirewall user => "Asked about firewall rules for user " ^ user + | QFirewall {node, user} => "Asked about firewall rules on " ^ node ^ " 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 @@ -1183,43 +1293,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 +1454,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 @@ -1577,18 +1568,6 @@ fun service () = (describeQuery q, NONE))) (fn () => ()) - - | MsgMysqlFixperms => - (print "Starting mysql-fixperms\n"; - doIt (fn () => if OS.Process.isSuccess - (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then - ("Requested mysql-fixperms", - NONE) - else - ("Requested mysql-fixperms, but execution failed!", - SOME "Script execution failed.")) - (fn () => ())) - | MsgDescribe dom => doIt (fn () => if not (Domain.validDomain dom) then ("Requested description of invalid domain " ^ dom, @@ -1720,14 +1699,130 @@ 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 () => ()) + | MsgMysqlFixperms => + (print "Starting mysql-fixperms\n"; + doIt (fn () => if OS.Process.isSuccess + (OS.Process.system "/usr/bin/sudo -H /afs/hcoop.net/common/etc/scripts/mysql-grant-table-drop") then + ("Requested mysql-fixperms", + NONE) + else + ("Requested mysql-fixperms, but execution failed!", + SOME "Script execution failed.")) + (fn () => ())) + | MsgFirewallRegen => + doIt (fn () => (Acl.read Config.aclFile; + if Acl.query {user = user, class = "priv", value = "all"} then + if List.exists (fn x => x = host) Config.Firewall.firewallNodes then + if (Firewall.generateFirewallConfig (Firewall.parseRules ()) andalso Firewall.publishConfig ()) + then + ("Firewall rules regenerated.", NONE) + else + ("Rules regeneration failed!", SOME "Script execution failed.") + else ("Node not controlled by domtool firewall.", SOME (host)) + else + ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ " attempted to regenerated firewall")))) + (fn () => ()) + + | _ => (OpenSSL.close bio; + loop ()) + end end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: " ^ s ^ "\n"); OpenSSL.close bio