--- /dev/null
+(* 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
--- /dev/null
+(* 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
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
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) => ())
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
domain.sig
domain.sml
+alias.sig
+alias.sml
+
main.sig
main.sml
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)
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
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"),
()
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
val p_typ : Ast.typ -> PD.pp_desc
val p_exp : Ast.exp -> PD.pp_desc
+val preface : string * PD.pp_desc -> unit
+
end
SM.closeStream myStream
end
+fun preface (s, d) = printd (PD.hovBox (PD.PPS.Rel 0,
+ [PD.string s, PD.space 1, d]))
+
end
val resetUnif : unit -> unit
val newUnif : unit -> Ast.typ'
+ val preface : string * Print.PD.pp_desc -> unit
+
end
| 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) =>
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
-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
HCoop / hcoop / domtool2.git / commitdiff