src/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 val aliases : TextIO.outstream option ref = ref NONE
  26 fun aliasesF () = valOf (!aliases)
  27
  28 val aliasesD : TextIO.outstream option ref = ref NONE
  29 fun aliasesDF () = valOf (!aliasesD)
  30
  31 fun write s = TextIO.output (aliasesF (), s)
  32 fun writeD s = TextIO.output (aliasesDF (), s)
  33
  34 val _ = Domain.registerBefore
  35             (fn _ => (aliases := SOME (Domain.domainFile "aliases");
  36                       aliasesD := SOME (Domain.domainFile "aliases.default")))
  37
  38 val _ = Domain.registerAfter
  39         (fn _ => (TextIO.closeOut (aliasesF ());
  40                   TextIO.closeOut (aliasesDF ())))
  41
  42 fun 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
  50 val _ = Env.type_one "emailUser"
  51         Env.string
  52         validEmailUser
  53
  54 fun 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
  60 val _ = Env.type_one "email"
  61         Env.string
  62         validEmail
  63
  64 datatype aliasSource =
  65          User of string
  66        | Default
  67        | CatchAll
  68
  69 val 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
  75 datatype aliasTarget =
  76          Address of string
  77        | Addresses of string list
  78        | Drop
  79
  80 val 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
  87 fun 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
  97 fun 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
 104 fun 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
 123 val _ = Env.action_two "aliasPrim"
 124                        ("from", source, "to", target)
 125                        writeSource
 126
 127 end