Changes to support IMAP on hopper all compile but are not tested yet

[hcoop/domtool2.git] / src / mail / vmail.sml

(* HCoop Domtool (http://hcoop.sourceforge.net/)
 * Copyright (c) 2006-2009, 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

open MsgTypes

fun rebuild () =
    let
	fun doNode (site, ok) =
	    (print ("New vmail data for node " ^ site ^ "\n");
	     if site = Config.defaultNode then
		 Slave.shell [Config.Courier.postReload] andalso ok
	     else let
		     val bio = OpenSSL.connect true (Domain.get_context (),
						     Domain.nodeIp site
						     ^ ":"
						     ^ Int.toString Config.slavePort)
		 in
		     Msg.send (bio, MsgVmailChanged);
		     (case Msg.recv bio of
			  NONE => (print "Slave closed connection unexpectedly\n";
				   false)
			| SOME m =>
			  case m of
			      MsgOk => (print ("Slave " ^ site ^ " finished\n");
					ok)
			    | MsgError s => (print ("Slave " ^ site
						    ^ " returned error: " ^
						    s ^ "\n");
					     false)
			    | _ => (print ("Slave " ^ site
					   ^ " returned unexpected command\n");
				    false))
		     before OpenSSL.close bio
		 end)
    in
	Slave.shell [Config.Courier.pushUserdb]
	andalso foldl doNode true Config.mailNodes_all
    end

fun doChanged () =
    Slave.shell [Config.Courier.pullUserdb]
    andalso 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.Courier.userdbDir,
					file = domain}
    in
	if Posix.FileSys.access (file, []) then
	    let
		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
		loop []
		before TextIO.closeIn inf
	    end
	else
	    Listing []
    end
    handle IO.Io {name, function, ...} =>
	   Error ("IO failure: " ^ name ^ ": " ^ function)

fun mailboxExists {domain, user} =
    let
	val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Courier.userdbDir,
						      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 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.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} =
    if not (mailboxExists {domain = domain, user = user}) then
	SOME "Mailbox doesn't exist"
    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
		SOME "Error setting password"
	    else if not (rebuild ()) then
		SOME "Error reloading userdb"
	    else
		NONE
	end

fun rm {domain, user} =
    if not (mailboxExists {domain = domain, user = user}) then
	SOME "Mailbox doesn't exist"
    else 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