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