X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/9ffe2f0fea48f1e2fa6a30b6a79b975b4a6f7671..0c85f25e773621daeb1b4ecff989dfbb602a8918:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 4fe8124..f3bedc2 100644 --- a/src/main.sml +++ b/src/main.sml @@ -1,5 +1,5 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2006-2007, Adam Chlipala * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -92,7 +92,9 @@ fun check fname = end end -val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") +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 = let @@ -167,19 +169,42 @@ fun eval' fname = val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort +val self = + "localhost:" ^ Int.toString Config.slavePort + +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 ("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 uid = Posix.ProcEnv.getuid () - val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) - - val () = Acl.read Config.aclFile - val () = Domain.setUser user + val user = setupUser () val () = f () - val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", - Config.keyDir ^ "/" ^ user ^ "/key.pem", - Config.trustStore) + val context = context (Config.certDir ^ "/" ^ user ^ ".pem", + Config.keyDir ^ "/" ^ user ^ "/key.pem", + Config.trustStore) in (user, context) end @@ -191,6 +216,13 @@ fun requestBio f = (user, OpenSSL.connect (context, dispatcher)) end +fun requestSlaveBio () = + let + val (user, context) = requestContext (fn () => ()) + in + (user, OpenSSL.connect (context, self)) + end + fun request fname = let val (user, bio) = requestBio (fn () => ignore (check fname)) @@ -219,6 +251,14 @@ fun request fname = fun requestDir dname = let + val _ = if Posix.FileSys.access (dname, []) then + () + 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"; + OS.Process.exit OS.Process.failure) + val _ = ErrorMsg.reset () val (user, bio) = requestBio (fn () => checkDir dname) @@ -275,6 +315,54 @@ fun requestDir dname = end handle ErrorMsg.Error => () +fun requestPing () = + let + val (_, bio) = requestBio (fn () => ()) + in + OpenSSL.close bio; + OS.Process.success + end + handle _ => OS.Process.failure + +fun requestShutdown () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgShutdown); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Shutdown begun.\n" + | MsgError s => print ("Shutdown failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestSlavePing () = + let + val (_, bio) = requestSlaveBio () + in + OpenSSL.close bio; + OS.Process.success + end + handle _ => OS.Process.failure + +fun requestSlaveShutdown () = + let + val (_, bio) = requestSlaveBio () + in + Msg.send (bio, MsgShutdown); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Shutdown begun.\n" + | MsgError s => print ("Shutdown failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestGrant acl = let val (user, bio) = requestBio (fn () => ()) @@ -356,6 +444,21 @@ fun requestRegen () = OpenSSL.close bio end +fun requestRegenTc () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRegenerateTc); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "All configuration validated.\n" + | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestRmdom dom = let val (_, bio) = requestBio (fn () => ()) @@ -401,6 +504,21 @@ fun requestDbUser dbtype = OpenSSL.close bio end +fun requestDbPasswd rc = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgDbPasswd rc); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Your password has been changed.\n" + | MsgError s => print ("Password set failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestDbTable p = let val (user, bio) = requestBio (fn () => ()) @@ -422,13 +540,13 @@ fun requestListMailboxes domain = in Msg.send (bio, MsgListMailboxes domain); (case Msg.recv bio of - NONE => Vmail.Error "Server closed connection unexpectedly.\n" + NONE => Vmail.Error "Server closed connection unexpectedly." | SOME m => case m of MsgMailboxes users => (Msg.send (bio, MsgOk); Vmail.Listing users) | MsgError s => Vmail.Error ("Creation failed: " ^ s) - | _ => Vmail.Error "Unexpected server reply.\n") + | _ => Vmail.Error "Unexpected server reply.") before OpenSSL.close bio end @@ -477,13 +595,245 @@ fun requestRmMailbox p = OpenSSL.close bio end +fun requestSaQuery addr = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgSaQuery addr); + (case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgSaStatus b => (print ("SpamAssassin filtering for " ^ addr ^ " is " + ^ (if b then "ON" else "OFF") ^ ".\n"); + Msg.send (bio, MsgOk)) + | MsgError s => print ("Query failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n") + before OpenSSL.close bio + end + +fun requestSaSet p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgSaSet p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("SpamAssassin filtering for " ^ #1 p ^ " is now " + ^ (if #2 p then "ON" else "OFF") ^ ".\n") + | MsgError s => print ("Set failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestSmtpLog domain = + let + val (_, bio) = requestBio (fn () => ()) + + val _ = Msg.send (bio, MsgSmtpLogReq domain) + + fun loop () = + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => () + | MsgSmtpLogRes line => (print line; + loop ()) + | MsgError s => print ("Log search failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n" + in + loop (); + 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 _ = Msg.send (bio, MsgQuery (QApt pkg)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "Package is installed.\n"; + OS.Process.success) + | MsgNo => (print "Package is not installed.\n"; + OS.Process.failure) + | MsgError s => (print ("APT 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 _ = Msg.send (bio, MsgQuery (QCron uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has cron permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have cron permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("Cron query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +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 _ = Msg.send (bio, MsgQuery (QFtp uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has FTP permissions.\n"; + OS.Process.success) + | MsgNo => (print "User does not have FTP permissions.\n"; + OS.Process.failure) + | MsgError s => (print ("FTP query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +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 _ = Msg.send (bio, MsgQuery (QTrustedPath uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgYes => (print "User has trusted path restriction.\n"; + OS.Process.success) + | MsgNo => (print "User does not have trusted path restriction.\n"; + OS.Process.failure) + | MsgError s => (print ("Trusted path query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +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 _ = Msg.send (bio, MsgQuery (QSocket uname)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgSocket p => (case p of + Any => print "Any\n" + | Client => print "Client\n" + | Server => print "Server\n" + | Nada => print "Nada\n"; + OS.Process.success) + | MsgError s => (print ("Socket permission query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + +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)) + + fun loop () = + case Msg.recv bio of + NONE => (print "Server closed connection unexpectedly.\n"; + OS.Process.failure) + | SOME m => + case m of + MsgFirewall ls => (app (fn s => (print s; print "\n")) ls; + OS.Process.success) + | MsgError s => (print ("Firewall query failed: " ^ s ^ "\n"); + OS.Process.failure) + | _ => (print "Unexpected server reply.\n"; + OS.Process.failure) + in + loop () + before OpenSSL.close bio + end + fun regenerate context = let + val _ = ErrorMsg.reset () + val b = basis () val () = Tycheck.disallowExterns () val () = Domain.resetGlobal () + val ok = ref true + fun contactNode (node, ip) = if node = Config.defaultNode then Domain.resetLocal () @@ -505,7 +855,8 @@ fun regenerate context = | _ => print ("Slave " ^ node ^ " returned unexpected command\n"); OpenSSL.close bio - end + end + handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n") fun doUser user = let @@ -513,36 +864,106 @@ fun regenerate context = val _ = ErrorMsg.reset () val dname = Config.domtoolDir user - - val dir = Posix.FileSys.opendir dname - - fun loop files = - case Posix.FileSys.readdir dir of - NONE => (Posix.FileSys.closedir dir; - files) - | SOME fname => - if notTmp fname then - loop (OS.Path.joinDirFile {dir = dname, - file = fname} - :: files) - else - loop files - - val files = loop [] - val (_, files) = Order.order (SOME b) files in - if !ErrorMsg.anyErrors then - print ("User " ^ user ^ "'s configuration has errors!\n") + if Posix.FileSys.access (dname, []) then + let + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + (ErrorMsg.reset (); + print ("User " ^ user ^ "'s configuration has errors!\n")) + else + app eval' files + end else - app eval' files + () end - handle IO.Io _ => () - | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + handle IO.Io _ => () + | 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 (); app doUser (Acl.users ()); - Env.post () + Env.post (); + !ok + end + +fun regenerateTc context = + let + val _ = ErrorMsg.reset () + + val b = basis () + val () = Tycheck.disallowExterns () + + val () = Domain.resetGlobal () + + val ok = ref true + + fun doUser user = + let + val _ = Domain.setUser user + val _ = ErrorMsg.reset () + + val dname = Config.domtoolDir user + in + if Posix.FileSys.access (dname, []) then + let + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + (ErrorMsg.reset (); + print ("User " ^ user ^ "'s configuration has errors!\n"); + ok := false) + else + app (ignore o check) files + end + else + () + end + handle IO.Io _ => () + | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + | ErrorMsg.Error => (ErrorMsg.reset (); + print ("User " ^ user ^ " had a compilation error.\n")) + | _ => print "Unknown exception during -tc regeneration!\n" + in + app doUser (Acl.users ()); + !ok end fun rmuser user = @@ -557,13 +978,33 @@ fun rmuser user = Domain.rmdom doms end +fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) + +fun answerQuery q = + case q of + QApt pkg => if Apt.installed pkg then MsgYes else 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) + +fun describeQuery q = + case q of + QApt pkg => "Requested installation status of package " ^ pkg + | 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 + fun service () = let val () = Acl.read Config.aclFile - val context = OpenSSL.context (Config.serverCert, - Config.serverKey, - Config.trustStore) + val context = context (Config.serverCert, + Config.serverKey, + Config.trustStore) val _ = Domain.set_context context val sock = OpenSSL.listen (context, Config.dispatcherPort) @@ -574,7 +1015,7 @@ fun service () = | SOME bio => let val user = OpenSSL.peerCN bio - val () = print ("\nConnection from " ^ user ^ "\n") + val () = print ("\nConnection from " ^ user ^ " at " ^ now () ^ "\n") val () = Domain.setUser user fun doIt f cleanup = @@ -587,8 +1028,11 @@ fun service () = (print msgLocal; print "\n"; Msg.send (bio, MsgOk))) - handle OpenSSL.OpenSSL _ => - print "OpenSSL error\n" + 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; @@ -636,6 +1080,20 @@ fun service () = (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 @@ -646,6 +1104,16 @@ fun service () = 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 @@ -703,14 +1171,32 @@ fun service () = doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"} orelse Acl.query {user = user, class = "priv", value = "all"} then - (regenerate context; - ("Regenerated all configuration.", - NONE)) + (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 @@ -737,6 +1223,20 @@ fun service () = 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 @@ -773,7 +1273,7 @@ fun service () = 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.validUser emailUser) then + 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 @@ -797,7 +1297,7 @@ fun service () = 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.validUser emailUser) then + 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 @@ -817,7 +1317,7 @@ fun service () = 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.validUser emailUser) then + else if not (Domain.validEmailUser emailUser) then ("Invalid e-mail username " ^ emailUser, SOME "Invalid e-mail username") else @@ -828,6 +1328,46 @@ fun service () = 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")) @@ -835,8 +1375,9 @@ fun service () = in cmdLoop () end - handle OpenSSL.OpenSSL s => + 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 ()) @@ -845,7 +1386,20 @@ fun service () = 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 ()) in + print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; loop (); OpenSSL.shutdown sock @@ -855,25 +1409,23 @@ fun slave () = let val host = Slave.hostname () - val context = OpenSSL.context (Config.certDir ^ "/" ^ host ^ ".pem", - Config.keyDir ^ "/" ^ host ^ "/key.pem", - Config.trustStore) + val context = context (Config.certDir ^ "/" ^ host ^ ".pem", + Config.keyDir ^ "/" ^ host ^ "/key.pem", + Config.trustStore) val sock = OpenSSL.listen (context, Config.slavePort) + 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 ^ "\n") + val () = print ("\nConnection from " ^ peer ^ " at " ^ now () ^ "\n") in - if peer <> Config.dispatcherName then - (print "Not authorized!\n"; - OpenSSL.close bio; - loop ()) - else let + if peer = Config.dispatcherName then let fun loop' files = case Msg.recv bio of NONE => print "Dispatcher closed connection unexpectedly\n" @@ -892,13 +1444,29 @@ fun slave () = OpenSSL.close bio; loop () end + else if peer = "domtool" then + case Msg.recv bio of + SOME MsgShutdown => (OpenSSL.close bio; + print ("Shutting down at " ^ now () ^ "\n\n")) + | _ => (OpenSSL.close bio; + loop ()) + else + case Msg.recv bio of + SOME (MsgQuery q) => (print (describeQuery q ^ "\n"); + Msg.send (bio, answerQuery q); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio; + loop ()) + | _ => (OpenSSL.close bio; + loop ()) end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: "^ s ^ "\n"); OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) - | OS.SysErr (s, _) => - (print ("System error: "^ s ^ "\n"); + | 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 ())