From: Clinton Ebadi Date: Sat, 26 Apr 2014 00:05:10 +0000 (-0400) Subject: merge toplevel-dynamic-environment X-Git-Tag: release_20140428~3 X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/d63aa5e7b08630cc17a606e85e35acc5bd0041ee?hp=8d06030c085c5ae1d186b679bd142a04055cc239 merge toplevel-dynamic-environment --- diff --git a/configDefault/apache.cfg b/configDefault/apache.cfg index 3d10c3a..48d852a 100644 --- a/configDefault/apache.cfg +++ b/configDefault/apache.cfg @@ -17,8 +17,6 @@ val confDir = ConfigCore.localRoot ^ "/vhosts" val webNodes_all = [("navajos", {version = APACHE_2, auth = MOD_WAKLOG})] val webNodes_admin = [("deleuze", {version = APACHE_2, auth = MOD_WAKLOG})] -val webNodes_default = ["navajos"] - val proxyTargets = ["http://hcoop.net/cgi-bin/mailman", "http://hcoop.net/pipermail"] diff --git a/configDefault/apache.csg b/configDefault/apache.csg index 5fbbe61..908fc49 100644 --- a/configDefault/apache.csg +++ b/configDefault/apache.csg @@ -14,7 +14,6 @@ signature APACHE_CONFIG = sig val webNodes_all : (string * ConfigTypes.apache_info) list val webNodes_admin : (string * ConfigTypes.apache_info) list - val webNodes_default : string list val proxyTargets : string list (* Specifically exempted URIs for proxying *) diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index eeaebad..69dcf8a 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -7,13 +7,6 @@ val oldResultRoot = ConfigCore.sharedRoot ^ "/nodes.old" val domtool_publish = ConfigCore.installPrefix ^ "/sbin/domtool-publish" -val defaultNs = "ns1.hcoop.net" - -val defaultRefresh = 86400 -val defaultRetry = 1800 -val defaultExpiry = 1209600 -val defaultMinimum = 3600 - val nodeIps = [("deleuze", "69.90.123.67"), ("hopper", "69.90.123.74"), ("fritz", "69.90.123.75"), ("navajos", "69.90.123.70"), ("bog", "69.90.123.72"), ("outpost", "151.236.216.192")] val dispatcherName = "fritz" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index 4cf7fee..94b0076 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -13,13 +13,6 @@ val tmpDir : string val domtool_publish : string -(* DNS SOA parameter defaults *) -val defaultNs : string -val defaultRefresh : int -val defaultRetry : int -val defaultExpiry : int -val defaultMinimum : int - (* Names of machines who will receive configuration *) val nodeIps : (string * string) list val dispatcherName : string diff --git a/configDefault/exim.cfg b/configDefault/exim.cfg index db689ec..4724054 100644 --- a/configDefault/exim.cfg +++ b/configDefault/exim.cfg @@ -7,8 +7,6 @@ val relayDomains = ConfigCore.localRoot ^ "/relay_domains.cfg" val reload = ConfigCore.sudo ^ " " ^ ConfigCore.installPrefix ^ "/sbin/domtool-publish exim" -val aliasTo = ["deleuze"] - val mainLog = "/var/log/exim4/mainlog" end diff --git a/configDefault/exim.csg b/configDefault/exim.csg index e28dee3..ddd7258 100644 --- a/configDefault/exim.csg +++ b/configDefault/exim.csg @@ -14,9 +14,6 @@ val handleDomains : string val relayDomains : string (* File to which to write a comma-separate list of domains to relay mail for *) -val aliasTo : string list -(* Default nodes to which alias directives are applied *) - val mainLog : string (* Path to main log file *) diff --git a/lib/defaults.dtl b/lib/defaults.dtl new file mode 100644 index 0000000..d6bf689 --- /dev/null +++ b/lib/defaults.dtl @@ -0,0 +1,45 @@ +extern val you : your_user; +extern val defaultMailbox : email; +extern val defaultServerAdmin : email; + +var SSL : ssl = no_ssl; + +var User : your_user = you; + +var Group : your_group = "nogroup"; + +var DocumentRoot : your_path = (home "public_html"); +var SuExec : suexec_flag = true; +var PhpVersion : php_version = php5; + +var Mailbox : email = defaultMailbox; +var ServerAdmin : email = defaultServerAdmin; + +var Aliases : [your_domain] = []; + +val defaultTTL : int = 3600; +val defaultNs : domain = "ns1.hcoop.net"; +val defaultRefresh : int = 86400; +val defaultRetry : int = 1800; +val defaultExpiry : int = 1209600; +val defaultMinimum : int = 3600; + +val dnsMasterNode : master = (internalMaster dns_master_node); +val dnsSlaveNodes : [dns_node] = dns_slave_nodes; + +var DNS : dnsKind = useDns (soa defaultNs serialAuto defaultRefresh defaultRetry defaultExpiry defaultMinimum) dnsMasterNode dnsSlaveNodes; +var TTL : int = defaultTTL; + +var WWW : [Vhost] = Skip; +var CreateWWW : bool = true; +var DefaultA : bool = true; +var DefaultAlias : bool = true; +var DefaultAliasSource : aliasSource = defaultSource; +var HandleMail : bool = true; +var AddMX : bool = true; + +var MailNodes : [mail_node] = ["deleuze"]; + +var MailManPlaces : [mailman_place] = [mailman_place_default mailman_node]; + +var DefaultWebNode : web_node = web_node; \ No newline at end of file diff --git a/lib/domain.dtl b/lib/domain.dtl index 08606a6..c3e16b5 100644 --- a/lib/domain.dtl +++ b/lib/domain.dtl @@ -78,6 +78,10 @@ extern val externalMaster : ip -> master; {{A server not controlled by domtool will serve as master.}} extern val internalMaster : dns_node -> master; {{A server controlled by domtool will serve as master.}} +extern val dns_master_node : dns_node; +{{Internal master DNS node}} +extern val dns_slave_nodes : [dns_node]; +{{Internal slave DNS nodes}} extern type dnsKind; {{How should DNS for this domain be handled?}} diff --git a/src/ast.sml b/src/ast.sml index d4c5727..caa7e9d 100644 --- a/src/ast.sml +++ b/src/ast.sml @@ -99,6 +99,7 @@ datatype decl' = DExternType of string | DExternVal of string * typ | DVal of string * typ option * exp + | DEnv of string * typ option * exp | DContext of string type decl = decl' * string option * position diff --git a/src/autodoc.sml b/src/autodoc.sml index bdf2527..baa8d54 100644 --- a/src/autodoc.sml +++ b/src/autodoc.sml @@ -36,7 +36,7 @@ fun check' G fname = if !ErrorMsg.anyErrors then G else - Tycheck.checkFile G (Defaults.tInit prog) prog + Tycheck.checkFile G prog end fun autodoc {outdir, infiles} = @@ -232,6 +232,8 @@ fun makeEmacsKeywords infiles = (case isAction evs t of SOME evs => (types, contexts, s :: actions, vals, evs) | NONE => (types, contexts, actions, s :: vals, evs)) + | DEnv (s, _, _) => + (types, contexts, actions, vals, StringSet.add (evs, s)) | DContext s => (types, s :: contexts, actions, vals, evs)) acc decls end diff --git a/src/defaults.sig b/src/defaults.sig deleted file mode 100644 index 7dbe773..0000000 --- a/src/defaults.sig +++ /dev/null @@ -1,26 +0,0 @@ -(* 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. - *) - -(* Default record field database *) - -signature DEFAULTS = sig - val registerDefault : string * Ast.typ * (unit -> Ast.exp) -> unit - - val tInit : Ast.file -> Ast.typ - val eInit : unit -> Env.env_vars -end diff --git a/src/defaults.sml b/src/defaults.sml deleted file mode 100644 index 8ca63f7..0000000 --- a/src/defaults.sml +++ /dev/null @@ -1,63 +0,0 @@ -(* 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. - *) - -(* Default record field database *) - -structure Defaults :> DEFAULTS = struct - -open Ast Print - -structure SM = StringMap - -val dmy = ErrorMsg.dummyLoc - -val defaultT : record ref = ref SM.empty -val defaultV : (unit -> exp) SM.map ref = ref SM.empty - -fun registerDefault (name, t, v) = - case SM.find (!defaultT, name) of - NONE => (defaultT := SM.insert (!defaultT, name, t); - defaultV := SM.insert (!defaultV, name, v)) - | SOME _ => raise Fail "Duplicate default environment variable" - -fun allSets (e, _) = - case e of - ESkip => true - | ESet _ => true - | ESeq es => List.all allSets es - | _ => false - -val dmy = ErrorMsg.dummyLoc - -fun bodyType (_, _, SOME e) = - if allSets e then - (CPrefix (CRoot, dmy), dmy) - else - (CRoot, dmy) - | bodyType _ = (CRoot, dmy) - -fun tInit p = - (TAction (bodyType p, - !defaultT, - StringMap.empty), - dmy) - -fun eInit () = SM.map (fn f => f ()) (!defaultV) - - -end diff --git a/src/domain.sml b/src/domain.sml index 2b93535..affa1b1 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -70,8 +70,9 @@ fun setUser user = class = "domain"}; your_usrs := Acl.class {user = getUser (), class = "user"}; - your_grps := Acl.class {user = getUser (), - class = "group"}; + your_grps := SS.add (Acl.class {user = getUser (), + class = "group"}, + "nogroup"); your_pths := your_paths; readable_pths := SS.union (your_paths, world_readable); your_ipss := Acl.class {user = getUser (), @@ -133,15 +134,18 @@ fun validDomain s = fun validNode s = List.exists (fn s' => s = s') nodes fun yourDomain s = !fakePrivs orelse SS.member (your_domains (), s) -fun yourUser s = SS.member (your_users (), s) -fun yourGroup s = SS.member (your_groups (), s) +fun yourUser s = !fakePrivs orelse SS.member (your_users (), s) +fun yourGroup s = !fakePrivs orelse SS.member (your_groups (), s) + fun checkPath paths path = + !fakePrivs orelse (List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path) andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/" orelse ch = #"-" orelse ch = #"_") path andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (paths ())) val yourPath = checkPath your_paths val readablePath = checkPath readable_paths + fun yourIp s = !fakePrivs orelse SS.member (your_ips (), s) fun yourDomainHost s = @@ -267,41 +271,14 @@ val _ = Env.registerFunction ("end_in_slash", | _ => NONE) -val nsD = (EString Config.defaultNs, dl) -val serialD = (EVar "serialAuto", dl) -val refD = (EInt Config.defaultRefresh, dl) -val retD = (EInt Config.defaultRetry, dl) -val expD = (EInt Config.defaultExpiry, dl) -val minD = (EInt Config.defaultMinimum, dl) - -val soaD = multiApp ((EVar "soa", dl), - dl, - [nsD, serialD, refD, retD, expD, minD]) - -val masterD = (EApp ((EVar "internalMaster", dl), - (EString Config.Bind.masterNode, dl)), - dl) +val _ = Env.registerFunction ("you", + fn [] => SOME (EString (getUser ()), dl) + | _ => NONE) -val slavesD = (EList (map (fn s => (EString s, dl)) - (List.filter (fn x => List.exists (fn y => y = x) (Config.dnsNodes_all @ Config.dnsNodes_admin)) Config.Bind.slaveNodes)), dl) - -val _ = Defaults.registerDefault ("Aliases", - (TList (TBase "your_domain", dl), dl), - (fn () => (EList [], dl))) - -val _ = Defaults.registerDefault ("Mailbox", - (TBase "email", dl), - (fn () => (EString (getUser ()), dl))) - -val _ = Defaults.registerDefault ("DNS", - (TBase "dnsKind", dl), - (fn () => multiApp ((EVar "useDns", dl), - dl, - [soaD, masterD, slavesD]))) +val _ = Env.registerFunction ("defaultMailbox", + fn [] => SOME (EString (getUser ()), dl) + | _ => NONE) -val _ = Defaults.registerDefault ("TTL", - (TBase "int", dl), - (fn () => (EInt Config.Bind.defaultTTL, dl))) type soa = {ns : string, serial : int option, @@ -892,6 +869,7 @@ fun homedirOf uname = Posix.SysDB.Passwd.home (Posix.SysDB.getpwnam uname) fun homedir () = homedirOf (getUser ()) + handle e => if !fakePrivs then "/tmp" else raise e type subject = {node : string, domain : string} diff --git a/src/domtool.grm b/src/domtool.grm index bd2726c..ea6db74 100644 --- a/src/domtool.grm +++ b/src/domtool.grm @@ -34,7 +34,7 @@ open Ast | EQ | COMMA | BSLASH | BSLASHBSLASH | SEMI | LET | IN | BEGIN | END | IF | THEN | ELSE | ROOT | SKIP - | EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT + | EXTERN | TYPE | VAL | ENV | WITH | WHERE | CONTEXT %nonterm file of file @@ -90,6 +90,8 @@ 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)) + | ENV CSYMBOL EQ exp (DEnv (CSYMBOL, NONE, exp)) + | ENV CSYMBOL COLON typ EQ exp (DEnv (CSYMBOL, SOME typ, exp)) | CONTEXT CSYMBOL (DContext CSYMBOL) docOpt : (NONE) diff --git a/src/domtool.lex b/src/domtool.lex index 4f51821..65ceda1 100644 --- a/src/domtool.lex +++ b/src/domtool.lex @@ -138,6 +138,7 @@ lineComment = #[^\n]*\n; "extern" => (Tokens.EXTERN (yypos, yypos + size yytext)); "type" => (Tokens.TYPE (yypos, yypos + size yytext)); "val" => (Tokens.VAL (yypos, yypos + size yytext)); + "var" => (Tokens.ENV (yypos, yypos + size yytext)); "context" => (Tokens.CONTEXT (yypos, yypos + size yytext)); "Root" => (Tokens.ROOT (yypos, yypos + size yytext)); diff --git a/src/env.sig b/src/env.sig index 8e5962c..c8371a8 100644 --- a/src/env.sig +++ b/src/env.sig @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -93,16 +94,22 @@ signature ENV = sig type env val empty : env + val initialDynEnvTypes : env -> Ast.typ Ast.StringMap.map + val initialDynEnvVals : env -> env_vars + val bindType : env -> string -> env val bindVal : env -> string * Ast.typ * Ast.exp option -> env val bindContext : env -> string -> env + val bindInitialDynEnvVal : env -> string * Ast.typ * Ast.exp -> env val lookupType : env -> string -> bool val lookupVal : env -> string -> Ast.typ option val lookupEquation : env -> string -> Ast.exp option val lookupContext : env -> string -> bool + val lookupInitialDynEnvVal : env -> string -> Ast.typ option val types : env -> Ast.StringSet.set val vals : env -> Ast.StringSet.set val contexts : env -> Ast.StringSet.set + val dynamics : env -> Ast.StringSet.set end diff --git a/src/env.sml b/src/env.sml index 8ebcaf4..3b08094 100644 --- a/src/env.sml +++ b/src/env.sml @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -211,26 +212,39 @@ fun container_one name args (f, g) = registerContainer (name, one name args f, g fun containerV_none name (f, g) = registerContainer (name, noneV name f, g) fun containerV_one name args (f, g) = registerContainer (name, oneV name args f, g) -type env = SS.set * (typ * exp option) SM.map * SS.set -val empty : env = (SS.empty, SM.empty, SS.empty) +type env = SS.set * (typ * exp option) SM.map * SS.set * (typ * exp) SM.map +val empty : env = (SS.empty, SM.empty, SS.empty, SM.empty) -fun lookupType (ts, _, _) name = SS.member (ts, name) -fun lookupVal (_, vs, _) name = + +fun initialDynEnvTypes (_, _, _, ds) = + SM.map (fn (t, e) => t) ds + +fun initialDynEnvVals (_, _, _, ds) = + SM.map (fn (t, v) => v) ds + +fun lookupType (ts, _, _, _) name = SS.member (ts, name) +fun lookupVal (_, vs, _, _) name = case SM.find (vs, name) of NONE => NONE | SOME (t, _) => SOME t -fun lookupEquation (_, vs, _) name = +fun lookupEquation (_, vs, _, _) name = case SM.find (vs, name) of NONE => NONE | SOME (_, eqo) => eqo -fun lookupContext (_, _, cs) name = SS.member (cs, name) +fun lookupContext (_, _, cs, _) name = SS.member (cs, name) +fun lookupInitialDynEnvVal (_, _, _, ds) name = + case SM.find (ds, name) of + NONE => NONE + | SOME (t, _) => SOME t -fun bindType (ts, vs, cs) name = (SS.add (ts, name), vs, cs) -fun bindVal (ts, vs, cs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs) -fun bindContext (ts, vs, cs) name = (ts, vs, SS.add (cs, name)) +fun bindType (ts, vs, cs, ds) name = (SS.add (ts, name), vs, cs, ds) +fun bindVal (ts, vs, cs, ds) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs, ds) +fun bindContext (ts, vs, cs, ds) name = (ts, vs, SS.add (cs, name), ds) +fun bindInitialDynEnvVal (ts, vs, cs, ds) (name, t, eqn) = (ts, vs, cs, SM.insert (ds, name, (t, eqn))) -fun types (ts, _, _) = ts -fun vals (_, vs, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs -fun contexts (_, _, cs) = cs +fun types (ts, _, _, _) = ts +fun vals (_, vs, _, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs +fun contexts (_, _, cs, _) = cs +fun dynamics (_, _, _, ds) = SM.foldli (fn (name, _, ds) => SS.add (ds, name)) SS.empty ds end diff --git a/src/main-doc.sml b/src/main-doc.sml index f088f8b..f2b6eab 100644 --- a/src/main-doc.sml +++ b/src/main-doc.sml @@ -44,6 +44,8 @@ val _ = files in Tycheck.allowExterns (); + Domain.declareClient (); + Domain.fakePrivileges (); if emacs then Autodoc.makeEmacsKeywords files else diff --git a/src/main.sml b/src/main.sml index 1552791..fe93791 100644 --- a/src/main.sml +++ b/src/main.sml @@ -51,7 +51,7 @@ fun check' G fname = () else Option.app (Unused.check G) (#3 prog); - Tycheck.checkFile G (Defaults.tInit prog) prog) + Tycheck.checkFile G prog) end fun basis () = @@ -101,7 +101,7 @@ fun check G fname = raise ErrorMsg.Error else let - val G' = Tycheck.checkFile G (Defaults.tInit prog) prog + val G' = Tycheck.checkFile G prog in if !ErrorMsg.anyErrors then raise ErrorMsg.Error @@ -1149,7 +1149,9 @@ fun regenerateEither tc checker context = ok := false) else (); - ignore (foldl checker' (basis (), Defaults.eInit ()) files) + let val basis' = basis () in + ignore (foldl checker' (basis', Env.initialDynEnvVals basis') files) + end end else if String.isSuffix "_admin" user then () @@ -1314,7 +1316,9 @@ fun service () = end in doIt (fn () => (Env.pre (); - ignore (foldl doOne (basis (), Defaults.eInit ()) codes); + let val basis' = basis () in + ignore (foldl doOne (basis', Env.initialDynEnvVals basis') codes) + end; Env.post (); Msg.send (bio, MsgOk); ("Configuration complete.", NONE))) diff --git a/src/order.sml b/src/order.sml index b58c9f7..117a0ea 100644 --- a/src/order.sml +++ b/src/order.sml @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -134,6 +135,11 @@ fun declNeeded G (d, _, _) = NONE => expNeeded G e | SOME t => unionCTE ((typNeeded G t, SS.empty), expNeeded G e)) + | DEnv (name, to, e) => (Env.bindInitialDynEnvVal G (name, dt, (Ast.ESkip, ErrorMsg.dummyLoc)), + case to of + NONE => expNeeded G e + | SOME t => unionCTE ((typNeeded G t, SS.empty), + expNeeded G e)) | DContext name => (Env.bindContext G name, empty) fun fileSig (_, ds, eo) = diff --git a/src/plugins/apache.sig b/src/plugins/apache.sig index 07e56e3..31f0587 100644 --- a/src/plugins/apache.sig +++ b/src/plugins/apache.sig @@ -38,9 +38,6 @@ signature APACHE = sig val realLogDir : {user : string, node : string, vhostId : string} -> string (* OK, where is it _really_ located? (Target of log syncing into AFS) *) - val defaults : (string * Ast.typ * (unit -> Ast.exp)) list - (* Default environment variables *) - val ssl : string option Env.arg val webPlace : (string * string) Env.arg diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index f6017dd..35bd070 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -144,32 +144,9 @@ val _ = Env.type_one "file_extension" Env.string validExtension -val defaults = [("WebPlaces", - (TList (TBase "web_place", dl), dl), - (fn () => (EList (map webPlaceDefault Config.Apache.webNodes_default), dl))), - ("SSL", - (TBase "ssl", dl), - (fn () => (EVar "no_ssl", dl))), - ("User", - (TBase "your_user", dl), - (fn () => (EString (Domain.getUser ()), dl))), - ("Group", - (TBase "your_group", dl), - (fn () => (EString "nogroup", dl))), - ("DocumentRoot", - (TBase "your_path", dl), - (fn () => (EString (Domain.homedir () ^ "/" ^ Config.Apache.public_html), dl))), - ("ServerAdmin", - (TBase "email", dl), - (fn () => (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl))), - ("SuExec", - (TBase "suexec_flag", dl), - (fn () => (EVar "true", dl))), - ("PhpVersion", - (TBase "php_version", dl), - (fn () => (EVar "php5", dl)))] - -val () = app Defaults.registerDefault defaults +val _ = Env.registerFunction ("defaultServerAdmin", + fn [] => SOME (EString (Domain.getUser () ^ "@" ^ Config.defaultDomain), dl) + | _ => NONE) val redirect_code = fn (EVar "temp", _) => SOME "temp" | (EVar "permanent", _) => SOME "permanent" diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml index 4b9eccd..ca35c2c 100644 --- a/src/plugins/bind.sml +++ b/src/plugins/bind.sml @@ -374,4 +374,12 @@ val _ = Env.type_one "srv_domain" Env.string validSrvDomain +val _ = Env.registerFunction ("dns_master_node", + fn [] => SOME (EString Config.Bind.masterNode, dl) + | _ => NONE) + +val _ = Env.registerFunction ("dns_slave_nodes", + fn [] => SOME (EList (map (fn n => (EString n, dl)) Config.Bind.slaveNodes), dl) + | _ => NONE) + end diff --git a/src/plugins/easy_domain.sig b/src/plugins/easy_domain.sig deleted file mode 100644 index 048cab8..0000000 --- a/src/plugins/easy_domain.sig +++ /dev/null @@ -1,23 +0,0 @@ -(* 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. - *) - -(* Derived directives of general use *) - -signature EASY_DOMAIN = sig - -end diff --git a/src/plugins/easy_domain.sml b/src/plugins/easy_domain.sml deleted file mode 100644 index 7a15dea..0000000 --- a/src/plugins/easy_domain.sml +++ /dev/null @@ -1,62 +0,0 @@ -(* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2007, Adam Chlipala - * Copyright (c) 2014 Clinton Ebadi - * - * 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. - *) - -(* Derived directives of general use *) - -structure EasyDomain :> EASY_DOMAIN = struct - -open Ast - -val dl = ErrorMsg.dummyLoc - -val _ = Defaults.registerDefault ("WWW", - (TAction ((CConst "Vhost", dl), - StringMap.empty, - StringMap.empty), dl), - (fn () => (ESkip, dl))) - -val _ = Defaults.registerDefault ("CreateWWW", - (TBase "bool", dl), - (fn () => (EVar "true", dl))) - -val _ = Defaults.registerDefault ("DefaultA", - (TBase "bool", dl), - (fn () => (EVar "true", dl))) - -val _ = Defaults.registerDefault ("DefaultAlias", - (TBase "bool", dl), - (fn () => (EVar "true", dl))) - -val _ = Defaults.registerDefault ("DefaultAliasSource", - (TBase "aliasSource", dl), - (fn () => (EVar "defaultSource", dl))) - -val _ = Defaults.registerDefault ("HandleMail", - (TBase "bool", dl), - (fn () => (EVar "true", dl))) - -val _ = Defaults.registerDefault ("AddMX", - (TBase "bool", dl), - (fn () => (EVar "true", dl))) - -val _ = Defaults.registerDefault ("DefaultWebNode", - (TBase "web_node", dl), - (fn () => (EString "navajos", dl))) - -end diff --git a/src/plugins/exim.sml b/src/plugins/exim.sml index 05e88e9..b069389 100644 --- a/src/plugins/exim.sml +++ b/src/plugins/exim.sml @@ -22,12 +22,6 @@ structure Exim :> EXIM = struct open Ast -val dl = ErrorMsg.dummyLoc - -val _ = Defaults.registerDefault ("MailNodes", - (TList (TBase "mail_node", dl), dl), - (fn () => (EList (map (fn s => (EString s, dl)) Config.Exim.aliasTo), dl))) - val aliasesChanged = ref false val aliasesDefaultChanged = ref false val hostsChanged = ref false diff --git a/src/plugins/mailman.sml b/src/plugins/mailman.sml index a4f5a6c..ef0a82f 100644 --- a/src/plugins/mailman.sml +++ b/src/plugins/mailman.sml @@ -42,8 +42,6 @@ fun mailmanPlace (EApp ((EVar "mailman_place_default", _), (EString node, _)), _ SOME (node, ip) | mailmanPlace _ = NONE -fun mailmanPlaceDefault node = (EApp ((EVar "mailman_place_default", dl), (EString node, dl)), dl) - val _ = Env.registerFunction ("mailman_place_to_web_node", fn [e] => Option.map (fn (node, _) => (EString node, dl)) (mailmanPlace e) | _ => NONE) @@ -56,11 +54,6 @@ val _ = Env.registerFunction ("mailman_place_to_ip", fn [e] => Option.map (fn (_, ip) => (EString ip, dl)) (mailmanPlace e) | _ => NONE) -val () = Defaults.registerDefault - ("MailmanPlaces", - (TList (TBase "mailman_place", dl), dl), - (fn () => (EList [mailmanPlaceDefault Config.Mailman.node], dl))) - val files = ref ([] : TextIO.outstream list) val write = ref (fn _ : string => ()) diff --git a/src/printFn.sml b/src/printFn.sml index 42282aa..9b3c4ee 100644 --- a/src/printFn.sml +++ b/src/printFn.sml @@ -155,6 +155,12 @@ fun p_decl d = ident name, space 1, punct ":", space 1, p_typ t]) + | DEnv (name, NONE, _) => string "Unannotated env declaration!" + | DEnv (name, SOME t, _) => anchor ("D_" ^ name, + dBox [keyword "var", space 1, + ident name, space 1, + punct ":", space 1, + p_typ t]) | DContext name => anchor ("C_" ^ name, dBox [keyword "context", space 1, ident name]) @@ -176,6 +182,12 @@ fun p_decl_fref d = space 1, punct ":", space 1, p_typ t] + | DEnv (name, NONE, _) => string "Unannotated var declaration!" + | DEnv (name, SOME t, _) => dBox [keyword "var", space 1, + link ("#D_" ^ name, ident name), + space 1, + punct ":", space 1, + p_typ t] | DContext name => dBox [keyword "context", space 1, link ("#C_" ^ name, ident name)] diff --git a/src/sources b/src/sources index 3c3ff42..17a9fd4 100644 --- a/src/sources +++ b/src/sources @@ -50,9 +50,6 @@ acl.sml slave.sig slave.sml -defaults.sig -defaults.sml - pcre.sig pcre.sml @@ -117,9 +114,6 @@ plugins/socketPerm.sml plugins/firewall.sig plugins/firewall.sml -plugins/easy_domain.sig -plugins/easy_domain.sml - mail/vmail.sig mail/vmail.sml diff --git a/src/tycheck.sig b/src/tycheck.sig index 19ec6d4..52630b8 100644 --- a/src/tycheck.sig +++ b/src/tycheck.sig @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -28,7 +29,7 @@ signature TYCHECK = sig val checkDecl : Env.env -> Ast.decl -> Env.env - val checkFile : Env.env -> Ast.typ -> Ast.file -> Env.env + val checkFile : Env.env -> Ast.file -> Env.env val resetUnif : unit -> unit val newUnif : unit -> Ast.typ' diff --git a/src/tycheck.sml b/src/tycheck.sml index 12efce3..38ef822 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -1,5 +1,6 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) * Copyright (c) 2006-2007, Adam Chlipala + * Copyright (c) 2014 Clinton Ebadi * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License @@ -671,6 +672,25 @@ fun checkDecl G (d, _, loc) = SOME ue)); bindVal G (name, to, SOME e) end + | DEnv (name, to, e) => + let + val to = + case to of + NONE => (newUnif (), loc) + | SOME to => checkTyp G to + + val t = checkExp G e + in + hasTyp (e, t, to) + handle Unify ue => + Describe.describe_type_error loc + (WrongType ("Dynamically bound value", + e, + t, + to, + SOME ue)); + bindInitialDynEnvVal G (name, to, e) + end | DContext name => bindContext G name fun printActionDiffs {have, need} = @@ -723,15 +743,42 @@ fun printActionDiffs {have, need} = | _ => false -fun checkFile G tInit (_, ds, eo) = +fun checkFile G (prog as (_, ds, eo)) = let val G' = foldl (fn (d, G) => checkDecl G d) G ds + + fun tInitial prog env = + (* This should likely only take the dynamic env as an argument *) + let + fun allSets (e, _) = + case e of + ESkip => true + | ESet _ => true + | ESeq es => List.all allSets es + | _ => false + + val dmy = ErrorMsg.dummyLoc + + fun bodyType (_, _, SOME e) = + if allSets e then + (CPrefix (CRoot, dmy), dmy) + else + (CRoot, dmy) + | bodyType _ = (CRoot, dmy) + in + (TAction (bodyType prog, + Env.initialDynEnvTypes env, + StringMap.empty), + dmy) + end + in case eo of NONE => () | SOME (e as (_, loc)) => let val t = checkExp G' e + val tInit = tInitial prog G' in hasTyp (e, t, tInit) handle Unify _ =>