X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/blobdiff_plain/0868840155aca9662f97318b114a07ae4c8319d6..0e0442b0650ceb74175905578054db8877b1bbbd:/src/mail/vmail.sml diff --git a/src/mail/vmail.sml b/src/mail/vmail.sml index a1f8648..0594fb1 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,207 @@ 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" + foldl doNode true Config.mailNodes_all + end + +fun doChanged () = + Slave.shell [Config.Courier.postReload] + + +structure SM = DataStructures.StringMap + +exception Userdb of string + +fun readUserdb domain = + let + val file = OS.Path.joinDirFile {dir = Config.Vmail.userDatabase, + file = domain} + in + if Posix.FileSys.access (file, []) then + let + val inf = TextIO.openIn file + + fun parseField (field, fields) = + case String.fields (fn ch => ch = #"=") field of + [key, value] => SM.insert (fields, key, value) + | _ => raise Userdb ("Malformed fields in vmail userdb for domain " ^ domain) + + fun loop users = + case TextIO.inputLine inf of + NONE => users + | SOME line => + case String.tokens Char.isSpace line of + [addr, fields] => (case String.fields (fn ch => ch = #"@") addr of + [user, _] => + loop (SM.insert (users, user, foldl parseField SM.empty (String.fields (fn ch => ch = #"|") fields))) + | _ => raise Userdb ("Malformed address in vmail userdb for " ^ domain ^ ": " ^ addr)) + | _ => raise Userdb ("Malformed record in vmail userdb for domain " ^ domain) + in + loop SM.empty + before TextIO.closeIn inf + end else + SM.empty + end + +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 checkpassword {domain, user, passwd} = + let + val proc = Unix.execute (Config.installPrefix ^ "/sbin/domtool-vmailpasswd", []) + val outf = Unix.textOutstreamOf proc + val db = readUserdb domain + in + case SM.find (db, user) of + SOME fields => + (case SM.find (fields, "systempw") of + SOME systempw => + (TextIO.output (outf, systempw ^ "\n"); + TextIO.output (outf, passwd ^ "\n"); + TextIO.closeOut outf; + OS.Process.isSuccess (Unix.reap proc)) + | NONE => raise Userdb ("systempw not found for user " ^ user ^ "@" ^ domain)) + | NONE => raise Userdb ("User " ^ user ^ " not found in vmail userdb for domain " ^ domain) + 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 portalpasswd {domain, user, oldpasswd, newpasswd} = + (if not (mailboxExists {domain = domain, user = user}) then + SOME "Mailbox doesn't exist" + else if not (checkpassword {domain = domain, user = user, passwd = oldpasswd}) then + SOME "Old password incorrect" + else if not (setpassword {domain = domain, user = user, passwd = newpasswd}) then + SOME "Error setting password" + else if not (rebuild ()) then + SOME "Error reloading userdb" + else + NONE) + handle Userdb errmsg => SOME ("userdb error: " ^ errmsg) + 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"