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 datatype listing =
  39          Error of string
  40        | Listing of {user : string, mailbox : string} list
  41
  42 fun list domain =
  43     let
  44         val file = OS.Path.joinDirFile {dir = Config.Vmail.userDatabase,
  45                                         file = domain}
  46     in
  47         if Posix.FileSys.access (file, []) then
  48             let
  49                 val inf = TextIO.openIn file
  50
  51                 fun loop users =
  52                     case TextIO.inputLine inf of
  53                         NONE => Listing (rev users)
  54                       | SOME line =>
  55                         case String.tokens Char.isSpace line of
  56                             [addr, fields] =>
  57                             (case String.fields (fn ch => ch = #"@") addr of
  58                                  [user, _] =>
  59                                  let
  60                                      fun parseFields fields =
  61                                          case fields of
  62                                              "mail" :: mailbox :: _ => loop ({user = user, mailbox = mailbox} :: users)
  63                                            | _ :: _ :: rest => parseFields rest
  64                                            | _ => Error "Invalid fields in database"
  65                                  in
  66                                      parseFields (String.fields (fn ch => ch = #"|" orelse ch = #"=") fields)
  67                                  end
  68                                | _ => Error "Invalid e-mail address format in database")
  69                           | _ => Error "Invalid entry in database"
  70             in
  71                 loop []
  72                 before TextIO.closeIn inf
  73             end
  74         else
  75             Listing []
  76     end
  77     handle IO.Io {name, function, ...} =>
  78            Error ("IO failure: " ^ name ^ ": " ^ function)
  79
  80 fun mailboxExists {domain, user} =
  81     let
  82         val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Vmail.userDatabase,
  83                                                       file = domain})
  84
  85         fun loop () =
  86             case TextIO.inputLine inf of
  87                 NONE => false
  88               | SOME line =>
  89                 case String.tokens Char.isSpace line of
  90                     [addr, _] =>
  91                     (case String.fields (fn ch => ch = #"@") addr of
  92                          [user', _] =>
  93                          user' = user orelse loop ()
  94                        | _ => false)
  95                   | _ => false
  96     in
  97         loop ()
  98         before TextIO.closeIn inf
  99     end
 100         handle IO.Io _ => false
 101
 102 fun setpassword {domain, user, passwd} =
 103     let
 104         val proc = Unix.execute ("/bin/sh", ["-c",
 105                                              String.concat [Config.Vmail.userdbpw, " | ", Config.Vmail.userdb,
 106                                                             " -f ", Config.Vmail.userDatabase, "/", domain,
 107                                                             " \"", user, "@", domain, "\" set systempw"]])
 108         val outf = Unix.textOutstreamOf proc
 109     in
 110         TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]);
 111         TextIO.closeOut outf;
 112         OS.Process.isSuccess (Unix.reap proc)
 113     end
 114
 115 fun deluser {domain, user} =
 116     Slave.run (Config.Vmail.userdb, ["-f", Config.Vmail.userDatabase ^ "/" ^ domain,
 117                                      user ^ "@" ^ domain, "del"])
 118
 119 fun add {domain, requester, user, passwd, mailbox} =
 120     let
 121         val udb = Posix.SysDB.getpwnam requester
 122         val uid = SysWord.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb))
 123         val gid = SysWord.toInt (Posix.ProcEnv.gidToWord (Posix.SysDB.Passwd.gid udb))
 124         val home = Posix.SysDB.Passwd.home udb
 125     in
 126         if mailboxExists {domain = domain, user = user} then
 127             SOME "Mailbox mapping already exists"
 128         else if not (Slave.run (Config.Vmail.userdb, ["-f", Config.Vmail.userDatabase ^ "/" ^ domain,
 129                                                       user ^ "@" ^ domain,
 130                                                       "set", "home=" ^ home, "mail=" ^ mailbox, "uid=" ^ Int.toString uid, "gid=" ^ Int.toString gid])) then
 131             SOME "Error running userdb"
 132         else if not (setpassword {domain = domain, user = user, passwd = passwd}) then
 133             (ignore (deluser {domain = domain, user = user});
 134              SOME "Error setting password")
 135         else if not (rebuild ()) then
 136             (ignore (deluser {domain = domain, user = user});
 137              SOME "Error reloading userdb")
 138         else
 139             NONE
 140     end
 141
 142 fun passwd {domain, user, passwd} =
 143     if not (mailboxExists {domain = domain, user = user}) then
 144         SOME "Mailbox doesn't exist"
 145     else  if not (setpassword {domain = domain, user = user, passwd = passwd}) then
 146         SOME "Error setting password"
 147     else if not (rebuild ()) then
 148         SOME "Error reloading userdb"
 149     else
 150         NONE
 151
 152 fun rm {domain, user} =
 153     if not (mailboxExists {domain = domain, user = user}) then
 154         SOME "Mailbox doesn't exist"
 155     else if not (deluser {domain = domain, user = user}) then
 156         SOME "Error deleting password entry"
 157     else if not (rebuild ()) then
 158         SOME "Error reloading userdb"
 159     else
 160         NONE
 161
 162 end