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