X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/b21491def4a9ec982a4de1525e9bc8f43c9da920..ebb51f80568cc35cf3cd2f99a31a28f72526798d:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 9bc87cd..50f5e97 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,16 +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 - (Option.app (Unused.check G) (#3 prog); - Tycheck.checkFile G (Defaults.tInit ()) prog) + (if isLib fname then + () + else + Option.app (Unused.check G) (#3 prog); + Tycheck.checkFile G prog) end fun basis () = @@ -64,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 @@ -78,17 +95,21 @@ 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 prog in if !ErrorMsg.anyErrors then raise ErrorMsg.Error else - (Option.app (Unused.check b) (#3 prog); + (if isLib fname then + () + else + Option.app (Unused.check G) (#3 prog); (G', #3 prog)) end end @@ -150,12 +171,12 @@ fun checkDir dname = (setupUser (); checkDir' dname) -fun reduce fname = +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 => @@ -166,31 +187,30 @@ 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 => () +(*(Defaults.eInit ())*) -fun eval' fname = - case reduce fname of - (SOME body') => +val toplevel = Env.initialDynEnvVals Reduce.reduceExp + +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 => () + let + val evs' = Eval.exec' (toplevel G, 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 @@ -216,35 +236,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 => @@ -290,7 +330,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 () @@ -324,7 +364,7 @@ fun requestDir dname = fun requestPing () = let - val (_, bio) = requestBio (fn () => ()) + val (_, bio) = requestBio' false (fn () => ()) in OpenSSL.close bio; OS.Process.success @@ -337,7 +377,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" @@ -348,7 +388,7 @@ fun requestShutdown () = fun requestSlavePing () = let - val (_, bio) = requestSlaveBio () + val (_, bio) = requestSlaveBio' false in OpenSSL.close bio; OS.Process.success @@ -361,7 +401,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" @@ -498,7 +538,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 @@ -513,7 +555,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 @@ -528,7 +572,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 @@ -543,7 +589,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 @@ -558,7 +606,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 @@ -688,7 +738,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 @@ -704,10 +756,10 @@ fun requestMysqlFixperms () = 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)) @@ -730,13 +782,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)) @@ -762,10 +846,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)) @@ -791,10 +875,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)) @@ -820,10 +904,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)) @@ -851,12 +935,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 @@ -890,6 +974,46 @@ 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 + +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 = @@ -969,13 +1093,13 @@ fun regenerateEither tc checker context = 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 @@ -1017,6 +1141,9 @@ fun regenerateEither tc checker 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 (); @@ -1024,10 +1151,15 @@ fun regenerateEither tc checker context = ok := false) else (); - app checker files + let val basis' = basis () in + ignore (foldl checker' (basis', SM.empty) files) + end end + else if String.isSuffix "_admin" user then + () else - () + (print ("Couldn't access " ^ user ^ "'s ~/.domtool directory.\n"); + ok := false) end handle IO.Io {name, function, ...} => (print ("IO error processing user " ^ user ^ ": " ^ function ^ ": " ^ name ^ "\n"); @@ -1062,8 +1194,14 @@ fun regenerateEither tc checker context = !ok end -val regenerate = regenerateEither false eval' -val regenerateTc = regenerateEither true (ignore o check) +val regenerate = regenerateEither false eval +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 @@ -1074,7 +1212,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 ())) @@ -1082,27 +1221,70 @@ 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 @@ -1116,43 +1298,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 @@ -1162,17 +1308,19 @@ fun service () = val outname = OS.FileSys.tmpName () - fun doOne code = + fun doOne (code, (G, evs)) = let val outf = TextIO.openOut outname in TextIO.output (outf, code); TextIO.closeOut outf; - eval' outname + eval G evs outname end in doIt (fn () => (Env.pre (); - app doOne codes; + let val basis' = basis () in + ignore (foldl doOne (basis', SM.empty) codes) + end; Env.post (); Msg.send (bio, MsgOk); ("Configuration complete.", NONE))) @@ -1218,6 +1366,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 @@ -1254,11 +1406,12 @@ fun service () = | 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 + orelse List.all (fn dom => Domain.validDomain dom + andalso Acl.queryDomain {user = user, domain = dom}) doms then (Domain.rmdom doms; - app (fn dom => + (*app (fn dom => Acl.revokeFromAll {class = "domain", value = dom}) doms; - Acl.write Config.aclFile; + Acl.write Config.aclFile;*) ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".", NONE)) else @@ -1308,85 +1461,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} => - 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 () => ()) - - | 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 @@ -1478,6 +1552,7 @@ fun service () = 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); + SetSA.rebuild (); Msg.send (bio, MsgOk); ("Set SA filtering status for " ^ addr ^ " to " ^ (if b then "ON" else "OFF"), @@ -1501,17 +1576,6 @@ fun service () = (describeQuery q, 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, @@ -1526,6 +1590,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")) @@ -1596,69 +1670,200 @@ 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")) + | MsgSaChanged => (if Slave.shell [Config.SpamAssassin.postReload] then + Msg.send (bio, MsgOk) + else + Msg.send (bio, MsgError "Error reloading SpamAssassin addresses")) + | _ => (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 ()) - | 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 ()) + 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