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