lib: switch from php5 to fast_php by default

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

diff --git a/src/mail/vmail.sml b/src/mail/vmail.sml
index f5010eb..0594fb1 100644 (file)
--- a/src/mail/vmail.sml
+++ b/src/mail/vmail.sml
@@ -1,5 +1,6 @@
 (* HCoop Domtool (http://hcoop.sourceforge.net/)
 (* HCoop Domtool (http://hcoop.sourceforge.net/)

- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2009, Adam Chlipala
+ * Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>

  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License
  *
  * This program is free software; you can redistribute it and/or
  * modify it under the terms of the GNU General Public License


@@ -20,83 +21,207 @@
 
 structure Vmail :> VMAIL = struct
 
 
 structure Vmail :> VMAIL = struct
 

-fun rebuild () = Slave.shell [Config.Courier.postReload]
+open MsgTypes
+
+fun rebuild () =
+    let
+       fun doNode (site, ok) =
+           (print ("New vmail data for node " ^ site ^ "\n");
+            Connect.commandWorker (Domain.get_context (), site, MsgVmailChanged))
+    in
+       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
 
 datatype listing =
         Error of string

-       | Listing of string list
+       | Listing of {user : string, mailbox : string} list

 
 fun list domain =
     let
 
 fun list domain =
     let

-       val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Courier.userdbDir,
+       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 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.Vmail.userDatabase,

                                                      file = domain})
 
                                                      file = domain})
 

-       fun loop users =
+       fun loop () =

            case TextIO.inputLine inf of
            case TextIO.inputLine inf of

-               NONE => Listing (rev users)
+               NONE => false

              | SOME line =>
                case String.tokens Char.isSpace line of
                    [addr, _] =>
                    (case String.fields (fn ch => ch = #"@") addr of
              | SOME line =>
                case String.tokens Char.isSpace line of
                    [addr, _] =>
                    (case String.fields (fn ch => ch = #"@") addr of

-                        [user, _] => loop (user :: users)
-                      | _ => Error "Invalid e-mail address format in database")
-                 | _ => Error "Invalid entry in database"
+                        [user', _] =>
+                        user' = user orelse loop ()
+                      | _ => false)
+                 | _ => false

     in
     in

-       loop []
+       loop ()

        before TextIO.closeIn inf
     end
        before TextIO.closeIn inf
     end

-       handle IO.Io _ => Listing []
+       handle IO.Io _ => false

 
 

-fun add {domain, requester, user, passwd, mailbox} =
+fun setpassword {domain, user, passwd} =

     let
     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
+       val proc = Unix.execute ("/bin/sh", ["-c",
+                                            String.concat [Config.Vmail.userdbpw, " | ", Config.Vmail.userdb,
+                                                           " -f ", Config.Vmail.userDatabase, "/", domain,
+                                                           " \"", user, "@", domain, "\" set systempw"]])
+       val outf = Unix.textOutstreamOf proc

     in
     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
+       TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]);
+       TextIO.closeOut outf;
+       OS.Process.isSuccess (Unix.reap proc)

     end
 
     end
 

-fun passwd {domain, user, passwd} =
+
+fun checkpassword {domain, user, passwd} =

     let
     let

-       val proc = Unix.execute ("/bin/sh", ["-c",
-                                            String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb,
-                                                           " \"", domain, "/", user, "@", domain, "\" set systempw"]])
+       val proc = Unix.execute (Config.installPrefix ^ "/sbin/domtool-vmailpasswd", [])

        val outf = Unix.textOutstreamOf proc
        val outf = Unix.textOutstreamOf proc

+       val db = readUserdb domain

     in
     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"
+       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
        else if not (rebuild ()) then

-           SOME "Error reloading userdb"
+           (ignore (deluser {domain = domain, user = user});
+            SOME "Error reloading userdb")

        else
            NONE
     end
 
        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} =
 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"
        SOME "Error deleting password entry"
     else if not (rebuild ()) then
        SOME "Error reloading userdb"