X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/281a6135805f7c5647a8e3791f76f4f143559d0c..53043cda16a4efd64705d7fc5ca188f67c92c84f:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 9463ce2..fcbcafe 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) * 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 @@ -50,11 +51,12 @@ fun check' G fname = () else Option.app (Unused.check G) (#3 prog); - Tycheck.checkFile G (Defaults.tInit prog) prog) + Tycheck.checkFile G prog) end fun basis () = let + val _ = ErrorMsg.reset () val dir = Posix.FileSys.opendir Config.libRoot fun loop files = @@ -100,7 +102,7 @@ fun check G fname = raise ErrorMsg.Error else let - val G' = Tycheck.checkFile G (Defaults.tInit prog) prog + val G' = Tycheck.checkFile G prog in if !ErrorMsg.anyErrors then raise ErrorMsg.Error @@ -193,6 +195,8 @@ fun reduce G fname = (*(Defaults.eInit ())*) +val toplevel = Env.initialDynEnvVals Reduce.reduceExp + fun eval G evs fname = case reduce G fname of (G, SOME body') => @@ -200,14 +204,14 @@ fun eval G evs fname = raise ErrorMsg.Error else let - val evs' = Eval.exec' evs body' + 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 @@ -664,6 +668,22 @@ fun requestPasswdMailbox p = OpenSSL.close bio end +fun requestPortalPasswdMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + (Msg.send (bio, MsgPortalPasswdMailbox p); + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; OS.Process.failure) + | SOME m => + case m of + MsgOk => (print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n"); + OS.Process.success) + | MsgError s => (print ("Set failed: " ^ s ^ "\n"); OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; OS.Process.failure)) + before OpenSSL.close bio + end + fun requestRmMailbox p = let val (_, bio) = requestBio (fn () => ()) @@ -779,6 +799,38 @@ 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 () => ()) @@ -905,7 +957,7 @@ fun requestFirewall {node, uname} = else Domain.nodeIp node ^ ":" ^ Int.toString Config.slavePort) - val _ = Msg.send (bio, MsgQuery (QFirewall uname)) + val _ = Msg.send (bio, MsgQuery (QFirewall {node = node, user = uname})) fun loop () = case Msg.recv bio of @@ -1058,7 +1110,7 @@ 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 true (context, @@ -1116,7 +1168,9 @@ fun regenerateEither tc checker context = ok := false) else (); - ignore (foldl checker' (basis (), Defaults.eInit ()) files) + let val basis' = basis () in + ignore (foldl checker' (basis', SM.empty) files) + end end else if String.isSuffix "_admin" user then () @@ -1184,20 +1238,24 @@ 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 @@ -1277,7 +1335,9 @@ fun service () = end in doIt (fn () => (Env.pre (); - ignore (foldl doOne (basis (), Defaults.eInit ()) codes); + let val basis' = basis () in + ignore (foldl doOne (basis', SM.empty) codes) + end; Env.post (); Msg.send (bio, MsgOk); ("Configuration complete.", NONE))) @@ -1477,6 +1537,27 @@ fun service () = SOME msg)) (fn () => ()) + | MsgPortalPasswdMailbox {domain, user = emailUser, oldpasswd, newpasswd} => + doIt (fn () => + if not (Acl.query {user = user, class = "priv", value = "vmail"}) then + ("User is not authorized to run portal vmail password", + SOME "You're not authorized to use the portal password command") + else if not (Domain.validEmailUser emailUser) then + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph oldpasswd + andalso CharVector.all Char.isGraph newpasswd) then + ("Invalid password", + SOME "Invalid password; may only contain printable, non-space characters") + else + case Vmail.portalpasswd {domain = domain, user = emailUser, + oldpasswd = oldpasswd, newpasswd = newpasswd} 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 @@ -1509,6 +1590,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"), @@ -1648,6 +1730,10 @@ fun slave () = 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 @@ -1771,14 +1857,17 @@ fun slave () = SOME "Script execution failed.")) (fn () => ())) | MsgFirewallRegen => - doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} andalso 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 - ("Not authorized to regenerate firewall.", SOME ("Unauthorized user " ^ user ^ "attempted to regenerated firewall"))) + 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;