From 629a34f64f780c03d049d20057acc9a487162272 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 30 Jul 2006 17:33:07 +0000 Subject: [PATCH] E-mail aliases --- src/alias.sig | 23 +++++++++ src/alias.sml | 127 ++++++++++++++++++++++++++++++++++++++++++++++ src/domain.sig | 4 ++ src/domain.sml | 33 +++++++++--- src/domtool.cm | 3 ++ src/domtool.grm | 2 + src/env.sig | 19 ++++++- src/env.sml | 55 +++++++++++++++++++- src/main.sml | 10 +++- src/print.sig | 2 + src/print.sml | 3 ++ src/tycheck.sig | 2 + src/tycheck.sml | 29 ++++++----- tests/domain2.dtl | 38 ++++++++++++-- 14 files changed, 321 insertions(+), 29 deletions(-) create mode 100644 src/alias.sig create mode 100644 src/alias.sml rewrite tests/domain2.dtl (61%) diff --git a/src/alias.sig b/src/alias.sig new file mode 100644 index 0000000..a0b5f6f --- /dev/null +++ b/src/alias.sig @@ -0,0 +1,23 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Configuring e-mail aliases *) + +signature ALIAS = sig + +end diff --git a/src/alias.sml b/src/alias.sml new file mode 100644 index 0000000..9449f2b --- /dev/null +++ b/src/alias.sml @@ -0,0 +1,127 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Configuring e-mail aliases *) + +structure Alias :> ALIAS = struct + +open Ast + +val aliases : TextIO.outstream option ref = ref NONE +fun aliasesF () = valOf (!aliases) + +val aliasesD : TextIO.outstream option ref = ref NONE +fun aliasesDF () = valOf (!aliasesD) + +fun write s = TextIO.output (aliasesF (), s) +fun writeD s = TextIO.output (aliasesDF (), s) + +val _ = Domain.registerBefore + (fn _ => (aliases := SOME (Domain.domainFile "aliases"); + aliasesD := SOME (Domain.domainFile "aliases.default"))) + +val _ = Domain.registerAfter + (fn _ => (TextIO.closeOut (aliasesF ()); + TextIO.closeOut (aliasesDF ()))) + +fun validEmailUser s = + size s > 0 andalso size s < 50 + andalso CharVector.all (fn ch => Char.isAlphaNum ch + orelse ch = #"." + orelse ch = #"_" + orelse ch = #"-" + orelse ch = #"+") s + +val _ = Env.type_one "emailUser" + Env.string + validEmailUser + +fun validEmail s = + case String.fields (fn ch => ch = #"@") s of + [user] => validEmailUser user + | [user, host] => validEmailUser user andalso Domain.validDomain host + | _ => false + +val _ = Env.type_one "email" + Env.string + validEmail + +datatype aliasSource = + User of string + | Default + | CatchAll + +val source = fn (EApp ((EVar "userSource", _), e), _) => + Option.map User (Env.string e) + | (EVar "defaultSource", _) => SOME Default + | (EVar "catchAllSource", _) => SOME CatchAll + | _ => NONE + +datatype aliasTarget = + Address of string + | Addresses of string list + | Drop + +val target = fn (EApp ((EVar "addressTarget", _), e), _) => + Option.map Address (Env.string e) + | (EApp ((EVar "addressesTarget", _), e), _) => + Option.map Addresses (Env.list Env.string e) + | (EVar "dropTarget", _) => SOME Drop + | _ => NONE + +fun localhostify s = + let + val (prefix, suffix) = Substring.splitl (fn ch => ch <> #"@") (Substring.full s) + in + if Substring.size suffix = 0 then + s ^ "@localhost" + else + s + end + +fun writeTarget (outf, t) = + case t of + Address s => TextIO.output (outf, localhostify s) + | Addresses [] => TextIO.output (outf, "!") + | Addresses ss => TextIO.output (outf, String.concatWith "," (map localhostify ss)) + | Drop => TextIO.output (outf, "!") + +fun writeSource (s, t) = + case s of + User s => (write s; + write "@"; + write (Domain.currentDomain ()); + write ": "; + writeTarget (aliasesF (), t); + write "\n") + | Default => (write "*@"; + write (Domain.currentDomain ()); + write ": "; + writeTarget (aliasesF (), t); + write "\n") + | CatchAll => (writeD "*@"; + writeD (Domain.currentDomain ()); + writeD ": "; + writeTarget (aliasesDF (), t); + writeD "\n") + +val _ = Env.action_two "aliasPrim" + ("from", source, "to", target) + writeSource + +end diff --git a/src/domain.sig b/src/domain.sig index eb94f3f..8c79274 100644 --- a/src/domain.sig +++ b/src/domain.sig @@ -20,6 +20,10 @@ signature DOMAIN = sig + val isIdent : char -> bool + val validHost : string -> bool + val validDomain : string -> bool + val registerBefore : (string -> unit) -> unit val registerAfter : (string -> unit) -> unit (* Register handlers to run just before and after entering a domain diff --git a/src/domain.sml b/src/domain.sml index 32b7ecf..99152ea 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -20,6 +20,24 @@ structure Domain :> DOMAIN = struct +fun isIdent ch = Char.isLower ch orelse Char.isDigit ch + +fun validHost s = + size s > 0 andalso size s < 20 + andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s + +fun validDomain s = + size s > 0 andalso size s < 100 + andalso List.all validHost (String.fields (fn ch => ch = #".") s) + +val _ = Env.type_one "host" + Env.string + validHost + +val _ = Env.type_one "domain" + Env.string + validDomain + open Ast val befores = ref (fn (_ : string) => ()) @@ -65,15 +83,14 @@ fun getPath domain = elems end) [] toks in - String.concatWith "/" (Config.configRoot :: rev elems) + String.concatWith "/" (Config.configRoot :: rev ("" :: elems)) end -val _ = Env.registerContainer ("domain", - fn (_, [(EString dom, _)]) => (current := dom; - currentPath := getPath dom; - !befores dom; - StringMap.empty) - | _ => Env.badArgs "domain", - fn () => !afters (!current)) +val _ = Env.container_one "domain" + ("domain", Env.string) + (fn dom => (current := dom; + currentPath := getPath dom; + !befores dom), + fn () => !afters (!current)) end diff --git a/src/domtool.cm b/src/domtool.cm index 34b52fc..33722c5 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -44,5 +44,8 @@ baseTypes.sml domain.sig domain.sml +alias.sig +alias.sml + main.sig main.sml diff --git a/src/domtool.grm b/src/domtool.grm index cd899e1..17ad3c1 100644 --- a/src/domtool.grm +++ b/src/domtool.grm @@ -85,6 +85,8 @@ decl : decl' docOpt (decl', docOpt, (decl'left, docOptrig decl' : EXTERN TYPE SYMBOL (DExternType SYMBOL) | EXTERN VAL SYMBOL COLON typ (DExternVal (SYMBOL, typ)) + | VAL SYMBOL EQ exp (DVal (SYMBOL, NONE, exp)) + | VAL SYMBOL COLON typ EQ exp (DVal (SYMBOL, SOME typ, exp)) docOpt : (NONE) | DOC (SOME DOC) diff --git a/src/env.sig b/src/env.sig index d239e14..adbf0b4 100644 --- a/src/env.sig +++ b/src/env.sig @@ -32,7 +32,24 @@ signature ENV = sig val registerContainer : string * action * (unit -> unit) -> unit val container : string -> (action * (unit -> unit)) option - val badArgs : string -> 'a + val badArgs : string * Ast.exp list -> 'a + val badArg : string * string * Ast.exp -> 'a + + type 'a arg = Ast.exp -> 'a option + + val int : int arg + val string : string arg + val list : 'a arg -> 'a list arg + + val one : string -> string * 'a arg -> ('a -> unit) -> action + val two : string -> string * 'a arg * string * 'b arg -> ('a * 'b -> unit) -> action + + val type_one : string -> 'a arg -> ('a -> bool) -> unit + + val action_one : string -> string * 'a arg -> ('a -> unit) -> unit + val action_two : string -> string * 'a arg * string * 'b arg -> ('a * 'b -> unit) -> unit + + val container_one : string -> string * 'a arg -> ('a -> unit) * (unit -> unit) -> unit type env val empty : env diff --git a/src/env.sml b/src/env.sml index 2141f64..acc7e36 100644 --- a/src/env.sml +++ b/src/env.sml @@ -41,7 +41,60 @@ fun registerContainer (name, befor, after) = containers := SM.insert (!containers, name, (befor, after)) fun container name = SM.find (!containers, name) -fun badArgs name = raise Fail ("Invalid arguments to " ^ name) +fun badArgs (name, args) = + (print ("Invalid arguments to " ^ name ^ "\n"); + app (fn arg => Print.preface ("Argument: ", Print.p_exp arg)) args; + raise Domain) +fun badArg (func, arg, v) = + (print ("Invalid " ^ arg ^ " argument to " ^ func ^ "\n"); + Print.preface ("Argument: ", Print.p_exp v); + raise Domain) + +type 'a arg = exp -> 'a option + +fun int (EInt n, _) = SOME n + | int _ = NONE + +fun string (EString s, _) = SOME s + | string _ = NONE + +fun mapFail f [] = SOME [] + | mapFail f (h :: t) = + case f h of + NONE => NONE + | SOME h' => + case mapFail f t of + NONE => NONE + | SOME t' => SOME (h' :: t') + +fun list f (EList ls, _) = mapFail f ls + | list _ _ = NONE + +fun one func (name, arg) f (_, [e]) = + (case arg e of + NONE => badArg (func, name, e) + | SOME v => (f v; + SM.empty)) + | one func _ _ (_, es) = badArgs (func, es) + +fun two func (name1, arg1, name2, arg2) f (_, [e1, e2]) = + (case (arg1 e1, arg2 e2) of + (NONE, _) => badArg (func, name1, e1) + | (_, NONE) => badArg (func, name2, e2) + | (SOME v1, SOME v2) => (f (v1, v2); + SM.empty)) + | two func _ _ (_, es) = badArgs (func, es) + +fun type_one func arg f = + registerType (func, fn e => + case arg e of + NONE => false + | SOME v => f v) + +fun action_one name args f = registerAction (name, one name args f) +fun action_two name args f = registerAction (name, two name args f) + +fun container_one name args (f, g) = registerContainer (name, one name args f, g) type env = SS.set * (typ * exp option) SM.map val empty : env = (SS.add (SS.singleton "int", "string"), diff --git a/src/main.sml b/src/main.sml index 7740522..bbf1091 100644 --- a/src/main.sml +++ b/src/main.sml @@ -84,7 +84,15 @@ fun eval fname = () else case prog of - (_, SOME body) => Eval.exec StringMap.empty body + (_, SOME body) => + let + val body' = Reduce.reduceExp G' body + in + if !ErrorMsg.anyErrors then + () + else + Eval.exec StringMap.empty body' + end | _ => () end end diff --git a/src/print.sig b/src/print.sig index 6d615e6..da6dbc1 100644 --- a/src/print.sig +++ b/src/print.sig @@ -28,4 +28,6 @@ val p_pred : Ast.pred -> PD.pp_desc val p_typ : Ast.typ -> PD.pp_desc val p_exp : Ast.exp -> PD.pp_desc +val preface : string * PD.pp_desc -> unit + end diff --git a/src/print.sml b/src/print.sml index 9305714..89a640c 100644 --- a/src/print.sml +++ b/src/print.sml @@ -129,4 +129,7 @@ fun printd d = SM.closeStream myStream end +fun preface (s, d) = printd (PD.hovBox (PD.PPS.Rel 0, + [PD.string s, PD.space 1, d])) + end diff --git a/src/tycheck.sig b/src/tycheck.sig index 6ef31a5..22b44c7 100644 --- a/src/tycheck.sig +++ b/src/tycheck.sig @@ -33,4 +33,6 @@ signature TYCHECK = sig val resetUnif : unit -> unit val newUnif : unit -> Ast.typ' + val preface : string * Print.PD.pp_desc -> unit + end diff --git a/src/tycheck.sml b/src/tycheck.sml index 8d35e2d..ac69a6d 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -112,9 +112,6 @@ datatype type_error = | UnboundVariable of string | WrongPred of string * pred * pred -fun preface (s, d) = printd (PD.hovBox (PD.PPS.Rel 0, - [PD.string s, PD.space 1, d])) - fun describe_unification_error t ue = case ue of UnifyPred (p1, p2) => @@ -281,17 +278,23 @@ fun whnorm (tAll as (t, loc)) = TUnif (_, ref (SOME tAll)) => whnorm tAll | _ => tAll +fun baseCondition t = + case whnorm t of + (TBase name, _) => typeRule name + | (TList t, _) => + (case baseCondition t of + NONE => NONE + | SOME f => SOME (fn (EList ls, _) => List.all f ls + | _ => false)) + | _ => NONE + fun hasTyp (e, t1, t2) = - case whnorm t2 of - (TBase name, _) => - (case typeRule name of - NONE => subTyp (t1, t2) - | SOME rule => - if rule e then - () - else - subTyp (t1, t2)) - | _ => subTyp (t1, t2) + if (case baseCondition t2 of + NONE => false + | SOME rule => rule e) then + () + else + subTyp (t1, t2) fun checkTyp G (tAll as (t, loc)) = let diff --git a/tests/domain2.dtl b/tests/domain2.dtl dissimilarity index 61% index 248f4a8..520abd1 100644 --- a/tests/domain2.dtl +++ b/tests/domain2.dtl @@ -1,5 +1,33 @@ -extern val domain : string -> Domain => [Root]; - -domain "hcoop.net" with - -end +extern type domain; +extern val domain : domain -> Domain => [Root]; + +extern type emailUser; +extern type email; + +extern type aliasSource; +extern val userSource : emailUser -> aliasSource; +extern val defaultSource : aliasSource; +extern val catchAllSource : aliasSource; + +extern type aliasTarget; +extern val addressTarget : email -> aliasTarget; +extern val addressesTarget : [email] -> aliasTarget; +extern val dropTarget : aliasTarget; + +extern val aliasPrim : aliasSource -> aliasTarget -> [Domain]; + +val alias = \user -> \email -> aliasPrim (userSource user) (addressTarget email); +val aliasMulti = \user -> \emails -> aliasPrim (userSource user) (addressesTarget emails); +val aliasDrop = \user -> aliasPrim (userSource user) dropTarget; + +val defaultAlias = \email -> aliasPrim defaultSource (addressTarget email); +val catchAllAlias = \email -> aliasPrim catchAllSource (addressTarget email); + +domain "hcoop.net" with + alias "schmeppo" "dlonker"; + aliasMulti "me" ["nowhere","smelly@yikes"]; + aliasDrop "yippo"; + + defaultAlias "billy"; + catchAllAlias "bonkers" +end -- 2.20.1