From 6bb366c5a60247419dce5cbce4a5c034fa2f1e5c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 6 Sep 2006 03:22:45 +0000 Subject: [PATCH] Changes before announcement to hcoop-discuss --- lib/easy_domain.dtl | 22 ++++++++++++++++++++++ src/ast.sml | 2 ++ src/autodoc.sml | 15 +++++++++------ src/domain.sml | 4 ++++ src/domtool.grm | 4 +++- src/domtool.lex | 1 + src/htmlPrint.sml | 3 +++ src/main.sml | 12 ++++++++---- src/order.sml | 9 ++++++++- src/print.sml | 3 +++ src/reduce.sml | 30 +++++++++++++++++++++++++++++- src/tycheck.sml | 17 +++++++++++++++++ tests/testBusy.dtl | 45 +++++++++++++++++++++++++++++++++++++++++++++ tests/testEasy.dtl | 2 ++ 14 files changed, 156 insertions(+), 13 deletions(-) create mode 100644 lib/easy_domain.dtl create mode 100644 tests/testBusy.dtl create mode 100644 tests/testEasy.dtl diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl new file mode 100644 index 0000000..9a1ace5 --- /dev/null +++ b/lib/easy_domain.dtl @@ -0,0 +1,22 @@ +{{The most common kinds of domain configuration}} + +val web_ip : (ip) = "1.2.3.4"; + +val dom = + \ d : (your_domain) -> + \\ config : Domain -> + domain d with + dns (dnsNS "ns.hcoop.net"); + dns (dnsNS "ns2.hcoop.net"); + + dns (dnsA "www" web_ip); + + handleMail; + mailbox <- Mailbox; + catchAllAlias mailbox; + + vhost "www" with + end; + + config + end; diff --git a/src/ast.sml b/src/ast.sml index 667a26c..7a9fe25 100644 --- a/src/ast.sml +++ b/src/ast.sml @@ -89,6 +89,8 @@ datatype exp' = * action are abandoned *) | EWith of exp * exp (* Apply a TNested to an action *) + | EALam of string * pred * exp + (* Abstraction for building TNested values *) withtype exp = exp' * position datatype decl' = diff --git a/src/autodoc.sml b/src/autodoc.sml index 87134e4..b342e6e 100644 --- a/src/autodoc.sml +++ b/src/autodoc.sml @@ -144,15 +144,18 @@ fun autodoc {outdir, infiles} = val items = map (fn file => let val file' = modify file + val (desc, _, _) = Parse.parse file in LI {ty = NONE, value = NONE, - content = TextBlock (A {name = NONE, - href = SOME (file' ^ ".html"), - rel = NONE, - rev = NONE, - title = NONE, - content = PCDATA (uppercase file')})} + content = BlockList + [TextBlock (A {name = NONE, + href = SOME (file' ^ ".html"), + rel = NONE, + rev = NONE, + title = NONE, + content = PCDATA (uppercase file')}), + TextBlock (PCDATA (Option.getOpt (desc, "")))]} end) infiles val index = HTML {version = NONE, diff --git a/src/domain.sml b/src/domain.sml index 38993a2..34d6d10 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -172,6 +172,10 @@ val masterD = (EApp ((EVar "internalMaster", dl), (EString Config.defaultNode, dl)), dl) +val _ = Defaults.registerDefault ("Mailbox", + (TBase "email", dl), + (fn () => (EString (getUser ()), dl))) + val _ = Defaults.registerDefault ("DNS", (TBase "dnsKind", dl), (fn () => multiApp ((EVar "useDns", dl), diff --git a/src/domtool.grm b/src/domtool.grm index 549a183..ca9ff3a 100644 --- a/src/domtool.grm +++ b/src/domtool.grm @@ -31,7 +31,7 @@ open Ast | ARROW | DARROW | LARROW | COLON | CARET | BANG | AND | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE - | EQ | COMMA | BSLASH | SEMI | LET | IN | END + | EQ | COMMA | BSLASH | BSLASHBSLASH | SEMI | LET | IN | END | ROOT | EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT @@ -114,6 +114,8 @@ exp : apps (apps) | BSLASH SYMBOL COLON LPAREN typ RPAREN ARROW exp (ELam (SYMBOL, SOME typ, exp), (BSLASHleft, expright)) | BSLASH SYMBOL ARROW exp (ELam (SYMBOL, NONE, exp), (BSLASHleft, expright)) + | BSLASHBSLASH SYMBOL COLON ctxt ARROW exp (EALam (SYMBOL, ctxt, exp), + (BSLASHBSLASHleft, expright)) | CSYMBOL EQ exp (ESet (CSYMBOL, exp), (CSYMBOLleft, expright)) | exp SEMI exp (let val ls = case #1 exp2 of diff --git a/src/domtool.lex b/src/domtool.lex index cafd14e..80c06c7 100644 --- a/src/domtool.lex +++ b/src/domtool.lex @@ -115,6 +115,7 @@ lineComment = #[^\n]*\n; "=" => (Tokens.EQ (yypos, yypos + size yytext)); "," => (Tokens.COMMA (yypos, yypos + size yytext)); + "\\\\" => (Tokens.BSLASHBSLASH (yypos, yypos + size yytext)); "\\" => (Tokens.BSLASH (yypos, yypos + size yytext)); ":" => (Tokens.COLON (yypos, yypos + size yytext)); ";" => (Tokens.SEMI (yypos, yypos + size yytext)); diff --git a/src/htmlPrint.sml b/src/htmlPrint.sml index 5b756c3..2018556 100644 --- a/src/htmlPrint.sml +++ b/src/htmlPrint.sml @@ -139,6 +139,9 @@ fun p_exp (e, _) = punct ":", space 1, dBox [punct "(", p_typ t, punct ")"], space 1, punct "->", space 1, p_exp e, punct ")"] + | EALam (x, p, e) => dBox [punct "(\\", space 1, exp x, space 1, + punct ":", space 1, p_pred p, + space 1, punct "->", space 1, p_exp e, punct ")"] | EVar x => exp x | EApp (e1, e2) => dBox [punct "(", p_exp e1, break {nsp = 1, offset = 0}, p_exp e2, punct ")"] diff --git a/src/main.sml b/src/main.sml index 87a1b73..461207a 100644 --- a/src/main.sml +++ b/src/main.sml @@ -63,6 +63,12 @@ fun basis () = fun check fname = let + val uid = Posix.ProcEnv.getuid () + val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) + + val () = Acl.read Config.aclFile + val () = Domain.setUser user + val _ = ErrorMsg.reset () val _ = Env.preTycheck () @@ -133,13 +139,11 @@ fun hostname () = fun request fname = let + val _ = check fname + val uid = Posix.ProcEnv.getuid () val user = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) - val () = Acl.read Config.aclFile - val () = Domain.setUser user - val _ = check fname - val context = OpenSSL.context (Config.certDir ^ "/" ^ user ^ ".pem", Config.keyDir ^ "/" ^ user ^ ".pem", Config.trustStore) diff --git a/src/order.sml b/src/order.sml index cf1dee1..0d0d363 100644 --- a/src/order.sml +++ b/src/order.sml @@ -70,7 +70,7 @@ fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) = val dt = (TError, ErrorMsg.dummyLoc) -fun expNeeded G (e, _) = +fun expNeeded G (e, loc) = case e of EInt _ => ((SS.empty, if Env.lookupType G "int" then @@ -96,6 +96,13 @@ fun expNeeded G (e, _) = | SOME t => unionCTE ((typNeeded G t, SS.empty), expNeeded G' e) end + | EALam (x, p, e) => + let + val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE) + in + unionCTE (((predNeeded G p, SS.empty), SS.empty), + expNeeded G' e) + end | EVar x => (case Env.lookupVal G x of NONE => ((SS.empty, SS.empty), SS.singleton x) diff --git a/src/print.sml b/src/print.sml index 76d3fd1..7e38bb5 100644 --- a/src/print.sml +++ b/src/print.sml @@ -99,6 +99,9 @@ fun p_exp (e, _) = string ":", space 1, dBox [string "(", p_typ t, string ")"], space 1, string "->", space 1, p_exp e, string ")"] + | EALam (x, c, e) => dBox [string "(\\\\", space 1, string x, space 1, + string ":", space 1, p_pred c, + space 1, string "->", space 1, p_exp e, string ")"] | EVar x => string x | EApp (e1, e2) => dBox [string "(", p_exp e1, break {nsp = 1, offset = 0}, p_exp e2, string ")"] diff --git a/src/reduce.sml b/src/reduce.sml index 5913873..37c2a35 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -22,6 +22,8 @@ structure Reduce :> REDUCE = struct open Ast Print Env +structure SM = StringMap + fun freeIn x (b, _) = case b of EInt _ => false @@ -38,6 +40,7 @@ fun freeIn x (b, _) = | ESeq es => List.exists (freeIn x) es | ELocal (e1, e2) => freeIn x e1 orelse freeIn x e2 | EWith (e1, e2) => freeIn x e1 orelse freeIn x e2 + | EALam (x', _, b') => x <> x' andalso freeIn x b' local val freshCount = ref 0 @@ -91,6 +94,17 @@ fun subst x e (bAll as (b, loc)) = | ESeq es => (ESeq (map (subst x e) es), loc) | ELocal (b1, b2) => (ELocal (subst x e b1, subst x e b2), loc) | EWith (b1, b2) => (EWith (subst x e b1, subst x e b2), loc) + | EALam (x', p, b') => + if x = x' then + bAll + else if freeIn x' e then + let + val x'' = freshVar () + in + (EALam (x'', p, subst x e (subst x' (EVar x'', loc) b')), loc) + end + else + (EALam (x', p, subst x e b'), loc) fun reduceExp G (eAll as (e, loc)) = case e of @@ -127,6 +141,20 @@ fun reduceExp G (eAll as (e, loc)) = | EGet (x, v, b) => (EGet (x, v, reduceExp G b), loc) | ESeq es => (ESeq (map (reduceExp G) es), loc) | ELocal (e1, e2) => (ELocal (reduceExp G e1, reduceExp G e2), loc) - | EWith (e1, e2) => (EWith (reduceExp G e1, reduceExp G e2), loc) + | EWith (e1, e2) => + let + val e1' = reduceExp G e1 + val e2' = reduceExp G e2 + in + case e1' of + (EALam (x, _, b), _) => reduceExp G (subst x e2' b) + | _ => (EWith (e1', e2'), loc) + end + | EALam (x, p, e) => + let + val G' = bindVal G (x, (TAction (p, SM.empty, SM.empty), loc), NONE) + in + (EALam (x, p, reduceExp G' e), loc) + end end diff --git a/src/tycheck.sml b/src/tycheck.sml index 152eaf7..f1c90dc 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -426,6 +426,23 @@ fun checkExp G (eAll as (e, loc)) = (TError, loc)) end + | EALam (x, p, e) => + let + val p' = checkPred G p + + val G' = bindVal G (x, (TAction (p, SM.empty, SM.empty), loc), NONE) + val t' = checkExp G' e + in + case t' of + (TAction _, _) => (TNested (p, t'), loc) + | _ => (dte (WrongForm ("Body of nested configuration 'fn'", + "action", + e, + t', + NONE)); + (TError, loc)) + end + | ESet (evar, e) => let val t = checkExp G e diff --git a/tests/testBusy.dtl b/tests/testBusy.dtl new file mode 100644 index 0000000..7c2216a --- /dev/null +++ b/tests/testBusy.dtl @@ -0,0 +1,45 @@ +domain "hcoop.net" with + dns (dnsNS "ns.hcoop.net"); + + dns (dnsA "a" "1.2.3.4"); + dns (dnsCNAME "b" "a.hcoop.net"); + dns (dnsMX 1 "mail.nowhere.eu"); + + handleMail; + + emailAlias "someone" "someoneElse"; + aliasMulti "me" ["nowhere","smelly@yikes.com"]; + + catchAllAlias "me@gmail.com"; + + mailmanWebHost "lists.hcoop.net"; + + dns (dnsA "www" web_ip); + vhost "www" where + DocumentRoot = "/home/adamc/html"; + ServerAdmin = "my@other.address" + with + serverAlias "hcoop.net"; + addDefaultCharset "mumbo-jumbo/incomprehensible"; + + location "/theMorgue" with + rewriteRule "A" "B" []; + end; + end; +end; + +domain "schizomaniac.net" where + TTL = 1234 +with + vhost "www" with + directory "/home/adamc/thisPlace" with + unset_options [includesNOEXEC]; + indexOptions [iconsAreLinks, scanHtmlTitles, iconWidth 45]; + end + end; + + vhost "proxy" with + proxyPass "/proxyLand" "http://localhost:1234/otherProxyLand"; + proxyPassReverse "/proxyLand" "http://localhost:1234/otherProxyLand"; + end; +end; diff --git a/tests/testEasy.dtl b/tests/testEasy.dtl new file mode 100644 index 0000000..6c63fb3 --- /dev/null +++ b/tests/testEasy.dtl @@ -0,0 +1,2 @@ +dom "hcoop.net" with +end; -- 2.20.1