X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/edf5dcbb8691753a607241508652acd680897949..9b8c6dc8df86d6ba1c7512cb12445912a9035a89:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 62af91b..d46deac 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1,5 +1,5 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006-2007, Adam Chlipala + * Copyright (c) 2006-2009, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -251,21 +251,37 @@ fun requestSlaveBio' printErr = fun requestSlaveBio () = requestSlaveBio' true -fun request fname = +fun request (fname, libOpt) = let - val (user, bio) = requestBio (fn () => ignore (check (basis ()) fname)) - - val inf = TextIO.openIn fname + val (user, bio) = requestBio (fn () => + let + val env = basis () + val env = case libOpt of + NONE => env + | SOME lib => #1 (check env lib) + in + ignore (check env fname) + end) + + fun readFile fname = + let + val inf = TextIO.openIn fname - fun loop lines = - case TextIO.inputLine inf of - NONE => String.concat (List.rev lines) - | SOME line => loop (line :: lines) + fun loop lines = + case TextIO.inputLine inf of + NONE => String.concat (rev lines) + | SOME line => loop (line :: lines) + in + loop [] + before TextIO.closeIn inf + end - val code = loop [] + val code = readFile fname + val msg = case libOpt of + NONE => MsgConfig code + | SOME fname' => MsgMultiConfig [readFile fname', code] in - TextIO.closeIn inf; - Msg.send (bio, MsgConfig code); + Msg.send (bio, msg); case Msg.recv bio of NONE => print "Server closed connection unexpectedly.\n" | SOME m => @@ -311,7 +327,7 @@ fun requestDir dname = val (_, files) = Order.order (SOME b) files val _ = if !ErrorMsg.anyErrors then - (print "J\n";raise ErrorMsg.Error) + raise ErrorMsg.Error else () @@ -911,6 +927,21 @@ fun requestDescribe dom = OpenSSL.close bio end +fun requestReUsers () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgReUsers); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Callbacks run.\n" + | MsgError s => print ("Failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + structure SS = StringSet fun domainList dname = @@ -1094,6 +1125,10 @@ val regenerateTc = regenerateEither true (fn G => fn evs => fn file => (#1 (check G file), evs)) +fun usersChanged () = + (Domain.onUsersChange (); + ignore (OS.Process.system Config.publish_reusers)) + fun rmuser user = let val doms = Acl.class {user = user, class = "domain"} @@ -1103,7 +1138,8 @@ fun rmuser user = | _ => false) (StringSet.listItems doms) in Acl.rmuser user; - Domain.rmdom doms + Domain.rmdom doms; + usersChanged () end fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) @@ -1249,6 +1285,10 @@ fun service () = if Acl.query {user = user, class = "priv", value = "all"} then (Acl.grant acl; Acl.write Config.aclFile; + if #class acl = "user" then + usersChanged () + else + (); ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".", NONE)) else @@ -1539,14 +1579,15 @@ fun service () = (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) + (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 () => ()) + (fn () => ())) | MsgDescribe dom => doIt (fn () => if not (Domain.validDomain dom) then @@ -1562,6 +1603,16 @@ fun service () = NONE))) (fn () => ()) + | MsgReUsers => + doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (usersChanged (); + ("Users change callbacks run", NONE)) + else + ("Unauthorized user asked to reusers!", + SOME "You aren't authorized to regenerate files.")) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command")) @@ -1632,69 +1683,80 @@ fun slave () = val _ = print ("Slave server starting at " ^ now () ^ "\n") fun loop () = - case OpenSSL.accept sock of - NONE => () - | SOME bio => - let - val peer = OpenSSL.peerCN bio - val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n") - in - if peer = Config.dispatcherName then let - fun loop' files = - case Msg.recv bio of - NONE => print "Dispatcher closed connection unexpectedly\n" - | SOME m => - case m of - MsgFile file => loop' (file :: files) - | MsgDoFiles => (Slave.handleChanges files; - Msg.send (bio, MsgOk)) - | MsgRegenerate => (Domain.resetLocal (); - Msg.send (bio, MsgOk)) - | _ => (print "Dispatcher sent unexpected command\n"; - Msg.send (bio, MsgError "Unexpected command")) - in - loop' []; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio; - loop () - end - else if peer = "domtool" then - case Msg.recv bio of - SOME MsgShutdown => (OpenSSL.close bio; - print ("Shutting down at " ^ now () ^ "\n\n")) - | _ => (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 ()) - end handle OpenSSL.OpenSSL s => - (print ("OpenSSL error: " ^ s ^ "\n"); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | e as OS.SysErr (s, _) => - (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e); - print ("System error: "^ s ^ "\n"); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | IO.Io {function, name, ...} => - (print ("IO error: " ^ function ^ ": " ^ name ^ "\n"); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | e => - (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e); - print "Uncaught exception!\n"; - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) + (case OpenSSL.accept sock of + NONE => () + | SOME bio => + let + val peer = OpenSSL.peerCN bio + val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n") + in + if peer = Config.dispatcherName then let + fun loop' files = + case Msg.recv bio of + NONE => print "Dispatcher closed connection unexpectedly\n" + | SOME m => + case m of + MsgFile file => loop' (file :: files) + | MsgDoFiles => (Slave.handleChanges files; + Msg.send (bio, MsgOk)) + | MsgRegenerate => (Domain.resetLocal (); + Msg.send (bio, MsgOk)) + | MsgVmailChanged => (if Vmail.doChanged () then + Msg.send (bio, MsgOk) + else + Msg.send (bio, MsgError "userdb update failed")) + | _ => (print "Dispatcher sent unexpected command\n"; + Msg.send (bio, MsgError "Unexpected command")) + in + loop' []; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio; + loop () + end + else if peer = "domtool" then + case Msg.recv bio of + SOME MsgShutdown => (OpenSSL.close bio; + print ("Shutting down at " ^ now () ^ "\n\n")) + | _ => (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 ()) + end handle OpenSSL.OpenSSL s => + (print ("OpenSSL error: " ^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | e as OS.SysErr (s, _) => + (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e); + print ("System error: "^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | IO.Io {function, name, ...} => + (print ("IO error: " ^ function ^ ": " ^ name ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | e => + (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e); + print "Uncaught exception!\n"; + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ())) + handle OpenSSL.OpenSSL s => + (print ("OpenSSL error: " ^ s ^ "\n"); + loop ()) + | e => + (app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory e); + print "Uncaught exception!\n"; + loop ()) in loop (); OpenSSL.shutdown sock