X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0c85f25e773621daeb1b4ecff989dfbb602a8918..201b83c73c5a4e09dcf4c3f2f9b94ded360c78c6:/src/main.sml diff --git a/src/main.sml b/src/main.sml index f3bedc2..1552791 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006-2007, Adam Chlipala + * Copyright (c) 2006-2009, Adam Chlipala + * Copyright (c) 2012,2013,2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -25,15 +26,32 @@ open Ast MsgTypes Print structure SM = StringMap fun init () = Acl.read Config.aclFile - + +fun isLib fname = OS.Path.file fname = "lib.dtl" + +fun wrapFile (fname, file) = + case (isLib fname, file) of + (true, (comment, ds, SOME e)) => + let + val (_, loc) = e + in + (comment, ds, SOME (ELocal (e, (ESkip, loc)), loc)) + end + | _ => file + fun check' G fname = let val prog = Parse.parse fname + val prog = wrapFile (fname, prog) in if !ErrorMsg.anyErrors then G else - Tycheck.checkFile G (Defaults.tInit ()) prog + (if isLib fname then + () + else + Option.app (Unused.check G) (#3 prog); + Tycheck.checkFile G (Defaults.tInit prog) prog) end fun basis () = @@ -63,12 +81,12 @@ fun basis () = before Tycheck.disallowExterns ()) end -fun check fname = +(* val b = basis () *) + +fun check G fname = let val _ = ErrorMsg.reset () val _ = Env.preTycheck () - - val b = basis () in if !ErrorMsg.anyErrors then raise ErrorMsg.Error @@ -77,17 +95,22 @@ fun check fname = val _ = Tycheck.disallowExterns () val _ = ErrorMsg.reset () val prog = Parse.parse fname + val prog = wrapFile (fname, prog) in if !ErrorMsg.anyErrors then raise ErrorMsg.Error else let - val G' = Tycheck.checkFile b (Defaults.tInit ()) prog + val G' = Tycheck.checkFile G (Defaults.tInit prog) prog in if !ErrorMsg.anyErrors then raise ErrorMsg.Error else - (G', #3 prog) + (if isLib fname then + () + else + Option.app (Unused.check G) (#3 prog); + (G', #3 prog)) end end end @@ -96,7 +119,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,12 +167,16 @@ fun checkDir dname = ()) end -fun reduce fname = +fun checkDir dname = + (setupUser (); + checkDir' dname) + +fun reduce G fname = let - val (G, body) = check fname + val (G, body) = check G fname in if !ErrorMsg.anyErrors then - NONE + (G, NONE) else case body of SOME body => @@ -143,31 +187,28 @@ fun reduce fname = [PD.string "Result:", PD.space 1, p_exp body']))*) - SOME body' + (G, SOME body') end - | _ => NONE + | _ => (G, NONE) end -fun eval fname = - case reduce fname of - (SOME body') => - if !ErrorMsg.anyErrors then - raise ErrorMsg.Error - else - Eval.exec (Defaults.eInit ()) body' - | NONE => raise ErrorMsg.Error +(*(Defaults.eInit ())*) -fun eval' fname = - case reduce fname of - (SOME body') => +fun eval G evs fname = + case reduce G fname of + (G, SOME body') => if !ErrorMsg.anyErrors then raise ErrorMsg.Error else - ignore (Eval.exec' (Defaults.eInit ()) body') - | NONE => raise ErrorMsg.Error + let + val evs' = Eval.exec' evs body' + in + (G, evs') + end + | (G, NONE) => (G, evs) val dispatcher = - Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort + Domain.nodeIp Config.dispatcherName ^ ":" ^ Int.toString Config.dispatcherPort val self = "localhost:" ^ Int.toString Config.slavePort @@ -176,26 +217,10 @@ fun context x = (OpenSSL.context false x) handle e as OpenSSL.OpenSSL s => (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n"; + print ("I looked in: " ^ #1 x ^ "\n"); 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 () @@ -209,35 +234,55 @@ fun requestContext f = (user, context) end -fun requestBio f = +fun requestBio' printErr f = let val (user, context) = requestContext f in - (user, OpenSSL.connect (context, dispatcher)) + (user, OpenSSL.connect printErr (context, dispatcher)) end -fun requestSlaveBio () = +val requestBio = requestBio' true + +fun requestSlaveBio' printErr = let val (user, context) = requestContext (fn () => ()) in - (user, OpenSSL.connect (context, self)) + (user, OpenSSL.connect printErr (context, self)) end -fun request fname = - let - val (user, bio) = requestBio (fn () => ignore (check fname)) +fun requestSlaveBio () = requestSlaveBio' true - val inf = TextIO.openIn fname +fun request (fname, libOpt) = + let + 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 => @@ -256,12 +301,12 @@ fun requestDir dname = else (print ("Can't access " ^ dname ^ ".\n"); print "Did you mean to run domtool on a specific file, instead of asking for all\n"; - print "files in your ~/domtool directory?\n"; + print "files in your ~/.domtool directory?\n"; OS.Process.exit OS.Process.failure) val _ = ErrorMsg.reset () - val (user, bio) = requestBio (fn () => checkDir dname) + val (user, bio) = requestBio (fn () => checkDir' dname) val b = basis () @@ -317,7 +362,7 @@ fun requestDir dname = fun requestPing () = let - val (_, bio) = requestBio (fn () => ()) + val (_, bio) = requestBio' false (fn () => ()) in OpenSSL.close bio; OS.Process.success @@ -330,7 +375,7 @@ fun requestShutdown () = in Msg.send (bio, MsgShutdown); case Msg.recv bio of - NONE => print "Server closed connection unexpectedly.\n" + NONE => () | SOME m => case m of MsgOk => print "Shutdown begun.\n" @@ -341,7 +386,7 @@ fun requestShutdown () = fun requestSlavePing () = let - val (_, bio) = requestSlaveBio () + val (_, bio) = requestSlaveBio' false in OpenSSL.close bio; OS.Process.success @@ -354,7 +399,7 @@ fun requestSlaveShutdown () = in Msg.send (bio, MsgShutdown); case Msg.recv bio of - NONE => print "Server closed connection unexpectedly.\n" + NONE => () | SOME m => case m of MsgOk => print "Shutdown begun.\n" @@ -491,7 +536,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 @@ -506,7 +553,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 @@ -521,9 +570,11 @@ 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, MsgCreateDbTable p); + Msg.send (bio, MsgCreateDb p); case Msg.recv bio of NONE => print "Server closed connection unexpectedly.\n" | SOME m => @@ -534,6 +585,40 @@ fun requestDbTable p = OpenSSL.close bio end +fun requestDbDrop p = + let + 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 + 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 requestDbGrant p = + let + 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 + 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 () => ()) @@ -545,7 +630,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 @@ -649,13 +734,30 @@ fun requestSmtpLog domain = OpenSSL.close bio end +fun requestMysqlFixperms () = + let + 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 + 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 () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + 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 (QApt pkg)) @@ -678,13 +780,45 @@ 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 (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + 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 (QCron uname)) @@ -710,10 +844,10 @@ fun requestCron {node, uname} = fun requestFtp {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + 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 (QFtp uname)) @@ -739,10 +873,10 @@ fun requestFtp {node, uname} = fun requestTrustedPath {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + 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 (QTrustedPath uname)) @@ -768,10 +902,10 @@ fun requestTrustedPath {node, uname} = fun requestSocketPerm {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) + 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 (QSocket uname)) @@ -799,12 +933,12 @@ fun requestSocketPerm {node, uname} = fun requestFirewall {node, uname} = let val (user, context) = requestContext (fn () => ()) - val bio = OpenSSL.connect (context, if node = Config.masterNode then - dispatcher - else - Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) - - val _ = Msg.send (bio, MsgQuery (QFirewall uname)) + 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 {node = node, user = uname})) fun loop () = case Msg.recv bio of @@ -823,25 +957,147 @@ 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 + +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 + +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 = 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 () = print "Starting regeneration....\n" + + val domainsBefore = + if tc then + SS.empty + else + 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 fun contactNode (node, ip) = - if node = Config.defaultNode then + if node = Config.dispatcherName then Domain.resetLocal () else let - val bio = OpenSSL.connect (context, - ip - ^ ":" - ^ Int.toString Config.slavePort) + val bio = OpenSSL.connect true (context, + ip + ^ ":" + ^ Int.toString Config.slavePort) in Msg.send (bio, MsgRegenerate); case Msg.recv bio of @@ -883,88 +1139,65 @@ fun regenerate context = val files = loop [] val (_, files) = Order.order (SOME b) files + + fun checker' (file, (G, evs)) = + checker G evs file 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 + (); + ignore (foldl checker' (basis (), Defaults.eInit ()) files) end + else if String.isSuffix "_admin" user then + () else - () + (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n"); + ok := false) 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 regenerate = regenerateEither false eval +val regenerateTc = regenerateEither true + (fn G => fn evs => fn file => + (#1 (check G file), evs)) - 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 +fun usersChanged () = + (Domain.onUsersChange (); + ignore (OS.Process.system Config.publish_reusers)) fun rmuser user = let @@ -975,7 +1208,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 ())) @@ -983,421 +1217,432 @@ 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 + val host = Slave.hostname () + val () = Acl.read Config.aclFile - - val context = context (Config.serverCert, - Config.serverKey, + + val context = context (Config.certDir ^ "/" ^ host ^ ".pem", + Config.keyDir ^ "/" ^ host ^ "/key.pem", Config.trustStore) val _ = Domain.set_context context val sock = OpenSSL.listen (context, Config.dispatcherPort) fun loop () = - case OpenSSL.accept sock of - NONE => () - | SOME bio => - let - 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) + (case OpenSSL.accept sock of + NONE => () + | SOME bio => + let + val user = OpenSSL.peerCN bio + val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n") + val () = Domain.setUser user + val doIt = doIt' loop bio + + fun doConfig codes = + let + val _ = print "Configuration:\n" + val _ = app (fn s => (print s; print "\n")) codes + val _ = print "\n" + + val outname = OS.FileSys.tmpName () + + fun doOne (code, (G, evs)) = + let + val outf = TextIO.openOut outname + in + TextIO.output (outf, code); + TextIO.closeOut outf; + eval G evs outname + end + in + doIt (fn () => (Env.pre (); + ignore (foldl doOne (basis (), Defaults.eInit ()) codes); + Env.post (); + Msg.send (bio, MsgOk); + ("Configuration complete.", NONE))) + (fn () => OS.FileSys.remove outname) + end + + fun checkAddr s = + case String.fields (fn ch => ch = #"@") s of + [user'] => + if user = user' then + SOME (SetSA.User s) + else + NONE + | [user', domain] => + if Domain.validEmailUser user' andalso Domain.yourDomain domain then + SOME (SetSA.Email s) + else + NONE + | _ => NONE + + fun cmdLoop () = + case Msg.recv bio of + NONE => (OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | SOME m => + case m of + MsgConfig code => doConfig [code] + | MsgMultiConfig codes => doConfig codes + + | MsgShutdown => + if Acl.query {user = user, class = "priv", value = "all"} + orelse Acl.query {user = user, class = "priv", value = "shutdown"} then + print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n") + else + (print "Unauthorized shutdown command!\n"; + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgGrant acl => + doIt (fn () => + 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 + ("Unauthorized user asked to grant a permission!", + SOME "Not authorized to grant privileges")) + (fn () => ()) + + | MsgRevoke acl => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (Acl.revoke acl; + Acl.write Config.aclFile; + ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".", + NONE)) + else + ("Unauthorized user asked to revoke a permission!", + SOME "Not authorized to revoke privileges")) + (fn () => ()) + + | MsgListPerms user => + doIt (fn () => + (Msg.send (bio, MsgPerms (Acl.queryAll user)); + ("Sent permission list for user " ^ user ^ ".", + NONE))) + (fn () => ()) + + | MsgWhoHas perm => + doIt (fn () => + (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); + ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".", + NONE))) + (fn () => ()) + + | MsgRmdom doms => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} + orelse List.all (fn dom => Domain.validDomain dom + andalso Acl.queryDomain {user = user, domain = dom}) doms then + (Domain.rmdom doms; + (*app (fn dom => + Acl.revokeFromAll {class = "domain", value = dom}) doms; + Acl.write Config.aclFile;*) + ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".", + NONE)) + else + ("Unauthorized user asked to remove a domain!", + SOME "Not authorized to remove that domain")) + (fn () => ()) + + | MsgRegenerate => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (if regenerate context then + ("Regenerated all configuration.", + NONE) + else + ("Error regenerating configuration!", + SOME "Error regenerating configuration! Consult /var/log/domtool.log.")) + else + ("Unauthorized user asked to regenerate!", + SOME "Not authorized to regenerate")) + (fn () => ()) + + | MsgRegenerateTc => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (if regenerateTc context then + ("Checked all configuration.", + NONE) + else + ("Found a compilation error!", + SOME "Found a compilation error! Consult /var/log/domtool.log.")) + else + ("Unauthorized user asked to regenerate -tc!", + SOME "Not authorized to regenerate -tc")) + (fn () => ()) + + | MsgRmuser user' => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (rmuser user'; + Acl.write Config.aclFile; + ("Removed user " ^ user' ^ ".", + NONE)) + else + ("Unauthorized user asked to remove a user!", + SOME "Not authorized to remove users")) + (fn () => ()) + + | MsgListMailboxes domain => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to list mailboxes for " ^ domain, + SOME "You're not authorized to configure that domain.") + else + case Vmail.list domain of + Vmail.Listing users => (Msg.send (bio, MsgMailboxes users); + ("Sent mailbox list for " ^ domain, + NONE)) + | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to add a mailbox to " ^ domain, + SOME "You're not authorized to configure that domain.") + else if not (Domain.validEmailUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph passwd) then + ("Invalid password", + 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. (" + ^ mailbox ^ ")")) + else + case Vmail.add {requester = user, + domain = domain, user = emailUser, + passwd = passwd, mailbox = mailbox} of + NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox, + NONE) + | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgPasswdMailbox {domain, user = emailUser, passwd} => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to change password of a mailbox for " ^ domain, + SOME "You're not authorized to configure that domain.") + else if not (Domain.validEmailUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph passwd) then + ("Invalid password", + SOME "Invalid password; may only contain printable, non-space characters") + else + case Vmail.passwd {domain = domain, user = emailUser, + passwd = passwd} of + NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain, + NONE) + | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgRmMailbox {domain, user = emailUser} => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("User wasn't authorized to change password of a mailbox for " ^ domain, + SOME "You're not authorized to configure that domain.") + else if not (Domain.validEmailUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else + case Vmail.rm {domain = domain, user = emailUser} of + NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain, + NONE) + | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgSaQuery addr => + doIt (fn () => + case checkAddr addr of + NONE => ("User tried to query SA filtering for " ^ addr, + SOME "You aren't allowed to configure SA filtering for that recipient.") + | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr')); + ("Queried SA filtering status for " ^ addr, + NONE))) + (fn () => ()) + + | MsgSaSet (addr, b) => + doIt (fn () => + case checkAddr addr of + NONE => ("User tried to set SA filtering for " ^ addr, + SOME "You aren't allowed to configure SA filtering for that recipient.") + | SOME addr' => (SetSA.set (addr', b); + Msg.send (bio, MsgOk); + ("Set SA filtering status for " ^ addr ^ " to " + ^ (if b then "ON" else "OFF"), + NONE))) + (fn () => ()) + + | MsgSmtpLogReq domain => + doIt (fn () => + if not (Domain.yourDomain domain) then + ("Unauthorized user tried to request SMTP logs for " ^ domain, + SOME "You aren't authorized to configure that domain.") + else + (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line)) + domain; + ("Requested SMTP logs for " ^ domain, + NONE))) + (fn () => ()) + + | MsgQuery q => + doIt (fn () => (Msg.send (bio, answerQuery q); + (describeQuery q, + NONE))) + (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 () => ()) + + | 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")) + (fn () => ()) + in + cmdLoop () + end + handle e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) - - fun doConfig codes = - let - val _ = print "Configuration:\n" - val _ = app (fn s => (print s; print "\n")) codes - val _ = print "\n" - - val outname = OS.FileSys.tmpName () - - fun doOne code = - let - val outf = TextIO.openOut outname - in - TextIO.output (outf, code); - TextIO.closeOut outf; - eval' outname - end - in - doIt (fn () => (Env.pre (); - app doOne codes; - Env.post (); - Msg.send (bio, MsgOk); - ("Configuration complete.", NONE))) - (fn () => OS.FileSys.remove outname) - end - - fun checkAddr s = - case String.fields (fn ch => ch = #"@") s of - [user'] => - if user = user' then - SOME (SetSA.User s) - else - NONE - | [user', domain] => - if Domain.validEmailUser user' andalso Domain.yourDomain domain then - SOME (SetSA.Email s) - else - NONE - | _ => NONE - - fun cmdLoop () = - case Msg.recv bio of - NONE => (OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | SOME m => - case m of - MsgConfig code => doConfig [code] - | MsgMultiConfig codes => doConfig codes - - | MsgShutdown => - if Acl.query {user = user, class = "priv", value = "all"} - orelse Acl.query {user = user, class = "priv", value = "shutdown"} then - print ("Domtool dispatcher shutting down at " ^ now () ^ "\n\n") - else - (print "Unauthorized shutdown command!\n"; - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - - | MsgGrant acl => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "all"} then - (Acl.grant acl; - Acl.write Config.aclFile; - ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".", - NONE)) - else - ("Unauthorized user asked to grant a permission!", - SOME "Not authorized to grant privileges")) - (fn () => ()) - - | MsgRevoke acl => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "all"} then - (Acl.revoke acl; - Acl.write Config.aclFile; - ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".", - NONE)) - else - ("Unauthorized user asked to revoke a permission!", - SOME "Not authorized to revoke privileges")) - (fn () => ()) - - | MsgListPerms user => - doIt (fn () => - (Msg.send (bio, MsgPerms (Acl.queryAll user)); - ("Sent permission list for user " ^ user ^ ".", - NONE))) - (fn () => ()) - - | MsgWhoHas perm => - doIt (fn () => - (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); - ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".", - NONE))) - (fn () => ()) - - | MsgRmdom doms => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "all"} - orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then - (Domain.rmdom doms; - app (fn dom => - Acl.revokeFromAll {class = "domain", value = dom}) doms; - Acl.write Config.aclFile; - ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".", - NONE)) - else - ("Unauthorized user asked to remove a domain!", - SOME "Not authorized to remove that domain")) - (fn () => ()) - - | MsgRegenerate => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "regen"} - orelse Acl.query {user = user, class = "priv", value = "all"} then - (if regenerate context then - ("Regenerated all configuration.", - NONE) - else - ("Error regenerating configuration!", - SOME "Error regenerating configuration! Consult /var/log/domtool.log.")) - else - ("Unauthorized user asked to regenerate!", - SOME "Not authorized to regenerate")) - (fn () => ()) - - | MsgRegenerateTc => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "regen"} - orelse Acl.query {user = user, class = "priv", value = "all"} then - (if regenerateTc context then - ("Checked all configuration.", - NONE) - else - ("Found a compilation error!", - SOME "Found a compilation error! Consult /var/log/domtool.log.")) - else - ("Unauthorized user asked to regenerate -tc!", - SOME "Not authorized to regenerate -tc")) - (fn () => ()) - - | MsgRmuser user' => - doIt (fn () => - if Acl.query {user = user, class = "priv", value = "all"} then - (rmuser user'; - Acl.write Config.aclFile; - ("Removed user " ^ user' ^ ".", - NONE)) - else - ("Unauthorized user asked to remove a user!", - 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 () => ()) - - | MsgCreateDbTable {dbtype, dbname} => - 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 => - case #createdb handler {user = user, dbname = dbname} 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 () => ()) - - | MsgListMailboxes domain => - doIt (fn () => - if not (Domain.yourDomain domain) then - ("User wasn't authorized to list mailboxes for " ^ domain, - SOME "You're not authorized to configure that domain.") - else - case Vmail.list domain of - Vmail.Listing users => (Msg.send (bio, MsgMailboxes users); - ("Sent mailbox list for " ^ domain, - NONE)) - | Vmail.Error msg => ("Error listing mailboxes for " ^ domain ^ ": " ^ msg, - SOME msg)) - (fn () => ()) - - | MsgNewMailbox {domain, user = emailUser, passwd, mailbox} => - doIt (fn () => - if not (Domain.yourDomain domain) then - ("User wasn't authorized to add a mailbox to " ^ domain, - SOME "You're not authorized to configure that domain.") - else if not (Domain.validEmailUser emailUser) then - ("Invalid e-mail username " ^ emailUser, - SOME "Invalid e-mail username") - else if not (CharVector.all Char.isGraph passwd) then - ("Invalid password", - 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.") - else - case Vmail.add {requester = user, - domain = domain, user = emailUser, - passwd = passwd, mailbox = mailbox} of - NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox, - NONE) - | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, - SOME msg)) - (fn () => ()) - - | MsgPasswdMailbox {domain, user = emailUser, passwd} => - doIt (fn () => - if not (Domain.yourDomain domain) then - ("User wasn't authorized to change password of a mailbox for " ^ domain, - SOME "You're not authorized to configure that domain.") - else if not (Domain.validEmailUser emailUser) then - ("Invalid e-mail username " ^ emailUser, - SOME "Invalid e-mail username") - else if not (CharVector.all Char.isGraph passwd) then - ("Invalid password", - SOME "Invalid password; may only contain printable, non-space characters") - else - case Vmail.passwd {domain = domain, user = emailUser, - passwd = passwd} of - NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain, - NONE) - | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, - SOME msg)) - (fn () => ()) - - | MsgRmMailbox {domain, user = emailUser} => - doIt (fn () => - if not (Domain.yourDomain domain) then - ("User wasn't authorized to change password of a mailbox for " ^ domain, - SOME "You're not authorized to configure that domain.") - else if not (Domain.validEmailUser emailUser) then - ("Invalid e-mail username " ^ emailUser, - SOME "Invalid e-mail username") - else - case Vmail.rm {domain = domain, user = emailUser} of - NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain, - NONE) - | SOME msg => ("Error deleting mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, - SOME msg)) - (fn () => ()) - - | MsgSaQuery addr => - doIt (fn () => - case checkAddr addr of - NONE => ("User tried to query SA filtering for " ^ addr, - SOME "You aren't allowed to configure SA filtering for that recipient.") - | SOME addr' => (Msg.send (bio, MsgSaStatus (SetSA.query addr')); - ("Queried SA filtering status for " ^ addr, - NONE))) - (fn () => ()) - - | MsgSaSet (addr, b) => - doIt (fn () => - case checkAddr addr of - NONE => ("User tried to set SA filtering for " ^ addr, - SOME "You aren't allowed to configure SA filtering for that recipient.") - | SOME addr' => (SetSA.set (addr', b); - Msg.send (bio, MsgOk); - ("Set SA filtering status for " ^ addr ^ " to " - ^ (if b then "ON" else "OFF"), - NONE))) - (fn () => ()) - - | MsgSmtpLogReq domain => - doIt (fn () => - if not (Domain.yourDomain domain) then - ("Unauthorized user tried to request SMTP logs for " ^ domain, - SOME "You aren't authorized to configure that domain.") - else - (SmtpLog.search (fn line => Msg.send (bio, MsgSmtpLogRes line)) - domain; - ("Requested SMTP logs for " ^ domain, - NONE))) - (fn () => ()) - - | MsgQuery q => - doIt (fn () => (Msg.send (bio, answerQuery q); - (describeQuery q, - NONE))) - (fn () => ()) - - | _ => - doIt (fn () => ("Unexpected command", - SOME "Unexpected command")) - (fn () => ()) - in - cmdLoop () - end - handle e as (OpenSSL.OpenSSL s) => - (print ("OpenSSL error: " ^ s ^ "\n"); - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | OS.SysErr (s, _) => - (print ("System error: " ^ s ^ "\n"); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | IO.Io {name, function, cause} => - (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | e => - (print "Unknown exception in main loop!\n"; - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) + | OS.SysErr (s, _) => + (print ("System error: " ^ s ^ "\n"); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ()) + | IO.Io {name, function, cause} => + (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); + 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); + OpenSSL.close bio + handle OpenSSL.OpenSSL _ => (); + loop ())) + handle e as (OpenSSL.OpenSSL s) => + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + loop ()) + | OS.SysErr (s, _) => + (print ("System error: " ^ s ^ "\n"); + loop ()) + | IO.Io {name, function, cause} => + (print ("IO error: " ^ function ^ " for " ^ name ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory cause); + loop ()) + | e => + (print "Unknown exception in main loop!\n"; + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + loop ()) in print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; @@ -1418,58 +1663,196 @@ 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 + (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 + let + val doIt = doIt' loop bio + val user = peer + in + case Msg.recv bio of + NONE => (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 ()) + 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 + 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