E-mail aliases
[hcoop/domtool2.git] / src / 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
25val aliases : TextIO.outstream option ref = ref NONE
26fun aliasesF () = valOf (!aliases)
27
28val aliasesD : TextIO.outstream option ref = ref NONE
29fun aliasesDF () = valOf (!aliasesD)
30
31fun write s = TextIO.output (aliasesF (), s)
32fun writeD s = TextIO.output (aliasesDF (), s)
33
34val _ = Domain.registerBefore
35 (fn _ => (aliases := SOME (Domain.domainFile "aliases");
36 aliasesD := SOME (Domain.domainFile "aliases.default")))
37
38val _ = Domain.registerAfter
39 (fn _ => (TextIO.closeOut (aliasesF ());
40 TextIO.closeOut (aliasesDF ())))
41
42fun validEmailUser s =
43 size s > 0 andalso size s < 50
44 andalso CharVector.all (fn ch => Char.isAlphaNum ch
45 orelse ch = #"."
46 orelse ch = #"_"
47 orelse ch = #"-"
48 orelse ch = #"+") s
49
50val _ = Env.type_one "emailUser"
51 Env.string
52 validEmailUser
53
54fun validEmail s =
55 case String.fields (fn ch => ch = #"@") s of
56 [user] => validEmailUser user
57 | [user, host] => validEmailUser user andalso Domain.validDomain host
58 | _ => false
59
60val _ = Env.type_one "email"
61 Env.string
62 validEmail
63
64datatype aliasSource =
65 User of string
66 | Default
67 | CatchAll
68
69val source = fn (EApp ((EVar "userSource", _), e), _) =>
70 Option.map User (Env.string e)
71 | (EVar "defaultSource", _) => SOME Default
72 | (EVar "catchAllSource", _) => SOME CatchAll
73 | _ => NONE
74
75datatype aliasTarget =
76 Address of string
77 | Addresses of string list
78 | Drop
79
80val target = fn (EApp ((EVar "addressTarget", _), e), _) =>
81 Option.map Address (Env.string e)
82 | (EApp ((EVar "addressesTarget", _), e), _) =>
83 Option.map Addresses (Env.list Env.string e)
84 | (EVar "dropTarget", _) => SOME Drop
85 | _ => NONE
86
87fun localhostify s =
88 let
89 val (prefix, suffix) = Substring.splitl (fn ch => ch <> #"@") (Substring.full s)
90 in
91 if Substring.size suffix = 0 then
92 s ^ "@localhost"
93 else
94 s
95 end
96
97fun writeTarget (outf, t) =
98 case t of
99 Address s => TextIO.output (outf, localhostify s)
100 | Addresses [] => TextIO.output (outf, "!")
101 | Addresses ss => TextIO.output (outf, String.concatWith "," (map localhostify ss))
102 | Drop => TextIO.output (outf, "!")
103
104fun writeSource (s, t) =
105 case s of
106 User s => (write s;
107 write "@";
108 write (Domain.currentDomain ());
109 write ": ";
110 writeTarget (aliasesF (), t);
111 write "\n")
112 | Default => (write "*@";
113 write (Domain.currentDomain ());
114 write ": ";
115 writeTarget (aliasesF (), t);
116 write "\n")
117 | CatchAll => (writeD "*@";
118 writeD (Domain.currentDomain ());
119 writeD ": ";
120 writeTarget (aliasesDF (), t);
121 writeD "\n")
122
123val _ = Env.action_two "aliasPrim"
124 ("from", source, "to", target)
125 writeSource
126
127end