src/mail/vmail.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006-2009, Adam Chlipala
   3  * Copyright (c) 2014 Clinton Ebadi <clinton@unknownlamer.org>
   4  *
   5  * This program is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU General Public License
   7  * as published by the Free Software Foundation; either version 2
   8  * of the License, or (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  18  *)
  19
  20 (* Administration of Courier IMAP virtual mailboxes *)
  21
  22 structure Vmail :> VMAIL = struct
  23
  24 open MsgTypes
  25
  26 fun rebuild () =
  27     let
  28         fun doNode (site, ok) =
  29             (print ("New vmail data for node " ^ site ^ "\n");
  30              Connect.commandWorker (Domain.get_context (), site, MsgVmailChanged))
  31     in
  32         foldl doNode true Config.mailNodes_all
  33     end
  34
  35 fun doChanged () =
  36     Slave.shell [Config.Courier.postReload]
  37
  38
  39 structure SM = DataStructures.StringMap
  40
  41 exception Userdb of string
  42
  43 fun readUserdb domain =
  44     let
  45         val file = OS.Path.joinDirFile {dir = Config.Vmail.userDatabase,
  46                                         file = domain}
  47     in
  48         if Posix.FileSys.access (file, []) then
  49             let
  50                 val inf = TextIO.openIn file
  51
  52                 fun parseField (field, fields) =
  53                     case String.fields (fn ch => ch = #"=") field of
  54                         [key, value] => SM.insert (fields, key, value)
  55                       | _ => raise Userdb ("Malformed fields in vmail userdb for domain " ^ domain)
  56
  57                 fun loop users =
  58                     case TextIO.inputLine inf of
  59                         NONE => users
  60                       | SOME line =>
  61                         case String.tokens Char.isSpace line of
  62                             [addr, fields] => (case String.fields (fn ch => ch = #"@") addr of
  63                                                    [user, _] =>
  64                                                    loop (SM.insert (users, user, foldl parseField SM.empty (String.fields (fn ch => ch = #"|") fields)))
  65                                                  | _ => raise Userdb ("Malformed address in vmail userdb for " ^ domain ^ ": " ^ addr))
  66                           | _ => raise Userdb ("Malformed record in vmail userdb for domain " ^ domain)
  67             in
  68                 loop SM.empty
  69                 before TextIO.closeIn inf
  70             end
  71         else
  72             SM.empty
  73     end
  74
  75 datatype listing =
  76          Error of string
  77        | Listing of {user : string, mailbox : string} list
  78
  79 fun list domain =
  80     let
  81         val file = OS.Path.joinDirFile {dir = Config.Vmail.userDatabase,
  82                                         file = domain}
  83     in
  84         if Posix.FileSys.access (file, []) then
  85             let
  86                 val inf = TextIO.openIn file
  87
  88                 fun loop users =
  89                     case TextIO.inputLine inf of
  90                         NONE => Listing (rev users)
  91                       | SOME line =>
  92                         case String.tokens Char.isSpace line of
  93                             [addr, fields] =>
  94                             (case String.fields (fn ch => ch = #"@") addr of
  95                                  [user, _] =>
  96                                  let
  97                                      fun parseFields fields =
  98                                          case fields of
  99                                              "mail" :: mailbox :: _ => loop ({user = user, mailbox = mailbox} :: users)
 100                                            | _ :: _ :: rest => parseFields rest
 101                                            | _ => Error "Invalid fields in database"
 102                                  in
 103                                      parseFields (String.fields (fn ch => ch = #"|" orelse ch = #"=") fields)
 104                                  end
 105                                | _ => Error "Invalid e-mail address format in database")
 106                           | _ => Error "Invalid entry in database"
 107             in
 108                 loop []
 109                 before TextIO.closeIn inf
 110             end
 111         else
 112             Listing []
 113     end
 114     handle IO.Io {name, function, ...} =>
 115            Error ("IO failure: " ^ name ^ ": " ^ function)
 116
 117 fun mailboxExists {domain, user} =
 118     let
 119         val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Vmail.userDatabase,
 120                                                       file = domain})
 121
 122         fun loop () =
 123             case TextIO.inputLine inf of
 124                 NONE => false
 125               | SOME line =>
 126                 case String.tokens Char.isSpace line of
 127                     [addr, _] =>
 128                     (case String.fields (fn ch => ch = #"@") addr of
 129                          [user', _] =>
 130                          user' = user orelse loop ()
 131                        | _ => false)
 132                   | _ => false
 133     in
 134         loop ()
 135         before TextIO.closeIn inf
 136     end
 137         handle IO.Io _ => false
 138
 139 fun setpassword {domain, user, passwd} =
 140     let
 141         val proc = Unix.execute ("/bin/sh", ["-c",
 142                                              String.concat [Config.Vmail.userdbpw, " | ", Config.Vmail.userdb,
 143                                                             " -f ", Config.Vmail.userDatabase, "/", domain,
 144                                                             " \"", user, "@", domain, "\" set systempw"]])
 145         val outf = Unix.textOutstreamOf proc
 146     in
 147         TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]);
 148         TextIO.closeOut outf;
 149         OS.Process.isSuccess (Unix.reap proc)
 150     end
 151
 152
 153 fun checkpassword {domain, user, passwd} =
 154     let
 155         val proc = Unix.execute (Config.installPrefix ^ "/sbin/domtool-vmailpasswd", [])
 156         val outf = Unix.textOutstreamOf proc
 157         val db = readUserdb domain
 158     in
 159         case SM.find (db, user) of
 160             SOME fields =>
 161             (case SM.find (fields, "systempw") of
 162                  SOME systempw =>
 163                  (TextIO.output (outf, systempw ^ "\n");
 164                   TextIO.output (outf, passwd ^ "\n");
 165                   TextIO.closeOut outf;
 166                   OS.Process.isSuccess (Unix.reap proc))
 167                | NONE => raise Userdb ("systempw not found for user " ^ user ^ "@" ^ domain))
 168             | NONE => raise Userdb ("User " ^ user ^ " not found in vmail userdb for domain " ^ domain)
 169     end
 170
 171 fun deluser {domain, user} =
 172     Slave.run (Config.Vmail.userdb, ["-f", Config.Vmail.userDatabase ^ "/" ^ domain,
 173                                      user ^ "@" ^ domain, "del"])
 174
 175 fun add {domain, requester, user, passwd, mailbox} =
 176     let
 177         val udb = Posix.SysDB.getpwnam requester
 178         val uid = SysWord.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb))
 179         val gid = SysWord.toInt (Posix.ProcEnv.gidToWord (Posix.SysDB.Passwd.gid udb))
 180         val home = Posix.SysDB.Passwd.home udb
 181     in
 182         if mailboxExists {domain = domain, user = user} then
 183             SOME "Mailbox mapping already exists"
 184         else if not (Slave.run (Config.Vmail.userdb, ["-f", Config.Vmail.userDatabase ^ "/" ^ domain,
 185                                                       user ^ "@" ^ domain,
 186                                                       "set", "home=" ^ home, "mail=" ^ mailbox, "uid=" ^ Int.toString uid, "gid=" ^ Int.toString gid])) then
 187             SOME "Error running userdb"
 188         else if not (setpassword {domain = domain, user = user, passwd = passwd}) then
 189             (ignore (deluser {domain = domain, user = user});
 190              SOME "Error setting password")
 191         else if not (rebuild ()) then
 192             (ignore (deluser {domain = domain, user = user});
 193              SOME "Error reloading userdb")
 194         else
 195             NONE
 196     end
 197
 198 fun passwd {domain, user, passwd} =
 199     if not (mailboxExists {domain = domain, user = user}) then
 200         SOME "Mailbox doesn't exist"
 201     else  if not (setpassword {domain = domain, user = user, passwd = passwd}) then
 202         SOME "Error setting password"
 203     else if not (rebuild ()) then
 204         SOME "Error reloading userdb"
 205     else
 206         NONE
 207
 208 fun portalpasswd {domain, user, oldpasswd, newpasswd} =
 209     (if not (mailboxExists {domain = domain, user = user}) then
 210          SOME "Mailbox doesn't exist"
 211      else if not (checkpassword {domain = domain, user = user, passwd = oldpasswd}) then
 212          SOME "Old password incorrect"
 213      else  if not (setpassword {domain = domain, user = user, passwd = newpasswd}) then
 214          SOME "Error setting password"
 215      else if not (rebuild ()) then
 216          SOME "Error reloading userdb"
 217      else
 218          NONE)
 219     handle Userdb errmsg => SOME ("userdb error: " ^ errmsg)
 220
 221 fun rm {domain, user} =
 222     if not (mailboxExists {domain = domain, user = user}) then
 223         SOME "Mailbox doesn't exist"
 224     else if not (deluser {domain = domain, user = user}) then
 225         SOME "Error deleting password entry"
 226     else if not (rebuild ()) then
 227         SOME "Error reloading userdb"
 228     else
 229         NONE
 230
 231 end