Domain alias support for e-mail aliases
[hcoop/domtool2.git] / src / plugins / alias.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 (* Configuring e-mail aliases *)
20
21 structure Alias :> ALIAS = struct
22
23 open Ast
24
25 structure SM = DataStructures.StringMap
26
27 val aliases : Domain.files SM.map ref = ref SM.empty
28 fun aliasesF node = valOf (SM.find (!aliases, node))
29
30 val aliasesD : Domain.files SM.map ref = ref SM.empty
31 fun aliasesDF node = valOf (SM.find (!aliasesD, node))
32
33 fun write nodes =
34 let
35 val files = map (fn node => aliasesF node) nodes
36 in
37 (fn s => app (fn file => #write file s) files,
38 fn () => app (fn file => #writeDom file ()) files)
39 end
40
41 fun writeD nodes =
42 let
43 val files = map (fn node => aliasesDF node) nodes
44 in
45 (fn s => app (fn file => #write file s) files,
46 fn () => app (fn file => #writeDom file ()) files)
47 end
48
49 fun openInAll base = foldl (fn (node, r) =>
50 SM.insert (r,
51 node,
52 Domain.domainsFile {node = node, name = base}))
53 SM.empty Domain.nodes
54
55 val _ = Domain.registerBefore
56 (fn _ => (aliases := openInAll "aliases";
57 aliasesD := openInAll "aliases.default"))
58
59 val _ = Domain.registerAfter
60 (fn _ => (SM.app (fn file => #close file ()) (!aliases);
61 SM.app (fn file => #close file ()) (!aliasesD)))
62
63 fun validEmailUser s =
64 size s > 0 andalso size s < 50
65 andalso CharVector.all (fn ch => Char.isAlphaNum ch
66 orelse ch = #"."
67 orelse ch = #"_"
68 orelse ch = #"-"
69 orelse ch = #"+") s
70
71 val _ = Env.type_one "emailUser"
72 Env.string
73 validEmailUser
74
75 fun validEmail s =
76 case String.fields (fn ch => ch = #"@") s of
77 [user] => validEmailUser user
78 | [user, host] => validEmailUser user andalso Domain.validDomain host
79 | _ => false
80
81 val _ = Env.type_one "email"
82 Env.string
83 validEmail
84
85 datatype aliasSource =
86 User of string
87 | Default
88 | CatchAll
89
90 val source = fn (EApp ((EVar "userSource", _), e), _) =>
91 Option.map User (Env.string e)
92 | (EVar "defaultSource", _) => SOME Default
93 | (EVar "catchAllSource", _) => SOME CatchAll
94 | _ => NONE
95
96 datatype aliasTarget =
97 Address of string
98 | Addresses of string list
99 | Drop
100
101 val target = fn (EApp ((EVar "addressTarget", _), e), _) =>
102 Option.map Address (Env.string e)
103 | (EApp ((EVar "addressesTarget", _), e), _) =>
104 Option.map Addresses (Env.list Env.string e)
105 | (EVar "dropTarget", _) => SOME Drop
106 | _ => NONE
107
108 fun localhostify s =
109 let
110 val (prefix, suffix) = Substring.splitl (fn ch => ch <> #"@") (Substring.full s)
111 in
112 if Substring.size suffix = 0 then
113 s ^ "@localhost"
114 else
115 s
116 end
117
118 fun writeSource (env, s, t) =
119 let
120 val nodes = Env.env (Env.list Env.string) (env, "MailNodes")
121
122 val (write, writeDom) = write nodes
123 val (writeD, writeDomD) = writeD nodes
124
125 fun writeTarget (writer, t) =
126 case t of
127 Address s => writer (localhostify s)
128 | Addresses [] => writer "!"
129 | Addresses ss => writer (String.concatWith "," (map localhostify ss))
130 | Drop => writer "!"
131 in
132 case s of
133 User s => (write s;
134 write "@";
135 writeDom ();
136 write ": ";
137 writeTarget (write, t);
138 write "\n")
139 | Default => (write "*@";
140 writeDom ();
141 write ": ";
142 writeTarget (write, t);
143 write "\n")
144 | CatchAll => (writeD "*@";
145 writeDomD ();
146 writeD ": ";
147 writeTarget (writeD, t);
148 writeD "\n")
149 end
150
151 val _ = Env.actionV_two "aliasPrim"
152 ("from", source, "to", target)
153 writeSource
154
155 end