X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0868840155aca9662f97318b114a07ae4c8319d6..c9731b9b3ee43c4c8d82c31009a5870a01d3acfa:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 5025cb2..29d2b37 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 () => ()) @@ -416,6 +489,22 @@ fun requestDbTable p = OpenSSL.close bio end +fun requestListMailboxes domain = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgListMailboxes domain); + (case Msg.recv bio of + 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.") + before OpenSSL.close bio + end + fun requestNewMailbox p = let val (_, bio) = requestBio (fn () => ()) @@ -461,6 +550,60 @@ 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 regenerate context = let val b = basis () @@ -541,6 +684,8 @@ fun rmuser user = Domain.rmdom doms end +fun now () = Date.toString (Date.fromTimeUniv (Time.now ())) + fun service () = let val () = Acl.read Config.aclFile @@ -558,7 +703,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 = @@ -620,6 +765,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 @@ -630,6 +789,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 @@ -721,6 +890,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 @@ -738,12 +921,26 @@ fun service () = 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.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 @@ -758,7 +955,7 @@ fun service () = passwd = passwd, mailbox = mailbox} of NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox, NONE) - | SOME msg => ("Error adding mailbox: " ^ msg, + | SOME msg => ("Error adding mailbox " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, SOME msg)) (fn () => ()) @@ -767,7 +964,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 @@ -778,7 +975,7 @@ fun service () = passwd = passwd} of NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain, NONE) - | SOME msg => ("Error changing mailbox password: " ^ msg, + | SOME msg => ("Error changing mailbox password for " ^ emailUser ^ "@" ^ domain ^ ": " ^ msg, SOME msg)) (fn () => ()) @@ -787,17 +984,51 @@ 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 case Vmail.rm {domain = domain, user = emailUser} of NONE => ("Deleted mailbox " ^ emailUser ^ "@" ^ domain, NONE) - | SOME msg => ("Error deleting mailbox: " ^ msg, + | 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 () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command")) @@ -816,6 +1047,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 @@ -831,19 +1063,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" @@ -862,6 +1092,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