X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0868840155aca9662f97318b114a07ae4c8319d6..8ca17b9a328732cac9ccd9e1c96c8d35777afe88:/src/mail/vmail.sml diff --git a/src/mail/vmail.sml b/src/mail/vmail.sml index a1f8648..8e92f60 100644 --- a/src/mail/vmail.sml +++ b/src/mail/vmail.sml @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2006-2009, Adam Chlipala + * Copyright (c) 2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -20,58 +21,138 @@ structure Vmail :> VMAIL = struct -fun rebuild () = Slave.shell [Config.Courier.postReload] +open MsgTypes -fun add {domain, requester, user, passwd, mailbox} = +fun rebuild () = 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 + fun doNode (site, ok) = + (print ("New vmail data for node " ^ site ^ "\n"); + Connect.commandWorker (Domain.get_context (), site, MsgVmailChanged)) 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 + foldl doNode true Config.mailNodes_all + end + +fun doChanged () = + Slave.shell [Config.Courier.postReload] + +datatype listing = + Error of string + | Listing of {user : string, mailbox : string} list + +fun list domain = + let + val file = OS.Path.joinDirFile {dir = Config.Vmail.userDatabase, + file = domain} + in + if Posix.FileSys.access (file, []) then 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 + val inf = TextIO.openIn file + + fun loop users = + case TextIO.inputLine inf of + NONE => Listing (rev users) + | SOME line => + case String.tokens Char.isSpace line of + [addr, fields] => + (case String.fields (fn ch => ch = #"@") addr of + [user, _] => + let + fun parseFields fields = + case fields of + "mail" :: mailbox :: _ => loop ({user = user, mailbox = mailbox} :: users) + | _ :: _ :: rest => parseFields rest + | _ => Error "Invalid fields in database" + in + parseFields (String.fields (fn ch => ch = #"|" orelse ch = #"=") fields) + end + | _ => Error "Invalid e-mail address format in database") + | _ => Error "Invalid entry in database" 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 + loop [] + before TextIO.closeIn inf end + else + Listing [] end + handle IO.Io {name, function, ...} => + Error ("IO failure: " ^ name ^ ": " ^ function) -fun passwd {domain, user, passwd} = +fun mailboxExists {domain, user} = + let + val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Vmail.userDatabase, + file = domain}) + + fun loop () = + case TextIO.inputLine inf of + NONE => false + | SOME line => + case String.tokens Char.isSpace line of + [addr, _] => + (case String.fields (fn ch => ch = #"@") addr of + [user', _] => + user' = user orelse loop () + | _ => false) + | _ => false + in + loop () + before TextIO.closeIn inf + end + handle IO.Io _ => false + +fun setpassword {domain, user, passwd} = let val proc = Unix.execute ("/bin/sh", ["-c", - String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb, - " \"", domain, "/", user, "@", domain, "\" set systempw"]]) + String.concat [Config.Vmail.userdbpw, " | ", Config.Vmail.userdb, + " -f ", Config.Vmail.userDatabase, "/", 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" + OS.Process.isSuccess (Unix.reap proc) + end + +fun deluser {domain, user} = + Slave.run (Config.Vmail.userdb, ["-f", Config.Vmail.userDatabase ^ "/" ^ domain, + user ^ "@" ^ domain, "del"]) + +fun add {domain, requester, user, passwd, mailbox} = + let + val udb = Posix.SysDB.getpwnam requester + val uid = SysWord.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb)) + val gid = SysWord.toInt (Posix.ProcEnv.gidToWord (Posix.SysDB.Passwd.gid udb)) + val home = Posix.SysDB.Passwd.home udb + in + if mailboxExists {domain = domain, user = user} then + SOME "Mailbox mapping already exists" + else if not (Slave.run (Config.Vmail.userdb, ["-f", Config.Vmail.userDatabase ^ "/" ^ domain, + user ^ "@" ^ domain, + "set", "home=" ^ home, "mail=" ^ mailbox, "uid=" ^ Int.toString uid, "gid=" ^ Int.toString gid])) then + SOME "Error running userdb" + else if not (setpassword {domain = domain, user = user, passwd = passwd}) then + (ignore (deluser {domain = domain, user = user}); + SOME "Error setting password") else if not (rebuild ()) then - SOME "Error reloading userdb" + (ignore (deluser {domain = domain, user = user}); + SOME "Error reloading userdb") else NONE end +fun passwd {domain, user, passwd} = + if not (mailboxExists {domain = domain, user = user}) then + SOME "Mailbox doesn't exist" + else if not (setpassword {domain = domain, user = user, passwd = passwd}) then + SOME "Error setting password" + else if not (rebuild ()) then + SOME "Error reloading userdb" + else + NONE + fun rm {domain, user} = - if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]) then + if not (mailboxExists {domain = domain, user = user}) then + SOME "Mailbox doesn't exist" + else if not (deluser {domain = domain, user = user}) then SOME "Error deleting password entry" else if not (rebuild ()) then SOME "Error reloading userdb"