X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/504618b9ccf4bdbd8b3e27f799770b16c6358a71..1638d5a206cd79e9619f0d3334fed29eaddc6b51:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 7473fb6..fc8df17 100644 --- a/src/main.sml +++ b/src/main.sml @@ -96,7 +96,24 @@ fun notTmp s = String.sub (s, 0) <> #"." andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") s -fun checkDir dname = +fun setupUser () = + let + val user = + case Posix.ProcEnv.getenv "DOMTOOL_USER" of + NONE => + let + val uid = Posix.ProcEnv.getuid () + in + Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + end + | SOME user => user + in + Acl.read Config.aclFile; + Domain.setUser user; + user + end + +fun checkDir' dname = let val b = basis () @@ -127,6 +144,10 @@ fun checkDir dname = ()) end +fun checkDir dname = + (setupUser (); + checkDir' dname) + fun reduce fname = let val (G, body) = check fname @@ -180,23 +201,6 @@ fun context x = print ("Additional information: " ^ s ^ "\n"); raise e) -fun setupUser () = - let - val user = - case Posix.ProcEnv.getenv "DOMTOOL_USER" of - NONE => - let - val uid = Posix.ProcEnv.getuid () - in - Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) - end - | SOME user => user - in - Acl.read Config.aclFile; - Domain.setUser user; - user - end - fun requestContext f = let val user = setupUser () @@ -262,7 +266,7 @@ fun requestDir dname = val _ = ErrorMsg.reset () - val (user, bio) = requestBio (fn () => checkDir dname) + val (user, bio) = requestBio (fn () => checkDir' dname) val b = basis () @@ -524,7 +528,7 @@ fun requestDbTable p = let val (user, bio) = requestBio (fn () => ()) in - Msg.send (bio, MsgCreateDbTable p); + Msg.send (bio, MsgCreateDb p); case Msg.recv bio of NONE => print "Server closed connection unexpectedly.\n" | SOME m => @@ -550,6 +554,21 @@ fun requestDbDrop p = OpenSSL.close bio end +fun requestDbGrant p = + let + val (user, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgGrantDb p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("You've been granted all allowed privileges to database " ^ user ^ "_" ^ #dbname p ^ ".\n") + | MsgError s => print ("Grant failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestListMailboxes domain = let val (_, bio) = requestBio (fn () => ()) @@ -561,7 +580,7 @@ fun requestListMailboxes domain = case m of MsgMailboxes users => (Msg.send (bio, MsgOk); Vmail.Listing users) - | MsgError s => Vmail.Error ("Creation failed: " ^ s) + | MsgError s => Vmail.Error ("Listing failed: " ^ s) | _ => Vmail.Error "Unexpected server reply.") before OpenSSL.close bio end @@ -665,6 +684,21 @@ fun requestSmtpLog domain = OpenSSL.close bio end +fun requestMysqlFixperms () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgMysqlFixperms); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Permissions granted.\n" + | MsgError s => print ("Failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestApt {node, pkg} = let val (user, context) = requestContext (fn () => ()) @@ -839,14 +873,90 @@ fun requestFirewall {node, uname} = before OpenSSL.close bio end -fun regenerate context = +fun requestDescribe dom = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgDescribe dom); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgDescription s => print s + | MsgError s => print ("Description failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +structure SS = StringSet + +fun domainList dname = + let + val dir = Posix.FileSys.opendir dname + + fun visitNode dset = + case Posix.FileSys.readdir dir of + NONE => dset + | SOME node => + let + val path = OS.Path.joinDirFile {dir = dname, + file = node} + + fun visitDomains (path, bfor, dset) = + let + val dir = Posix.FileSys.opendir path + + fun loop dset = + case Posix.FileSys.readdir dir of + NONE => dset + | SOME dname => + let + val path = OS.Path.joinDirFile {dir = path, + file = dname} + in + if Posix.FileSys.ST.isDir (Posix.FileSys.stat path) then + let + val bfor = dname :: bfor + in + loop (visitDomains (path, bfor, + SS.add (dset, + String.concatWith "." bfor))) + end + else + loop dset + end + in + loop dset + before Posix.FileSys.closedir dir + end + in + visitNode (visitDomains (path, [], dset)) + end + in + visitNode SS.empty + before Posix.FileSys.closedir dir + end + +fun regenerateEither tc checker context = let + val domainsBefore = domainList Config.resultRoot + + fun ifReal f = + if tc then + () + else + f () + val _ = ErrorMsg.reset () val b = basis () val () = Tycheck.disallowExterns () - val () = Domain.resetGlobal () + val () = ifReal (fn () => + (ignore (OS.Process.system ("rm -rf " ^ Config.oldResultRoot ^ "/*")); + ignore (OS.Process.system ("cp -r " ^ Config.resultRoot + ^ "/* " ^ Config.oldResultRoot ^ "/")); + Domain.resetGlobal ())) val ok = ref true @@ -902,85 +1012,49 @@ fun regenerate context = in if !ErrorMsg.anyErrors then (ErrorMsg.reset (); - print ("User " ^ user ^ "'s configuration has errors!\n")) + print ("User " ^ user ^ "'s configuration has errors!\n"); + ok := false) else - app eval' files + app checker files end else () end - handle IO.Io _ => () - | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n"); - ok := false) + handle IO.Io {name, function, ...} => + (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n"); + ok := false) + | exn as OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n"); + ok := false) | ErrorMsg.Error => (ErrorMsg.reset (); print ("User " ^ user ^ " had a compilation error.\n"); ok := false) | _ => (print "Unknown exception during regeneration!\n"; ok := false) in - app contactNode Config.nodeIps; - Env.pre (); + ifReal (fn () => (app contactNode Config.nodeIps; + Env.pre ())); app doUser (Acl.users ()); - Env.post (); + ifReal (fn () => + let + val domainsAfter = domainList Config.resultRoot + val domainsGone = SS.difference (domainsBefore, domainsAfter) + in + if SS.isEmpty domainsGone then + () + else + (print "Domains to kill:"; + SS.app (fn s => (print " "; print s)) domainsGone; + print "\n"; + + Domain.rmdom' Config.oldResultRoot (SS.listItems domainsGone)); + + Env.post () + end); !ok end -fun regenerateTc context = - let - val _ = ErrorMsg.reset () - - val b = basis () - val () = Tycheck.disallowExterns () - - val () = Domain.resetGlobal () - - val ok = ref true - - fun doUser user = - let - val _ = Domain.setUser user - val _ = ErrorMsg.reset () - - val dname = Config.domtoolDir user - in - if Posix.FileSys.access (dname, []) then - let - val dir = Posix.FileSys.opendir dname - - fun loop files = - case Posix.FileSys.readdir dir of - NONE => (Posix.FileSys.closedir dir; - files) - | SOME fname => - if notTmp fname then - loop (OS.Path.joinDirFile {dir = dname, - file = fname} - :: files) - else - loop files - - val files = loop [] - val (_, files) = Order.order (SOME b) files - in - if !ErrorMsg.anyErrors then - (ErrorMsg.reset (); - print ("User " ^ user ^ "'s configuration has errors!\n"); - ok := false) - else - app (ignore o check) files - end - else - () - end - handle IO.Io _ => () - | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") - | ErrorMsg.Error => (ErrorMsg.reset (); - print ("User " ^ user ^ " had a compilation error.\n")) - | _ => print "Unknown exception during -tc regeneration!\n" - in - app doUser (Acl.users ()); - !ok - end +val regenerate = regenerateEither false eval' +val regenerateTc = regenerateEither true (ignore o check) fun rmuser user = let @@ -1253,7 +1327,7 @@ fun service () = SOME ("Error adding user: " ^ msg))) (fn () => ()) - | MsgCreateDbTable {dbtype, dbname} => + | MsgCreateDb {dbtype, dbname} => doIt (fn () => if Dbms.validDbname dbname then case Dbms.lookup dbtype of @@ -1287,6 +1361,23 @@ fun service () = 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 @@ -1314,7 +1405,8 @@ fun service () = SOME "Invalid password; may only contain printable, non-space characters") else if not (Domain.yourPath mailbox) then ("User wasn't authorized to add a mailbox at " ^ mailbox, - SOME "You're not authorized to use that mailbox location.") + SOME ("You're not authorized to use that mailbox location. (" + ^ mailbox ^ ")")) else case Vmail.add {requester = user, domain = domain, user = emailUser, @@ -1401,6 +1493,30 @@ fun service () = NONE))) (fn () => ()) + | MsgMysqlFixperms => + 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, + SOME "Invalid domain name") + else if not (Domain.yourDomain dom + orelse Acl.query {user = user, class = "priv", value = "all"}) then + ("Requested description of " ^ dom ^ ", but not allowed access", + SOME "Access denied") + else + (Msg.send (bio, MsgDescription (Domain.describe dom)); + ("Sent description of domain " ^ dom, + NONE))) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command")) @@ -1425,6 +1541,11 @@ fun service () = OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) + | OS.Path.InvalidArc => + (print "Invalid arc\n"; + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) | e => (print "Unknown exception in main loop!\n"; app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e);