merge toplevel-dynamic-environment
[hcoop/domtool2.git] / src / mail / vmail.sml
1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
2 * Copyright (c) 2006-2009, 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 open MsgTypes
24
25 fun rebuild () =
26 let
27 fun doNode (site, ok) =
28 (print ("New vmail data for node " ^ site ^ "\n");
29 if site = Config.dispatcherName then
30 Slave.shell [Config.Courier.postReload] andalso ok
31 else let
32 val bio = OpenSSL.connect true (Domain.get_context (),
33 Domain.nodeIp site
34 ^ ":"
35 ^ Int.toString Config.slavePort)
36 in
37 Msg.send (bio, MsgVmailChanged);
38 (case Msg.recv bio of
39 NONE => (print "Slave closed connection unexpectedly\n";
40 false)
41 | SOME m =>
42 case m of
43 MsgOk => (print ("Slave " ^ site ^ " finished\n");
44 ok)
45 | MsgError s => (print ("Slave " ^ site
46 ^ " returned error: " ^
47 s ^ "\n");
48 false)
49 | _ => (print ("Slave " ^ site
50 ^ " returned unexpected command\n");
51 false))
52 before OpenSSL.close bio
53 end)
54 in
55 Slave.shell [Config.Courier.pushUserdb]
56 andalso foldl doNode true Config.mailNodes_all
57 end
58
59 fun doChanged () =
60 Slave.shell [Config.Courier.pullUserdb]
61 andalso Slave.shell [Config.Courier.postReload]
62
63 datatype listing =
64 Error of string
65 | Listing of {user : string, mailbox : string} list
66
67 fun list domain =
68 let
69 val file = OS.Path.joinDirFile {dir = Config.Courier.userdbDir,
70 file = domain}
71 in
72 if Posix.FileSys.access (file, []) then
73 let
74 val inf = TextIO.openIn file
75
76 fun loop users =
77 case TextIO.inputLine inf of
78 NONE => Listing (rev users)
79 | SOME line =>
80 case String.tokens Char.isSpace line of
81 [addr, fields] =>
82 (case String.fields (fn ch => ch = #"@") addr of
83 [user, _] =>
84 let
85 fun parseFields fields =
86 case fields of
87 "mail" :: mailbox :: _ => loop ({user = user, mailbox = mailbox} :: users)
88 | _ :: _ :: rest => parseFields rest
89 | _ => Error "Invalid fields in database"
90 in
91 parseFields (String.fields (fn ch => ch = #"|" orelse ch = #"=") fields)
92 end
93 | _ => Error "Invalid e-mail address format in database")
94 | _ => Error "Invalid entry in database"
95 in
96 loop []
97 before TextIO.closeIn inf
98 end
99 else
100 Listing []
101 end
102 handle IO.Io {name, function, ...} =>
103 Error ("IO failure: " ^ name ^ ": " ^ function)
104
105 fun mailboxExists {domain, user} =
106 let
107 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.Courier.userdbDir,
108 file = domain})
109
110 fun loop () =
111 case TextIO.inputLine inf of
112 NONE => false
113 | SOME line =>
114 case String.tokens Char.isSpace line of
115 [addr, _] =>
116 (case String.fields (fn ch => ch = #"@") addr of
117 [user', _] =>
118 user' = user orelse loop ()
119 | _ => false)
120 | _ => false
121 in
122 loop ()
123 before TextIO.closeIn inf
124 end
125 handle IO.Io _ => false
126
127 fun add {domain, requester, user, passwd, mailbox} =
128 let
129 val udb = Posix.SysDB.getpwnam requester
130 val uid = SysWord.toInt (Posix.ProcEnv.uidToWord (Posix.SysDB.Passwd.uid udb))
131 val gid = SysWord.toInt (Posix.ProcEnv.gidToWord (Posix.SysDB.Passwd.gid udb))
132 val home = Posix.SysDB.Passwd.home udb
133 in
134 if mailboxExists {domain = domain, user = user} then
135 SOME "Mailbox mapping already exists"
136 else if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain,
137 "\" set home=", home, " mail=", mailbox,
138 " uid=", Int.toString uid, " gid=" ^ Int.toString gid]) then
139 SOME "Error running userdb"
140 else
141 let
142 val proc = Unix.execute ("/bin/sh", ["-c",
143 String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb,
144 " \"", domain, "/", 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 if not (OS.Process.isSuccess (Unix.reap proc)) then
150 (ignore (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]);
151 SOME "Error setting password")
152 else if not (rebuild ()) then
153 (ignore (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]);
154 SOME "Error reloading userdb")
155 else
156 NONE
157 end
158 end
159
160 fun passwd {domain, user, passwd} =
161 if not (mailboxExists {domain = domain, user = user}) then
162 SOME "Mailbox doesn't exist"
163 else let
164 val proc = Unix.execute ("/bin/sh", ["-c",
165 String.concat [Config.Courier.userdbpw, " | ", Config.Courier.userdb,
166 " \"", domain, "/", user, "@", domain, "\" set systempw"]])
167 val outf = Unix.textOutstreamOf proc
168 in
169 TextIO.output (outf, String.concat [passwd, "\n", passwd, "\n"]);
170 TextIO.closeOut outf;
171 if not (OS.Process.isSuccess (Unix.reap proc)) then
172 SOME "Error setting password"
173 else if not (rebuild ()) then
174 SOME "Error reloading userdb"
175 else
176 NONE
177 end
178
179 fun rm {domain, user} =
180 if not (mailboxExists {domain = domain, user = user}) then
181 SOME "Mailbox doesn't exist"
182 else if not (Slave.shell [Config.Courier.userdb, " \"", domain, "/", user, "@", domain, "\" del"]) then
183 SOME "Error deleting password entry"
184 else if not (rebuild ()) then
185 SOME "Error reloading userdb"
186 else
187 NONE
188
189 end