X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0868840155aca9662f97318b114a07ae4c8319d6..2e96b9d42f6d2619f961c753ac3bbc9ba57c5147:/src/main.sml diff --git a/src/main.sml b/src/main.sml index 5025cb2..ef6e563 100644 --- a/src/main.sml +++ b/src/main.sml @@ -416,6 +416,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 +477,39 @@ 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 regenerate context = let val b = basis () @@ -620,6 +669,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 @@ -738,12 +801,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 +835,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 +844,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 +855,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 +864,39 @@ 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 () => ()) + | _ => doIt (fn () => ("Unexpected command", SOME "Unexpected command"))