src/mail/vmail.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* Administration of Courier IMAP virtual mailboxes *)
  20
  21 structure Vmail :> VMAIL = struct
  22
  23 fun rebuild () = Slave.shell [Config.Courier.postReload]
  24
  25 datatype listing =
  26          Error of string
  27        | Listing of {user : string, mailbox : string} list
  28
  29 fun list domain =
  30     let
  31         val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Courier.userdbDir,
  32                                                       file = domain})
  33
  34         fun loop users =
  35             case TextIO.inputLine inf of
  36                 NONE => Listing (rev users)
  37               | SOME line =>
  38                 case String.tokens Char.isSpace line of
  39                     [addr, fields] =>
  40                     (case String.fields (fn ch => ch = #"@") addr of
  41                          [user, _] =>
  42                          let
  43                              fun parseFields fields =
  44                                  case fields of
  45                                      "mail" :: mailbox :: _ => loop ({user = user, mailbox = mailbox} :: users)
  46                                    | _ :: _ :: rest => parseFields rest
  47                                    | _ => Error "Invalid fields in database"
  48                          in
  49                              parseFields (String.fields (fn ch => ch = #"|" orelse ch = #"=") fields)
  50                          end
  51                        | _ => Error "Invalid e-mail address format in database")
  52                   | _ => Error "Invalid entry in database"
  53     in
  54         loop []
  55         before TextIO.closeIn inf
  56     end
  57         handle IO.Io _ => Listing []
  58
  59 fun mailboxExists {domain, user} =
  60     let
  61         val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Courier.userdbDir,
  62                                                       file = domain})
  63
  64         fun loop () =
  65             case TextIO.inputLine inf of
  66                 NONE => false
  67               | SOME line =>
  68                 case String.tokens Char.isSpace line of
  69                     [addr, _] =>
  70                     (case String.fields (fn ch => ch = #"@") addr of
  71                          [user', _] =>
  72                          user' = user orelse loop ()
  73                        | _ => false)
  74                   | _ => false
  75     in
  76         loop ()
  77         before TextIO.closeIn inf
  78     end
  79         handle IO.Io _ => false
  80
  81 fun add {domain, requester, user, passwd, mailbox} =
  82     let
  83         val udb = Posix.SysDB.getpwnam requester
  84         val uid = Word.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb))
  85         val gid = Word.toInt (Posix.ProcEnv.gidToWord (Posix.SysDB.Passwd.gid udb))
  86         val home = Posix.SysDB.Passwd.home udb
  87     in
  88         if mailboxExists {domain = domain, user = user} then
  89             SOME "Mailbox mapping already exists"
  90         else if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain,
  91                              "\" set home=", home, " mail=", mailbox,
  92                              " uid=", Int.toString uid, " gid=" ^ Int.toString gid]) then
  93             SOME "Error running userdb"
  94         else
  95             let
  96                 val proc = Unix.execute ("/bin/sh", ["-c",
  97                                                      String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb,
  98                                                                     " \"", domain, "/", user, "@", domain, "\" set systempw"]])
  99                 val outf = Unix.textOutstreamOf proc
 100             in
 101                 TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]);
 102                 TextIO.closeOut outf;
 103                 if not (OS.Process.isSuccess (Unix.reap proc)) then
 104                     (ignore (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]);
 105                      SOME "Error setting password")
 106                 else if not (rebuild ()) then
 107                     (ignore (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]);
 108                      SOME "Error reloading userdb")
 109                 else
 110                     NONE
 111             end
 112     end
 113
 114 fun passwd {domain, user, passwd} =
 115     if not (mailboxExists {domain = domain, user = user}) then
 116         SOME "Mailbox doesn't exist"
 117     else let
 118             val proc = Unix.execute ("/bin/sh", ["-c",
 119                                                  String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb,
 120                                                                 " \"", domain, "/", user, "@", domain, "\" set systempw"]])
 121             val outf = Unix.textOutstreamOf proc
 122         in
 123             TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]);
 124             TextIO.closeOut outf;
 125             if not (OS.Process.isSuccess (Unix.reap proc)) then
 126                 SOME "Error setting password"
 127             else if not (rebuild ()) then
 128                 SOME "Error reloading userdb"
 129             else
 130                 NONE
 131         end
 132
 133 fun rm {domain, user} =
 134     if not (mailboxExists {domain = domain, user = user}) then
 135         SOME "Mailbox doesn't exist"
 136     else if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]) then
 137         SOME "Error deleting password entry"
 138     else if not (rebuild ()) then
 139         SOME "Error reloading userdb"
 140     else
 141         NONE
 142
 143 end