X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/9ffe2f0fea48f1e2fa6a30b6a79b975b4a6f7671..75585a67831244a20e460b7336d440d4cabe3b41:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 4fe8124..0ddc508 100644 --- a/src/main.sml +++ b/src/main.sml @@ -167,6 +167,9 @@ fun eval' fname = val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort +val self = + "localhost:" ^ Int.toString Config.slavePort + fun requestContext f = let val uid = Posix.ProcEnv.getuid () @@ -191,6 +194,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)) @@ -275,6 +285,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 () => ()) @@ -401,6 +459,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 +495,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,6 +550,85 @@ 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 (_, bio) = requestBio (fn () => ()) + + val _ = Msg.send (bio, MsgApt 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 regenerate context = let val b = basis () @@ -538,6 +690,7 @@ fun regenerate context = end handle IO.Io _ => () | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + | ErrorMsg.Error => print ("User " ^ user ^ " had a compilation error.\n") in app contactNode Config.nodeIps; Env.pre (); @@ -557,6 +710,8 @@ fun rmuser user = Domain.rmdom doms end +fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) + fun service () = let val () = Acl.read Config.aclFile @@ -574,7 +729,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 = @@ -636,6 +791,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 +815,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 @@ -737,6 +916,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 +966,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 +990,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 +1010,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 +1021,49 @@ 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 () => ()) + + | MsgApt pkg => + doIt (fn () => (Msg.send (bio, if Apt.installed pkg then + MsgYes + else + MsgNo); + ("User requested installation status of package " ^ pkg, + NONE))) + (fn () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command")) @@ -846,6 +1082,7 @@ fun service () = handle OpenSSL.OpenSSL _ => (); loop ()) in + print ("Domtool dispatcher starting up at " ^ now () ^ "\n"); print "Listening for connections....\n"; loop (); OpenSSL.shutdown sock @@ -861,19 +1098,17 @@ fun slave () = 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,6 +1127,16 @@ 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 + (print "Not authorized!\n"; + OpenSSL.close bio; + loop ()) end handle OpenSSL.OpenSSL s => (print ("OpenSSL error: "^ s ^ "\n"); OpenSSL.close bio