1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
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
.
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
.
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
.
19 (* Administration
of Courier IMAP virtual mailboxes
*)
21 structure Vmail
:> VMAIL
= struct
23 fun rebuild () = Slave
.shell
[Config
.Courier
.postReload
]
27 | Listing
of {user
: string, mailbox
: string} list
31 val inf
= TextIO.openIn (OS
.Path
.joinDirFile
{dir
= Config
.Courier
.userdbDir
,
35 case TextIO.inputLine inf
of
36 NONE
=> Listing (rev users
)
38 case String.tokens
Char.isSpace line
of
40 (case String.fields (fn ch
=> ch
= #
"@") addr
of
43 fun parseFields fields
=
45 "mail" :: mailbox
:: _
=> loop ({user
= user
, mailbox
= mailbox
} :: users
)
46 | _
:: _
:: rest
=> parseFields rest
47 | _
=> Error
"Invalid fields in database"
49 parseFields (String.fields (fn ch
=> ch
= #
"|" orelse ch
= #
"=") fields
)
51 | _
=> Error
"Invalid e-mail address format in database")
52 | _
=> Error
"Invalid entry in database"
55 before TextIO.closeIn inf
57 handle IO
.Io _
=> Listing
[]
59 fun mailboxExists
{domain
, user
} =
61 val inf
= TextIO.openIn (OS
.Path
.joinDirFile
{dir
= Config
.Courier
.userdbDir
,
65 case TextIO.inputLine inf
of
68 case String.tokens
Char.isSpace line
of
70 (case String.fields (fn ch
=> ch
= #
"@") addr
of
72 user
' = user
orelse loop ()
77 before TextIO.closeIn inf
79 handle IO
.Io _
=> false
81 fun add
{domain
, requester
, user
, passwd
, mailbox
} =
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
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"
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
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")
114 fun passwd
{domain
, user
, passwd
} =
115 if not (mailboxExists
{domain
= domain
, user
= user
}) then
116 SOME
"Mailbox doesn't exist"
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
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"
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"