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