fwtool: allow udp/tcp for all user rules
[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 fun 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 fun reopenAliasesD () = (SM.app (fn {close, ...} => close ()) (!aliasesD);
56 aliasesD := openInAll "aliases.default")
57
58 val _ = Domain.registerBefore
59 (fn _ => (aliases := openInAll "aliases.base";
60 reopenAliasesD ()))
61
62 val _ = Domain.registerAfter
63 (fn _ => (SM.app (fn file => #close file ()) (!aliases);
64 SM.app (fn file => #close file ()) (!aliasesD)))
65
66 fun validEmailUser s =
67 size s > 0 andalso size s < 50
68 andalso CharVector.all (fn ch => Char.isAlphaNum ch
69 orelse ch = #"."
70 orelse ch = #"_"
71 orelse ch = #"-"
72 orelse ch = #"+") s
73
74 val _ = Env.type_one "emailUser"
75 Env.string
76 validEmailUser
77
78 fun validEmail s =
79 case String.fields (fn ch => ch = #"@") s of
80 [user] => validEmailUser user
81 | [user, host] => validEmailUser user andalso Domain.validDomain host
82 | _ => false
83
84 val _ = Env.type_one "email"
85 Env.string
86 validEmail
87
88 datatype aliasSource =
89 User of string
90 | Default
91
92 val source = fn (EApp ((EVar "userSource", _), e), _) =>
93 Option.map User (Env.string e)
94 | (EVar "defaultSource", _) => SOME Default
95 | _ => NONE
96
97 datatype aliasTarget =
98 Address of string
99 | Addresses of string list
100 | Drop
101
102 val target = fn (EApp ((EVar "addressTarget", _), e), _) =>
103 Option.map Address (Env.string e)
104 | (EApp ((EVar "addressesTarget", _), e), _) =>
105 Option.map Addresses (Env.list Env.string e)
106 | (EVar "dropTarget", _) => SOME Drop
107 | _ => NONE
108
109 fun localhostify s =
110 let
111 val (prefix, suffix) = Substring.splitl (fn ch => ch <> #"@") (Substring.full s)
112 in
113 if Substring.size suffix = 0 then
114 s ^ "@localhost"
115 else
116 s
117 end
118
119 fun writeSource (env, s, t) =
120 let
121 val nodes = Env.env (Env.list Env.string) (env, "MailNodes")
122
123 val (write, writeDom) = write nodes
124 val (writeD, writeDomD) = writeD nodes
125
126 fun writeTarget (writer, t) =
127 case t of
128 Address s => writer (localhostify s)
129 | Addresses [] => writer "!"
130 | Addresses ss => writer (String.concatWith "," (map localhostify ss))
131 | Drop => writer "!"
132 in
133 case s of
134 User s => (write s;
135 write "@";
136 writeDom ();
137 write ": ";
138 writeTarget (write, t);
139 write "\n")
140 | Default => (reopenAliasesD ();
141 writeD "*@";
142 writeDomD ();
143 writeD ": ";
144 writeTarget (writeD, t);
145 writeD "\n")
146 end
147
148 val _ = Env.actionV_two "aliasPrim"
149 ("from", source, "to", target)
150 writeSource
151
152 end