Fixing some things that prevented SML/NJ compilation
[hcoop/domtool2.git] / 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 = SysWord.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb))
85 val gid = SysWord.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