From 0868840155aca9662f97318b114a07ae4c8319d6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 23 Dec 2006 20:40:16 +0000 Subject: [PATCH] First vmail support --- Makefile | 10 +- bin/.cvsignore | 1 + configDefault/courier.cfg | 18 ++ configDefault/courier.cfs | 1 + configDefault/courier.csg | 14 ++ scripts/domtool-publish | 7 + src/.cvsignore | 1 + src/domain.sig | 2 + src/mail/vmail.sig | 33 +++ src/mail/vmail.sml | 81 +++++++ src/main-vmail.sml | 51 +++++ src/main.sig | 5 + src/main.sml | 465 ++++++++++++++++++++------------------ src/msg.sml | 31 +++ src/msgTypes.sml | 7 + src/sources | 3 + 16 files changed, 503 insertions(+), 227 deletions(-) create mode 100644 configDefault/courier.cfg create mode 100644 configDefault/courier.cfs create mode 100644 configDefault/courier.csg create mode 100644 src/mail/vmail.sig create mode 100644 src/mail/vmail.sml create mode 100644 src/main-vmail.sml diff --git a/Makefile b/Makefile index 33f7683..17f3c0d 100644 --- a/Makefile +++ b/Makefile @@ -6,7 +6,7 @@ COMMON_DEPS := configDefault/config.sig configDefault/configDefault.sml \ .PHONY: all mlton smlnj install mlton: bin/domtool-server bin/domtool-client bin/domtool-slave \ - bin/domtool-admin bin/domtool-doc bin/dbtool + bin/domtool-admin bin/domtool-doc bin/dbtool bin/vmail smlnj: $(COMMON_DEPS) openssl/smlnj/FFI/libssl.h.cm src/domtool.cm @@ -65,6 +65,10 @@ src/dbtool.mlb: src/prefix.mlb src/sources src/suffix.mlb $(MAKE_MLB_BASE) >src/dbtool.mlb echo "main-dbtool.sml" >>src/dbtool.mlb +src/vmail.mlb: src/prefix.mlb src/sources src/suffix.mlb + $(MAKE_MLB_BASE) >src/vmail.mlb + echo "main-vmail.sml" >>src/vmail.mlb + openssl/smlnj/FFI/libssl.h.cm: openssl/openssl_sml.h cd openssl/smlnj ; ml-nlffigen -d FFI -lh LibsslH.libh -include ../libssl-h.sml \ -cm libssl.h.cm -D__builtin_va_list="void*" \ @@ -105,6 +109,9 @@ bin/domtool-doc: $(COMMON_MLTON_DEPS) src/domtool-doc.mlb bin/dbtool: $(COMMON_MLTON_DEPS) src/dbtool.mlb mlton -output bin/dbtool -link-opt -ldl src/dbtool.mlb +bin/vmail: $(COMMON_MLTON_DEPS) src/vmail.mlb + mlton -output bin/vmail -link-opt -ldl src/vmail.mlb + install: cp scripts/domtool-publish /usr/local/sbin/ cp scripts/domtool-reset-global /usr/local/sbin/ @@ -120,6 +127,7 @@ install: -cp bin/domtool-admin /usr/local/bin/ -cp bin/domtool-doc /usr/local/bin/ -cp bin/dbtool /usr/local/bin/ + -cp bin/vmail /usr/local/bin/ cp src/plugins/domtool-postgres /usr/local/sbin/ cp src/plugins/domtool-mysql /usr/local/sbin/ diff --git a/bin/.cvsignore b/bin/.cvsignore index dc4068c..df0fc62 100644 --- a/bin/.cvsignore +++ b/bin/.cvsignore @@ -4,3 +4,4 @@ domtool-slave domtool-admin domtool-doc dbtool +vmail diff --git a/configDefault/courier.cfg b/configDefault/courier.cfg new file mode 100644 index 0000000..025ee60 --- /dev/null +++ b/configDefault/courier.cfg @@ -0,0 +1,18 @@ +structure Courier :> COURIER_CONFIG = struct + +(* Non-daemon programs *) +val userdb = "/usr/sbin/userdb" +val maildirmake = "/usr/bin/maildirmake.courier" +val userdbpw = "/usr/sbin/userdbpw" +val makeuserdb = "/usr/sbin/makeuserdb" + +val userdbDir = "/etc/userdb" +(* Directory for storing userdb info *) + +val postReload = "/usr/bin/sudo /usr/local/sbin/domtool-publish courier" +(* Command to run after reloading userdb data *) + +val logFile = "/var/log/exim4/mainlog" +(* SMTP log *) + +end diff --git a/configDefault/courier.cfs b/configDefault/courier.cfs new file mode 100644 index 0000000..f1178df --- /dev/null +++ b/configDefault/courier.cfs @@ -0,0 +1 @@ +structure Courier : COURIER_CONFIG diff --git a/configDefault/courier.csg b/configDefault/courier.csg new file mode 100644 index 0000000..b1f544d --- /dev/null +++ b/configDefault/courier.csg @@ -0,0 +1,14 @@ +signature COURIER_CONFIG = sig + + val userdb : string + val maildirmake : string + val userdbpw : string + val makeuserdb : string + + val userdbDir : string + + val postReload : string + + val logFile : string + +end diff --git a/scripts/domtool-publish b/scripts/domtool-publish index fad7e85..e208877 100755 --- a/scripts/domtool-publish +++ b/scripts/domtool-publish @@ -27,6 +27,13 @@ case $1 in /bin/cp /var/domtool/mailman.map /etc/mailman /etc/init.d/mailman reload ;; + courier) + cat /etc/courier/userdb/* >/etc/courier/exim + chmod o-r /etc/courier/exim + exim_dbmbuild /etc/courier/exim /etc/courier/exim.dat + chgrp mail /etc/courier/exim.dat + chmod o-r /etc/courier/exim.dat + ;; *) echo "Usage: domtool-publish [apache|bind|exim|mailman]" ;; diff --git a/src/.cvsignore b/src/.cvsignore index 18ad0fc..e1d7ea7 100644 --- a/src/.cvsignore +++ b/src/.cvsignore @@ -8,3 +8,4 @@ domtool-slave.mlb domtool-admin.mlb domtool-doc.mlb dbtool.mlb +vmail.mlb diff --git a/src/domain.sig b/src/domain.sig index 642c0f4..be9bd8b 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -24,6 +24,8 @@ signature DOMAIN = sig val isIdent : char -> bool val validHost : string -> bool val validDomain : string -> bool + val yourDomain : string -> bool + val validUser : string -> bool val ip : string Env.arg diff --git a/src/mail/vmail.sig b/src/mail/vmail.sig new file mode 100644 index 0000000..37e4ee0 --- /dev/null +++ b/src/mail/vmail.sig @@ -0,0 +1,33 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Administration of Courier IMAP virtual mailboxes *) + +signature VMAIL = sig + + val rebuild : unit -> bool + + val add : {domain : string, requester : string, user : string, + passwd : string, mailbox : string} -> string option + + val passwd : {domain : string, user : string, passwd : string} + -> string option + + val rm : {domain : string, user : string} -> string option + +end diff --git a/src/mail/vmail.sml b/src/mail/vmail.sml new file mode 100644 index 0000000..a1f8648 --- /dev/null +++ b/src/mail/vmail.sml @@ -0,0 +1,81 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Administration of Courier IMAP virtual mailboxes *) + +structure Vmail :> VMAIL = struct + +fun rebuild () = Slave.shell [Config.Courier.postReload] + +fun add {domain, requester, user, passwd, mailbox} = + let + val udb = Posix.SysDB.getpwnam requester + val uid = Word.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb)) + val gid = Word.toInt (Posix.ProcEnv.gidToWord (Posix.SysDB.Passwd.gid udb)) + val home = Posix.SysDB.Passwd.home udb + in + if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, + "\" set home=", home, " mail=", mailbox, + " uid=", Int.toString uid, " gid=" ^ Int.toString gid]) then + SOME "Error running userdb" + else + let + val proc = Unix.execute ("/bin/sh", ["-c", + String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb, + " \"", domain, "/", user, "@", domain, "\" set systempw"]]) + val outf = Unix.textOutstreamOf proc + in + TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]); + TextIO.closeOut outf; + if not (OS.Process.isSuccess (Unix.reap proc)) then + (ignore (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]); + SOME "Error setting password") + else if not (rebuild ()) then + (ignore (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]); + SOME "Error reloading userdb") + else + NONE + end + end + +fun passwd {domain, user, passwd} = + let + val proc = Unix.execute ("/bin/sh", ["-c", + String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb, + " \"", domain, "/", user, "@", domain, "\" set systempw"]]) + val outf = Unix.textOutstreamOf proc + in + TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]); + TextIO.closeOut outf; + if not (OS.Process.isSuccess (Unix.reap proc)) then + SOME "Error setting password" + else if not (rebuild ()) then + SOME "Error reloading userdb" + else + NONE + end + +fun rm {domain, user} = + if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]) then + SOME "Error deleting password entry" + else if not (rebuild ()) then + SOME "Error reloading userdb" + else + NONE + +end diff --git a/src/main-vmail.sml b/src/main-vmail.sml new file mode 100644 index 0000000..63ea19d --- /dev/null +++ b/src/main-vmail.sml @@ -0,0 +1,51 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Driver for vmail *) + +val _ = + case CommandLine.arguments () of + [] => print "Invalid command-line arguments\n" + | domain :: rest => + case rest of + ["add", user, mailbox] => + (case Client.getpass () of + Client.Passwd passwd => + Main.requestNewMailbox {domain = domain, + user = user, + passwd = passwd, + mailbox = mailbox} + | _ => ()) + + | ["passwd", user] => + (case Client.getpass () of + Client.Passwd passwd => + Main.requestPasswdMailbox {domain = domain, + user = user, + passwd = passwd} + | _ => ()) + + | ["rm", user] => + (print ("Are you sure you want to delete the mapping for " ^ user ^ "@" ^ domain ^ "? (yes/no) "); + if TextIO.inputLine TextIO.stdIn = SOME "yes\n" then + Main.requestRmMailbox {domain = domain, + user = user} + else + print "Aborted\n") + + | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index 6960cf4..e9a8d2d 100644 --- a/src/main.sig +++ b/src/main.sig @@ -51,4 +51,9 @@ signature MAIN = sig val requestDbUser : {dbtype : string, passwd : string option} -> unit val requestDbTable : {dbtype : string, dbname : string} -> unit + val requestNewMailbox : {domain : string, user : string, + passwd : string, mailbox : string} -> unit + val requestPasswdMailbox : {domain : string, user : string, passwd : string} + -> unit + val requestRmMailbox : {domain : string, user : string} -> unit end diff --git a/src/main.sml b/src/main.sml index ec98e4e..5025cb2 100644 --- a/src/main.sml +++ b/src/main.sml @@ -416,6 +416,51 @@ fun requestDbTable p = OpenSSL.close bio end +fun requestNewMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgNewMailbox p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("A mapping for " ^ #user p ^ "@" ^ #domain p ^ " has been created.\n") + | MsgError s => print ("Creation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestPasswdMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgPasswdMailbox p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("The password for " ^ #user p ^ "@" ^ #domain p ^ " has been changed.\n") + | MsgError s => print ("Set failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + +fun requestRmMailbox p = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRmMailbox p); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print ("The mapping for mailbox " ^ #user p ^ "@" ^ #domain p ^ " has been deleted.\n") + | MsgError s => print ("Remove failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun regenerate context = let val b = basis () @@ -516,6 +561,40 @@ fun service () = val () = print ("\nConnection from " ^ user ^ "\n") val () = Domain.setUser user + fun doIt f cleanup = + ((case f () of + (msgLocal, SOME msgRemote) => + (print msgLocal; + print "\n"; + Msg.send (bio, MsgError msgRemote)) + | (msgLocal, NONE) => + (print msgLocal; + print "\n"; + Msg.send (bio, MsgOk))) + handle OpenSSL.OpenSSL _ => + print "OpenSSL error\n" + | OS.SysErr (s, _) => + (print "System error: "; + print s; + print "\n"; + Msg.send (bio, MsgError ("System error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | Fail s => + (print "Failure: "; + print s; + print "\n"; + Msg.send (bio, MsgError ("Failure: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) + | ErrorMsg.Error => + (print "Compilation error\n"; + Msg.send (bio, MsgError "Error during configuration evaluation") + handle OpenSSL.OpenSSL _ => ()); + (cleanup (); + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + fun doConfig codes = let val _ = print "Configuration:\n" @@ -533,25 +612,12 @@ fun service () = eval' outname end in - (Env.pre (); - app doOne codes; - Env.post (); - Msg.send (bio, MsgOk)) - handle ErrorMsg.Error => - (print "Compilation error\n"; - Msg.send (bio, - MsgError "Error during configuration evaluation")) - | OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during configuration evaluation: " - ^ s))); - OS.FileSys.remove outname; - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop () + doIt (fn () => (Env.pre (); + app doOne codes; + Env.post (); + Msg.send (bio, MsgOk); + ("Configuration complete.", NONE))) + (fn () => OS.FileSys.remove outname) end fun cmdLoop () = @@ -565,230 +631,177 @@ fun service () = | MsgMultiConfig codes => doConfig codes | MsgGrant acl => - if Acl.query {user = user, class = "priv", value = "all"} then - ((Acl.grant acl; - Acl.write Config.aclFile; - Msg.send (bio, MsgOk); - print ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during granting: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - else - ((Msg.send (bio, MsgError "Not authorized to grant privileges"); - print "Unauthorized user asked to grant a permission!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (Acl.grant acl; + Acl.write Config.aclFile; + ("Granted permission " ^ #value acl ^ " to " ^ #user acl ^ " in " ^ #class acl ^ ".", + NONE)) + else + ("Unauthorized user asked to grant a permission!", + SOME "Not authorized to grant privileges")) + (fn () => ()) + | MsgRevoke acl => - if Acl.query {user = user, class = "priv", value = "all"} then - ((Acl.revoke acl; - Acl.write Config.aclFile; - Msg.send (bio, MsgOk); - print ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during revocation: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - else - ((Msg.send (bio, MsgError "Not authorized to revoke privileges"); - print "Unauthorized user asked to revoke a permission!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (Acl.revoke acl; + Acl.write Config.aclFile; + ("Revoked permission " ^ #value acl ^ " from " ^ #user acl ^ " in " ^ #class acl ^ ".", + NONE)) + else + ("Unauthorized user asked to revoke a permission!", + SOME "Not authorized to revoke privileges")) + (fn () => ()) | MsgListPerms user => - ((Msg.send (bio, MsgPerms (Acl.queryAll user)); - print ("Sent permission list for user " ^ user ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during permission listing: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + (Msg.send (bio, MsgPerms (Acl.queryAll user)); + ("Sent permission list for user " ^ user ^ ".", + NONE))) + (fn () => ()) | MsgWhoHas perm => - ((Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); - print ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during whohas: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + (Msg.send (bio, MsgWhoHasResponse (Acl.whoHas perm)); + ("Sent whohas response for " ^ #class perm ^ " / " ^ #value perm ^ ".", + NONE))) + (fn () => ()) | MsgRmdom doms => - if Acl.query {user = user, class = "priv", value = "all"} - orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then - ((Domain.rmdom doms; - app (fn dom => - Acl.revokeFromAll {class = "domain", value = dom}) doms; - Acl.write Config.aclFile; - Msg.send (bio, MsgOk); - print ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during revocation: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - else - ((Msg.send (bio, MsgError "Not authorized to remove that domain"); - print "Unauthorized user asked to remove a domain!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} + orelse List.all (fn dom => Acl.query {user = user, class = "domain", value = dom}) doms then + (Domain.rmdom doms; + app (fn dom => + Acl.revokeFromAll {class = "domain", value = dom}) doms; + Acl.write Config.aclFile; + ("Removed domains" ^ foldl (fn (d, s) => s ^ " " ^ d) "" doms ^ ".", + NONE)) + else + ("Unauthorized user asked to remove a domain!", + SOME "Not authorized to remove that domain")) + (fn () => ()) | MsgRegenerate => - if Acl.query {user = user, class = "priv", value = "regen"} - orelse Acl.query {user = user, class = "priv", value = "all"} then - ((regenerate context; - Msg.send (bio, MsgOk); - print "Regenerated all configuration.\n") - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during regeneration: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - else - ((Msg.send (bio, MsgError "Not authorized to regeneration"); - print "Unauthorized user asked to regenerate!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + 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)) + else + ("Unauthorized user asked to regenerate!", + SOME "Not authorized to regenerate")) + (fn () => ()) | MsgRmuser user' => - if Acl.query {user = user, class = "priv", value = "all"} then - ((rmuser user'; - Acl.write Config.aclFile; - Msg.send (bio, MsgOk); - print ("Removed user " ^ user' ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during revocation: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - else - ((Msg.send (bio, MsgError "Not authorized to remove users"); - print "Unauthorized user asked to remove a user!\n"; - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "all"} then + (rmuser user'; + Acl.write Config.aclFile; + ("Removed user " ^ user' ^ ".", + NONE)) + else + ("Unauthorized user asked to remove a user!", + SOME "Not authorized to remove users")) + (fn () => ()) | MsgCreateDbUser {dbtype, passwd} => - (case Dbms.lookup dbtype of - NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype)); - print ("Database user creation request with unknown datatype type " ^ dbtype); - ignore (OpenSSL.readChar bio)) - handle OpenSSL.OpenSSL _ => (); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | SOME handler => - case #adduser handler {user = user, passwd = passwd} of - NONE => ((Msg.send (bio, MsgOk); - print ("Added " ^ dbtype ^ " user " ^ user ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during creation: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - | SOME msg => ((Msg.send (bio, MsgError ("Error adding user: " ^ msg)); - print ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg ^ "\n"); - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ())) + doIt (fn () => + case Dbms.lookup dbtype of + NONE => ("Database user creation request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #adduser handler {user = user, passwd = passwd} of + NONE => ("Added " ^ dbtype ^ " user " ^ user ^ ".", + NONE) + | SOME msg => + ("Error adding a " ^ dbtype ^ " user " ^ user ^ ": " ^ msg, + SOME ("Error adding user: " ^ msg))) + (fn () => ()) | MsgCreateDbTable {dbtype, dbname} => - if Dbms.validDbname dbname then - (case Dbms.lookup dbtype of - NONE => ((Msg.send (bio, MsgError ("Unknown database type " ^ dbtype)); - print ("Database creation request with unknown datatype type " ^ dbtype); - ignore (OpenSSL.readChar bio)) - handle OpenSSL.OpenSSL _ => (); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) - | SOME handler => - case #createdb handler {user = user, dbname = dbname} of - NONE => ((Msg.send (bio, MsgOk); - print ("Created database " ^ user ^ "_" ^ dbname ^ ".\n")) - handle OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during creation: " - ^ s))); - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) - | SOME msg => ((Msg.send (bio, MsgError ("Error creating database: " ^ msg)); - print ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg ^ "\n"); - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ())) - else - ((Msg.send (bio, MsgError ("Invalid database name " ^ dbname)); - print ("Invalid database name " ^ user ^ "_" ^ dbname ^ "\n"); - ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => + if Dbms.validDbname dbname then + case Dbms.lookup dbtype of + NONE => ("Database creation request with unknown datatype type " ^ dbtype, + SOME ("Unknown database type " ^ dbtype)) + | SOME handler => + case #createdb handler {user = user, dbname = dbname} of + NONE => ("Created database " ^ user ^ "_" ^ dbname ^ ".", + NONE) + | SOME msg => ("Error creating database " ^ user ^ "_" ^ dbname ^ ": " ^ msg, + SOME ("Error creating database: " ^ msg)) + else + ("Invalid database name " ^ user ^ "_" ^ dbname, + SOME ("Invalid database name " ^ dbname))) + (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 + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph passwd) then + ("Invalid password", + SOME "Invalid password; may only contain printable, non-space characters") + else if not (Domain.yourPath mailbox) then + ("User wasn't authorized to add a mailbox at " ^ mailbox, + SOME "You're not authorized to use that mailbox location.") + else + case Vmail.add {requester = user, + domain = domain, user = emailUser, + passwd = passwd, mailbox = mailbox} of + NONE => ("Added mailbox " ^ emailUser ^ "@" ^ domain ^ " at " ^ mailbox, + NONE) + | SOME msg => ("Error adding mailbox: " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgPasswdMailbox {domain, user = emailUser, passwd} => + doIt (fn () => + 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 + ("Invalid e-mail username " ^ emailUser, + SOME "Invalid e-mail username") + else if not (CharVector.all Char.isGraph passwd) then + ("Invalid password", + SOME "Invalid password; may only contain printable, non-space characters") + else + case Vmail.passwd {domain = domain, user = emailUser, + passwd = passwd} of + NONE => ("Changed password of mailbox " ^ emailUser ^ "@" ^ domain, + NONE) + | SOME msg => ("Error changing mailbox password: " ^ msg, + SOME msg)) + (fn () => ()) + + | MsgRmMailbox {domain, user = emailUser} => + doIt (fn () => + 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 + ("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)) + (fn () => ()) | _ => - (Msg.send (bio, MsgError "Unexpected command") - handle OpenSSL.OpenSSL _ => (); - OpenSSL.close bio - handle OpenSSL.OpenSSL _ => (); - loop ()) + doIt (fn () => ("Unexpected command", + SOME "Unexpected command")) + (fn () => ()) in cmdLoop () end diff --git a/src/msg.sml b/src/msg.sml index 53dfbfa..d0d917c 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -119,6 +119,21 @@ fun send (bio, m) = | MsgCreateDbTable {dbtype, dbname} => (OpenSSL.writeInt (bio, 17); OpenSSL.writeString (bio, dbtype); OpenSSL.writeString (bio, dbname)) + | MsgNewMailbox {domain, user, passwd, mailbox} => + (OpenSSL.writeInt (bio, 18); + OpenSSL.writeString (bio, domain); + OpenSSL.writeString (bio, user); + OpenSSL.writeString (bio, passwd); + OpenSSL.writeString (bio, mailbox)) + | MsgPasswdMailbox {domain, user, passwd} => + (OpenSSL.writeInt (bio, 19); + OpenSSL.writeString (bio, domain); + OpenSSL.writeString (bio, user); + OpenSSL.writeString (bio, passwd)) + | MsgRmMailbox {domain, user} => + (OpenSSL.writeInt (bio, 20); + OpenSSL.writeString (bio, domain); + OpenSSL.writeString (bio, user)) fun checkIt v = case v of @@ -177,6 +192,22 @@ fun recv bio = (SOME dbtype, SOME dbname) => SOME (MsgCreateDbTable {dbtype = dbtype, dbname = dbname}) | _ => NONE) + | 18 => (case (OpenSSL.readString bio, OpenSSL.readString bio, + OpenSSL.readString bio, OpenSSL.readString bio) of + (SOME domain, SOME user, SOME passwd, SOME mailbox) => + SOME (MsgNewMailbox {domain = domain, user = user, + passwd = passwd, mailbox = mailbox}) + | _ => NONE) + | 19 => (case (OpenSSL.readString bio, OpenSSL.readString bio, + OpenSSL.readString bio) of + (SOME domain, SOME user, SOME passwd) => + SOME (MsgPasswdMailbox {domain = domain, user = user, + passwd = passwd}) + | _ => NONE) + | 20 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of + (SOME domain, SOME user) => + SOME (MsgRmMailbox {domain = domain, user = user}) + | _ => NONE) | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 5758d80..c970491 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -58,5 +58,12 @@ datatype msg = (* Request creation of a user for the named DBMS type *) | MsgCreateDbTable of {dbtype : string, dbname : string} (* Request creation of a DBMS table *) + | MsgNewMailbox of {domain : string, user : string, + passwd : string, mailbox : string} + (* Request creation of a new vmail mapping *) + | MsgPasswdMailbox of {domain : string, user : string, passwd : string} + (* Change a vmail account's password *) + | MsgRmMailbox of {domain : string, user : string} + (* Remove a vmail mapping *) end diff --git a/src/sources b/src/sources index 4578e59..cbb56cb 100644 --- a/src/sources +++ b/src/sources @@ -86,6 +86,9 @@ plugins/postgres.sml plugins/mysql.sig plugins/mysql.sml +mail/vmail.sig +mail/vmail.sml + order.sig order.sml -- 2.20.1