$(CC) -lcrypt -o $@ $<
COMMON_DEPS := configDefault/config.sig configDefault/configDefault.sml \
- openssl/openssl_sml.so config.sml
+ openssl/openssl_sml.so pcre/pcre_sml.so config.sml
EMACS_DIR := /usr/local/share/emacs/site-lisp/domtool-mode
config.sml:
echo -e 'structure Config :> CONFIG = struct\nopen ConfigDefault\nend' > $@
-.PHONY: all mlton smlnj install
+.PHONY: all mlton smlnj install install_sos
mlton: bin/domtool-server bin/domtool-client bin/domtool-slave \
bin/domtool-admin bin/domtool-doc bin/dbtool bin/vmail \
bin/smtplog bin/setsa bin/mysql-fixperms bin/webbw
-smlnj: $(COMMON_DEPS) openssl/smlnj/FFI/libssl.h.cm src/domtool.cm
+smlnj: $(COMMON_DEPS) openssl/smlnj/FFI/libssl.h.cm pcre/smlnj/FFI/libpcre.h.cm \
+ src/domtool.cm
configDefault/config.sig: src/config.sig.header \
configDefault/*.csg configDefault/*.cfs \
-o openssl/openssl_sml.so \
openssl/openssl_sml.o -lssl
+pcre/pcre_sml.o: pcre/pcre_sml.c
+ gcc -fPIC -c pcre/pcre_sml.c -o pcre/pcre_sml.o
+
+pcre/pcre_sml.so: pcre/pcre_sml.o
+ gcc -shared -Wl,-soname,pcre_sml.so \
+ -o pcre/pcre_sml.so \
+ pcre/pcre_sml.o -lpcre
+
src/domtool.cm: src/prefix.cm src/sources
cat src/prefix.cm src/sources >src/domtool.cm
-mlbfile libssl.h.mlb -cppopt -D__builtin_va_list="void*" \
../openssl_sml.h
+pcre/smlnj/FFI/libpcre.h.cm: pcre/pcre_sml.h
+ cd pcre/smlnj ; ml-nlffigen -d FFI -lh LibpcreH.libh -include ../libpcre-h.sml \
+ -cm libpcre.h.cm -D__builtin_va_list="void*" \
+ ../pcre_sml.h
+
+pcre/mlton/FFI/libpcre.h.mlb: pcre/pcre_sml.h
+ cd pcre/mlton ; mlnlffigen -dir FFI -libhandle LibpcreH.libh -include ../libpcre-h.sml \
+ -mlbfile libpcre.h.mlb -cppopt -D__builtin_va_list="void*" \
+ ../pcre_sml.h
+
%.lex.sml: %.lex
mllex $<
mlyacc $<
COMMON_MLTON_DEPS := openssl/mlton/FFI/libssl.h.mlb \
+ pcre/mlton/FFI/libpcre.h.mlb \
src/domtool.lex.sml \
src/domtool.grm.sig src/domtool.grm.sml \
$(COMMON_DEPS) src/*.sig src/*.sml \
elisp/domtool-tables.el: lib/*.dtl bin/domtool-doc
bin/domtool-doc -basis -emacs >$@
-install:
+install_sos:
+ cp openssl/openssl_sml.so /usr/local/lib/
+ cp pcre/pcre_sml.so /usr/local/lib/
+
+install: install_sos
cp scripts/domtool-publish /usr/local/sbin/
cp scripts/domtool-reset-global /usr/local/sbin/
cp scripts/domtool-reset-local /usr/local/sbin/
cp scripts/domtool-slave-logged /usr/local/bin/
cp scripts/domtool-server /etc/init.d/
cp scripts/domtool-slave /etc/init.d/
- cp openssl/openssl_sml.so /usr/local/lib/
-cp bin/domtool-server /usr/local/sbin/
-cp bin/domtool-slave /usr/local/sbin/
-cp bin/domtool-client /usr/local/bin/domtool
Major Mode for editing Domtool files." t nil)
(add-to-list (quote auto-mode-alist) (quote ("\\.\\(dtl\\|com\\|net\\|org\\|edu\\|mil\\|biz\\|info\\|name\\|be\\|ca\\|cc\\|de\\|fr\\|in\\|mu\\|se\\|uk\\|us\\|ws\\)$" . domtool-mode)))
+
+(provide 'domtool-mode-startup)
(defun domtool-syms-re (&rest syms)
(concat "\\<" (regexp-opt syms t) "\\>"))
-(load-file "/usr/local/share/emacs/site-lisp/domtool-mode/domtool-tables.el")
+(require 'domtool-tables)
(defvar domtool-font-lock-keywords
`(,(concat
"\\_<"
(regexp-opt '("let" "in" "begin" "end" "with" "where" "extern" "type"
- "val" "context" "Root")
+ "val" "context" "Root" "if" "then" "else")
t)
"\\_>")
. domtool-font-lock-syntactic-keywords)
(font-lock-syntactic-face-function
. domtool-font-lock-syntactic-face-function)))
- (set (make-local-variable 'comment-start) "(* ")
- (set (make-local-variable 'comment-end) " *)")
+ (set (make-local-variable 'comment-start-regexp) "(\\*\\|{{")
+ (set (make-local-variable 'comment-end-regexp) "\\*)\\|}}")
(set (make-local-variable 'comment-nested) t)
(set (make-local-variable 'compile-command)
(defun until-closed-helper (level)
(if
- (re-search-backward "\\_<\\(with\\|where\\|begin\\|end\\|let\\)\\_>"
+ (re-search-backward "\\_<\\(with\\|where\\|begin\\|end\\|let\\|val\\|type\\|if\\)\\_>"
nil t)
(cond
((string= (match-string 0) "end")
(until-closed-helper (+ level 1)))
((= level 0)
(current-indentation))
+ ((and
+ (string= (match-string 0) "with")
+ (save-excursion
+ (backward-char)
+ (looking-at "\\s-")))
+ (until-closed-helper level))
(t
(until-closed-helper (- level 1))))
(back-to-indentation)
(multiple-value-bind (previous-keyword base-indent)
(save-excursion
- (if (re-search-backward "\\_<\\(with\\|where\\|begin\\|end\\|let\\|in\\)\\_>"
+ (if (re-search-backward "\\_<\\(with\\|where\\|begin\\|end\\|let\\|in\\|val\\|type\\|if\\)\\_>\\|}}\\|{{"
nil t)
(values (match-string 0) (current-indentation))
(values nil 0)))
'noindent)
((nth 4 state)
(domtool-calculate-comment-indent state))
- ((looking-at "\\_<\\(with\\|end\\|in\\)\\_>")
+ ((looking-at "{{\\|\\_<\\(extern\\|val\\|type\\|context\\)\\_>")
+ 0)
+ ((looking-at "\\_<\\(with\\|end\\|in\\|else\\)\\_>")
(until-closed))
((not previous-keyword)
base-indent)
((string= previous-keyword "end")
base-indent)
+ ((looking-at "\\_<\\(val\\|extern\\|context\\)\\_>")
+ base-indent)
(t
(+ base-indent domtool-indent)))))))
(incf depth)
(decf depth)))
(+ (current-indentation) depth)))))
+
+(provide 'domtool-mode)
extern val userSource : emailUser -> aliasSource;
{{The part appear before the "@" in your desired source address}}
extern val defaultSource : aliasSource;
-{{Matches any mail to this domain that doesn't match any other rule, with the
- exception of systemwide usernames like UNIX users.}}
-extern val catchAllSource : aliasSource;
-{{Matches any mail to this domain that doesn't match any other rule, even
- for systemwide usernames.}}
+{{Matches any mail to this domain that doesn't match any other rule.}}
extern type aliasTarget;
{{A place to redirect messages}}
{{Silently delete mail to the user at the current domain.}}
val defaultAlias = \email -> aliasPrim defaultSource (addressTarget email);
-{{When a message to the current domain doesn't match any other alias, send it to
+{{When a message to the current domain doesn't match any other rule, send it to
this e-mail address.}}
extern val use_cert : ssl_cert_path -> ssl;
extern val vhost : host -> Vhost => [Domain]
- {WebPlaces : [web_place],
- SSL : ssl,
- User : your_user,
- Group : your_group,
- DocumentRoot : your_path,
- ServerAdmin : email,
- SuExec : suexec_flag};
+ {WebPlaces : [web_place],
+ SSL : ssl,
+ User : your_user,
+ Group : your_group,
+ DocumentRoot : your_path,
+ ServerAdmin : email,
+ SuExec : suexec_flag};
{{Add a new named Apache virtual host, specifying which nodes' Apache servers
should answer requests for this host, whether it should use SSL, what UNIX
user and group dynamic content generators should be run as, the filesystem
path to the static content root, and the e-mail address to which error pages
should direct visitors.}}
+extern val vhostDefault : Vhost => [Domain]
+ {WebPlaces : [web_place],
+ SSL : ssl,
+ User : your_user,
+ Group : your_group,
+ DocumentRoot : your_path,
+ ServerAdmin : email,
+ SuExec : suexec_flag};
+{{Like <tt>vhost</tt>, but for, e.g., <tt>yourdomain.com</tt> instead of
+ <tt>www.yourdomain.com</tt>}}
+
context Location;
extern type location;
Apache documentation</a> for what the options mean.}}
extern val execCGI : apache_option;
+extern val followSymLinks : apache_option;
extern val includesNOEXEC : apache_option;
extern val indexes : apache_option;
extern val addDefaultCharset : no_spaces -> [^Vhost];
{{See <a href="http://httpd.apache.org/docs/2.0/mod/core.html#adddefaultcharset">the
Apache documentation</a>.}}
+
+extern type file_extension;
+extern val cgiExtension : file_extension -> [^Vhost];
+{{Ask for all files ending in a particular extension to be executed as CGI.}}
extern type dnsRecord;
extern val dnsA : host -> ip -> dnsRecord;
+extern val dnsAAAA : host -> ipv6 -> dnsRecord;
extern val dnsCNAME : host -> domain -> dnsRecord;
extern val dnsMX : int -> domain -> dnsRecord;
extern val dnsNS : domain -> dnsRecord;
extern val dnsDefaultA : ip -> dnsRecord;
+extern val dnsDefaultAAAA : ipv6 -> dnsRecord;
extern val dns : dnsRecord -> [Domain] {TTL : int};
extern type ip;
{{An IP address}}
+extern type ipv6;
+{{An IPv6 address}}
extern type your_ip;
extern val your_ip_to_ip : your_ip -> ip;
-{{The most common kinds of domain configuration}}
-
-val default_node : (node) = "mire";
-val web_node : (web_node) = "mire";
-
-val webAt =
- \ n : (web_node) ->
- \ host : (host) ->
- \\ config : Vhost ->
- (dns (dnsA host (ip_of_node (web_node_to_node n)));
-
- vhost host where
- WebPlaces = [web_place_default n]
- with
- config
- end);
-
-val web = webAt web_node;
-
-val webAtIp =
- \ ip : (your_ip) ->
- \ host : (host) ->
- \\ config : Vhost -> begin
- dns (dnsA host (your_ip_to_ip ip));
-
- vhost host where
- WebPlaces = [web_place web_node ip]
- with
- config
- end
- end;
-
-val addDefaultAlias = begin
- mailbox <- Mailbox;
- defaultAlias mailbox
-end;
-
-val addWww = begin
- web "www" with
- serverAliasDefault;
- www : [Vhost] <- WWW;
- www
- end
-end;
-
-val domNoWwwNoDefaultAlias =
- \ d : (your_domain) ->
- \\ config : Domain ->
- domain d with
- dns (dnsNS "ns1.hcoop.net");
- dns (dnsNS "ns3.hcoop.net");
-
- dns (dnsDefaultA (ip_of_node (web_node_to_node web_node)));
-
- handleMail;
- dns (dnsMX 1 "deleuze.hcoop.net");
-
- config
- end;
-
-val domNoDefaultAlias =
- \ d : (your_domain) ->
- \\ config : Domain ->
- domNoWwwNoDefaultAlias d with
- addWww;
- config
- end;
-
-val domNoWww =
- \ d : (your_domain) ->
- \\ config : Domain ->
- domNoWwwNoDefaultAlias d with
- config;
- addDefaultAlias;
- end;
-
-val dom =
- \ d : (your_domain) ->
- \\ config : Domain ->
- domNoDefaultAlias d with
- config;
- addDefaultAlias;
- end;
-
-val nameserver = \host -> dns (dnsNS host);
-val dnsIP = \from -> \to -> dns (dnsA from to);
-val dnsMail = \num -> \host -> dns (dnsMX num host);
-val dnsAlias = \from -> \to -> dns (dnsCNAME from to);
-val dnsDefault = \to -> dns (dnsDefaultA to);
+{{The most common kinds of domain configuration}}
+
+val default_node : (node) = "mire";
+val web_node : (web_node) = "mire";
+
+val webAt =
+ \ n : (web_node) ->
+ \ host : (host) ->
+ \\ config : Vhost -> begin
+ dns (dnsA host (ip_of_node (web_node_to_node n)));
+
+ vhost host where
+ WebPlaces = [web_place_default n]
+ with
+ config
+ end
+ end;
+
+val web = webAt web_node;
+
+val webAtIp =
+ \ ip : (your_ip) ->
+ \ host : (host) ->
+ \\ config : Vhost -> begin
+ dns (dnsA host (your_ip_to_ip ip));
+
+ vhost host where
+ WebPlaces = [web_place web_node ip]
+ with
+ config
+ end
+ end;
+
+val addDefaultAlias = begin
+ mailbox <- Mailbox;
+ defaultAlias mailbox
+end;
+
+val addWww = begin
+ web "www" with
+ serverAliasDefault;
+ www : [Vhost] <- WWW;
+ www
+ end
+end;
+
+val dom =
+ \ d : (your_domain) ->
+ \\ config : Domain ->
+ domain d with
+ dns (dnsNS "ns1.hcoop.net");
+ dns (dnsNS "ns3.hcoop.net");
+
+ dns (dnsDefaultA (ip_of_node (web_node_to_node web_node)));
+
+ handleMail;
+ dns (dnsMX 1 "deleuze.hcoop.net");
+
+ createWWW : bool <- CreateWWW;
+ if createWWW then
+ addWww
+ else
+ Skip
+ end;
+
+ defAl : bool <- DefaultAlias;
+ if defAl then
+ addDefaultAlias
+ else
+ Skip
+ end;
+
+ config
+ end;
+
+val nameserver = \host -> dns (dnsNS host);
+val dnsIP = \from -> \to -> dns (dnsA from to);
+val dnsIPv6 = \from -> \to -> dns (dnsAAAA from to);
+val dnsMail = \num -> \host -> dns (dnsMX num host);
+val dnsAlias = \from -> \to -> dns (dnsCNAME from to);
+val dnsDefault = \to -> dns (dnsDefaultA to);
+val dnsDefaultv6 = \to -> dns (dnsDefaultAAAA to);
{{Analogous to <tt>web_place</tt>, but based on <tt>mailman_node</tt>s}}
extern val mailmanVhost : host -> [Domain]
- {MailmanPlaces : [mailman_place],
- SSL : ssl,
- User : your_user,
- ServerAdmin : email};
+ {MailmanPlaces : [mailman_place],
+ SSL : ssl,
+ User : your_user,
+ ServerAdmin : email};
{{Create an Apache virtual host to serve as the web interface for some Mailman
lists.}}
--- /dev/null
+{{Apache mod_cache}}
+
+extern val diskCache : location -> [Vhost];
+{{See <a href="http://httpd.apache.org/docs/2.2/mod/mod_cache.html#cacheenable">the
+ Apache documentation</a>; specifically, the case where the first parameter is
+ <tt>disk</tt>.}}
extern val cond_nocase : mod_rewrite_cond_flag;
extern val ornext : mod_rewrite_cond_flag;
-extern val rewriteRule : no_spaces -> no_spaces -> [mod_rewrite_flag] -> [^Vhost];
+extern type regexp;
+{{PCRE regular expression}}
+
+extern val rewriteRule : regexp -> no_spaces -> [mod_rewrite_flag] -> [^Vhost];
{{See <a href="http://httpd.apache.org/docs/2.0/mod/mod_rewrite.html#rewriterule">Apache
documentation for <tt>RewriteRule</tt></a>.}}
-extern val rewriteCond : no_spaces -> no_spaces -> [mod_rewrite_cond_flag] -> [^Vhost];
+extern val rewriteCond : no_spaces -> regexp -> [mod_rewrite_cond_flag] -> [^Vhost];
{{See <a href="http://httpd.apache.org/docs/2.0/mod/mod_rewrite.html#rewritecond">Apache
documentation for <tt>RewriteCond</tt></a>.}}
--- /dev/null
+*.sml
+*.mlb
--- /dev/null
+structure LibpcreH = struct
+ local
+ val lh = DynLinkage.open_lib
+ { name = "/usr/local/lib/pcre_sml.so", global = true, lazy = true }
+ handle DynLinkage.DynLinkError s => raise Fail s
+ in
+ fun libh s = let
+ val sh = DynLinkage.lib_symbol (lh, s)
+ in
+ fn () => DynLinkage.addr sh
+ end
+ end
+end
--- /dev/null
+#include <pcre.h>
+
+int PCRE_SML_validRegexp(const char *s) {
+ pcre *re;
+ const char *error;
+ int erroffset;
+
+ re = pcre_compile(s, 0, &error, &erroffset, NULL);
+
+ if (re) {
+ pcre_free(re);
+ return 1;
+ } else
+ return 0;
+}
--- /dev/null
+int PCRE_SML_validRegexp(const char *);
--- /dev/null
+*.sml
+*.mlb
+*.cm
--- /dev/null
+structure LibpcreH = struct
+ local
+ val lh = DynLinkage.open_lib
+ { name = "/usr/local/lib/pcre_sml.so", global = true, lazy = true }
+ handle DynLinkage.DynLinkError s => raise Fail s
+ in
+ fun libh s = let
+ val sh = DynLinkage.lib_symbol (lh, s)
+ in
+ fn () => DynLinkage.addr sh
+ end
+ end
+end
;;
exim)
/bin/cp /var/domtool/aliases /etc/aliases.hosted
- #/bin/cp /var/domtool/aliases.default /etc/
+ /bin/cp /var/domtool/aliases.default /etc/aliases.wildcard
redo_exim
;;
mailman)
(* HCoop Domtool (http://hcoop.sourceforge.net/)
- * Copyright (c) 2006, Adam Chlipala
+ * Copyright (c) 2006-2007, Adam Chlipala
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
(* Apply a TNested to an action *)
| EALam of string * pred * exp
(* Abstraction for building TNested values *)
+ | EIf of exp * exp * exp
+ (* If..then..else *)
withtype exp = exp' * position
datatype decl' =
printKind ("contexts", contexts);
printKind ("actions", actions);
printKind ("vals", vals);
- printKind ("env-vars", StringSet.listItems evs)
+ printKind ("env-vars", StringSet.listItems evs);
+ print "(provide 'domtool-tables)\n"
end
end
fun getpass () =
let
val tty = Posix.FileSys.stdin
- val termios = Compat.getattr tty
+ val termios = Posix.TTY.TC.getattr tty
val fields = Posix.TTY.fieldsOf termios
val termios' = Posix.TTY.termios {iflag = #iflag fields,
ispeed = #ispeed fields,
ospeed = #ospeed fields}
- fun reset () = Compat.setattr (tty, Posix.TTY.TC.sanow, termios)
+ fun reset () = Posix.TTY.TC.setattr (tty, Posix.TTY.TC.sanow, termios)
in
print " Password: ";
TextIO.flushOut TextIO.stdOut;
- Compat.setattr (tty, Posix.TTY.TC.sanow, termios');
+ Posix.TTY.TC.setattr (tty, Posix.TTY.TC.sanow, termios');
case TextIO.inputLine TextIO.stdIn of
NONE => (reset ();
Aborted)
signature COMPAT = sig
structure Char : WORD
-
- val getattr : Posix.TTY.file_desc -> Posix.TTY.termios
- val setattr : Posix.TTY.file_desc * Posix.TTY.TC.set_action * Posix.TTY.termios -> unit
end
structure Compat : COMPAT = struct
structure Char = MLRep.Char.Unsigned
-
- val getattr = Posix.TTY.TC.getattr
- val setattr = Posix.TTY.TC.setattr
end
val _ = let
structure Compat : COMPAT = struct
structure Char = Word32
-
- val getattr = Posix.TTY.getattr
- val setattr = Posix.TTY.setattr
end
val describe_type_error : Ast.position -> Ast.type_error -> unit
-
+ val ununify : Ast.typ -> Ast.typ
end
| TUnif (_, ref (SOME t')) => get_first_arg t'
| _ => raise Fail "get_first_arg failed!"
-fun describe_type_error loc te =
+fun hint te =
+ case te of
+ WrongType (_, _, (TBase "string", _), (TBase "your_domain", _), _) =>
+ SOME "Did you forget to request permission to configure this domain? See:\n\thttps://members.hcoop.net/portal/domain"
+ | WrongType (_, (EString dom, _), (TBase "string", _), (TBase "domain", _), _) =>
+ if CharVector.exists Char.isUpper dom then
+ SOME "Uppercase letters aren't allowed in domain strings."
+ else
+ NONE
+ | _ => NONE
+
+fun describe_type_error' loc te =
case te of
WrongType (place, e, t1, t2, ueo) =>
(ErrorMsg.error (SOME loc) (place ^ " has wrong type.");
preface ("Have:", p_pred p1);
preface ("Need:", p_pred p2))
+fun ununify (tAll as (t, _)) =
+ case t of
+ TUnif (_, ref (SOME t)) => ununify t
+ | _ => tAll
+
+fun normalize_error err =
+ case err of
+ WrongType (s, e, t1, t2, ueo) =>
+ WrongType (s, e, ununify t1, ununify t2, ueo)
+ | WrongForm (s1, s2, e, t, ueo) =>
+ WrongForm (s1, s2, e, ununify t, ueo)
+ | UnboundVariable _ => err
+ | WrongPred _ => err
+
+fun describe_type_error loc te =
+ let
+ val te = normalize_error te
+ in
+ describe_type_error' loc te;
+ Option.app (fn s => (print "Hint Monster says:\n";
+ print s;
+ print "\n"))
+ (hint te)
+ end
+
end
n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
| _ => false
+fun isHexDigit ch = Char.isDigit ch orelse (ord ch >= ord #"a" andalso ord ch <= ord #"f")
+
+fun validIpv6 s =
+ let
+ val fields = String.fields (fn ch => ch = #":") s
+
+ val empties = foldl (fn ("", n) => n + 1
+ | (_, n) => n) 0 fields
+
+ fun noIpv4 maxLen =
+ length fields >= 2
+ andalso length fields <= maxLen
+ andalso empties <= 1
+ andalso List.all (fn "" => true
+ | s => size s <= 4
+ andalso CharVector.all isHexDigit s) fields
+
+ fun hasIpv4 () =
+ length fields > 0
+ andalso
+ let
+ val maybeIpv4 = List.last fields
+ val theRest = List.take (fields, length fields - 1)
+ in
+ validIp maybeIpv4 andalso noIpv4 6
+ end
+ in
+ noIpv4 8 orelse hasIpv4 ()
+ end
+
fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
fun validHost s =
Env.string
validIp
+val _ = Env.type_one "ipv6"
+ Env.string
+ validIpv6
+
val _ = Env.type_one "host"
Env.string
validHost
| COLON | CARET | BANG | AND
| LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
| EQ | COMMA | BSLASH | BSLASHBSLASH | SEMI | LET | IN | BEGIN | END
- | ROOT
+ | IF | THEN | ELSE
+ | ROOT | SKIP
| EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT
%nonterm
%name Domtool
+%nonassoc THEN ELSE
%right SEMI
%nonassoc COLON
%nonassoc IN
| exp SEMI (exp)
| SYMBOL LARROW CSYMBOL SEMI exp (EGet (SYMBOL, NONE, CSYMBOL, exp), (SYMBOLleft, expright))
| SYMBOL COLON typ LARROW CSYMBOL SEMI exp (EGet (SYMBOL, SOME typ, CSYMBOL, exp), (SYMBOLleft, expright))
+ | IF exp THEN exp ELSE exp END (EIf (exp1, exp2, exp3), (IFleft, ENDright))
apps : term (term)
| apps term (EApp (apps, term), (appsleft, termright))
| LBRACK elist RBRACK (EList elist, (LBRACKleft, RBRACKright))
| LET exp IN exp END (ELocal (exp1, exp2), (LETleft, ENDright))
| SYMBOL (EVar SYMBOL, (SYMBOLleft, SYMBOLright))
+ | SKIP (ESkip, (SKIPleft, SKIPright))
sets : CSYMBOL EQ apps SEMIopt ([(ESet (CSYMBOL, apps), (CSYMBOLleft, appsright))])
| CSYMBOL EQ apps SEMI sets ((ESet (CSYMBOL, apps), (CSYMBOLleft, appsright))
<INITIAL> "with" => (Tokens.WITH (yypos, yypos + size yytext));
<INITIAL> "where" => (Tokens.WHERE (yypos, yypos + size yytext));
+<INITIAL> "if" => (Tokens.IF (yypos, yypos + size yytext));
+<INITIAL> "then" => (Tokens.THEN (yypos, yypos + size yytext));
+<INITIAL> "else" => (Tokens.ELSE (yypos, yypos + size yytext));
+<INITIAL> "Skip" => (Tokens.SKIP (yypos, yypos + size yytext));
+
<INITIAL> "extern" => (Tokens.EXTERN (yypos, yypos + size yytext));
<INITIAL> "type" => (Tokens.TYPE (yypos, yypos + size yytext));
<INITIAL> "val" => (Tokens.VAL (yypos, yypos + size yytext));
-> string * 'a arg * string * 'b arg * string * 'c arg
-> ('a * 'b * 'c -> unit) -> action
+ val noneV : string -> (env_vars -> unit) -> action
val oneV : string -> string * 'a arg -> (env_vars * 'a -> unit) -> action
val twoV : string -> string * 'a arg * string * 'b arg -> (env_vars * 'a * 'b -> unit) -> action
val container_none : string -> (unit -> unit) * (unit -> unit) -> unit
val container_one : string -> string * 'a arg -> ('a -> unit) * (unit -> unit) -> unit
+ val containerV_none : string -> (env_vars -> unit) * (unit -> unit) -> unit
val containerV_one : string -> string * 'a arg -> (env_vars * 'a -> unit) * (unit -> unit) -> unit
val registerFunction : string * (Ast.exp list -> Ast.exp option) -> unit
SM.empty))
| three func _ _ (_, es) = badArgs (func, es)
+fun noneV func f (evs, []) = (f evs;
+ SM.empty)
+ | noneV func _ (_, es) = badArgs (func, es)
+
fun oneV func (name, arg) f (evs, [e]) =
(case arg e of
NONE => badArg (func, name, e)
fun container_none name (f, g) = registerContainer (name, none name f, g)
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 linePos : int list ref
val error : (int * int) option -> string -> unit
+ val warning : (int * int) option -> string -> unit
val dummyLoc : int * int
struct
(* Initial values of compiler state variables *)
val anyErrors = ref false
+ val anyWarnings = ref false
val errorText = ref ""
val fileName = ref ""
val lineNum = ref 1
(* Reset compiler to initial state *)
fun reset() = (anyErrors:=false;
+ anyWarnings:=false;
errorText:="";
fileName:="";
lineNum:=1;
linePos:=[1];
sourceStream:=TextIO.stdIn)
- (* Print the given error message *)
- fun error posopt (msg:string) =
+ fun notify f prefix posopt (msg:string) =
let
val (startpos, endpos) = Option.getOpt (posopt, (0, 0))
fun look(pos,a::rest,n) =
else look(pos,rest,n-1)
| look _ = print "0.0"
in
- anyErrors := true;
+ f ();
print (!fileName); print ":";
look(startpos, !linePos, !lineNum);
if startpos=endpos then () else (print "-"; look(endpos, !linePos, !lineNum));
- app print [":error: ", msg, "\n"]
+ app print [":", prefix, ": ", msg, "\n"]
end
+ val error = notify (fn () => anyErrors := true) "error"
+ val warning = notify (fn () => anyWarnings := true) "warning"
+
val dummyLoc = (0, 0)
exception Error
case e of
ESkip => SM.empty
| ESet (ev, e) => SM.insert (SM.empty, ev, e)
- | EGet (x, _, ev, e) => exec' evs (Reduce.subst x (lookup (evs, ev)) e)
+ | EGet (x, _, ev, e) =>
+ let
+ val e' = Reduce.subst x (lookup (evs, ev)) e
+ in
+ exec' evs (Reduce.reduceExp Env.empty e')
+ end
| ESeq es =>
let
val (new, _) =
if !ErrorMsg.anyErrors then
G
else
- Tycheck.checkFile G (Defaults.tInit ()) prog
+ (Option.app (Unused.check G) (#3 prog);
+ Tycheck.checkFile G (Defaults.tInit ()) prog)
end
fun basis () =
if !ErrorMsg.anyErrors then
raise ErrorMsg.Error
else
- (G', #3 prog)
+ (Option.app (Unused.check b) (#3 prog);
+ (G', #3 prog))
end
end
end
empty es
| ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
| EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
+ | EIf (e1, e2, e3) => unionCTE (expNeeded G e1,
+ unionCTE (expNeeded G e2,
+ expNeeded G e3))
fun declNeeded G (d, _, _) =
case d of
--- /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.
+ *)
+
+(* Perl Compatible Regular Expressions *)
+
+signature PCRE = sig
+
+ val validRegexp : string -> bool
+
+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.
+ *)
+
+(* Perl Compatible Regular Expressions *)
+
+structure Pcre :> PCRE = struct
+
+fun validRegexp s =
+ let
+ val buf = ZString.dupML' s
+ in
+ F_PCRE_SML_validRegexp.f' buf <> 0
+ before C.free' buf
+ end
+
+end
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 =
write ": ";
writeTarget (write, t);
write "\n")
- | Default => (write "*@";
- writeDom ();
- write ": ";
- writeTarget (write, t);
- write "\n")
- | CatchAll => (writeD "*@";
- writeDomD ();
- writeD ": ";
- writeTarget (writeD, t);
- writeD "\n")
+ | Default => (writeD "*@";
+ writeDomD ();
+ writeD ": ";
+ writeTarget (writeD, t);
+ writeD "\n")
end
val _ = Env.actionV_two "aliasPrim"
Env.bool
(fn b => b orelse Domain.hasPriv "www")
+val _ = Env.type_one "regexp"
+ Env.string
+ Pcre.validRegexp
+
fun validLocation s =
size s > 0 andalso size s < 1000 andalso CharVector.all
(fn ch => Char.isAlphaNum ch
orelse ch = #"-"
orelse ch = #"_"
orelse ch = #"."
- orelse ch = #"/") s
+ orelse ch = #"/"
+ orelse ch = #"~") s
val _ = Env.type_one "location"
Env.string
| (EApp ((EVar "use_cert", _), s), _) => Option.map SOME (Env.string s)
| _ => NONE
+fun validExtension s =
+ size s > 0
+ andalso size s < 20
+ andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_") s
+
+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))),
val apache_option = fn (EVar "execCGI", _) => SOME "ExecCGI"
| (EVar "includesNOEXEC", _) => SOME "IncludesNOEXEC"
| (EVar "indexes", _) => SOME "Indexes"
+ | (EVar "followSymLinks", _) => SOME "FollowSymLinks"
| _ => NONE
val autoindex_width = fn (EVar "autofit", _) => SOME "*"
aliaser := (fn x => (old x; f x))
end
-val () = Env.containerV_one "vhost"
- ("host", Env.string)
- (fn (env, host) =>
- let
- val places = Env.env (Env.list webPlace) (env, "WebPlaces")
-
- val ssl = Env.env ssl (env, "SSL")
- val user = Env.env Env.string (env, "User")
- val group = Env.env Env.string (env, "Group")
- val docroot = Env.env Env.string (env, "DocumentRoot")
- val sadmin = Env.env Env.string (env, "ServerAdmin")
- val suexec = Env.env Env.bool (env, "SuExec")
-
- val fullHost = host ^ "." ^ Domain.currentDomain ()
- val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
- val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
- in
- currentVhost := fullHost;
- currentVhostId := vhostId;
- sslEnabled := Option.isSome ssl;
-
- rewriteEnabled := false;
- localRewriteEnabled := false;
- vhostFiles := map (fn (node, ip) =>
- let
- val file = Domain.domainFile {node = node,
- name = confFile}
+fun vhostPost () = (!post ();
+ write "</VirtualHost>\n";
+ app (TextIO.closeOut o #2) (!vhostFiles))
- val ld = logDir {user = user, node = node, vhostId = vhostId}
- in
- TextIO.output (file, "# Owner: ");
+fun vhostBody (env, makeFullHost) =
+ let
+ val places = Env.env (Env.list webPlace) (env, "WebPlaces")
+
+ val ssl = Env.env ssl (env, "SSL")
+ val user = Env.env Env.string (env, "User")
+ val group = Env.env Env.string (env, "Group")
+ val docroot = Env.env Env.string (env, "DocumentRoot")
+ val sadmin = Env.env Env.string (env, "ServerAdmin")
+ val suexec = Env.env Env.bool (env, "SuExec")
+
+ val fullHost = makeFullHost (Domain.currentDomain ())
+ val vhostId = fullHost ^ (if Option.isSome ssl then ".ssl" else "")
+ val confFile = fullHost ^ (if Option.isSome ssl then ".vhost_ssl" else ".vhost")
+ in
+ currentVhost := fullHost;
+ currentVhostId := vhostId;
+ sslEnabled := Option.isSome ssl;
+
+ rewriteEnabled := false;
+ localRewriteEnabled := false;
+ vhostFiles := map (fn (node, ip) =>
+ let
+ val file = Domain.domainFile {node = node,
+ name = confFile}
+
+ val ld = logDir {user = user, node = node, vhostId = vhostId}
+ in
+ TextIO.output (file, "# Owner: ");
+ TextIO.output (file, user);
+ TextIO.output (file, "\n<VirtualHost ");
+ TextIO.output (file, ip);
+ TextIO.output (file, ":");
+ TextIO.output (file, case ssl of
+ SOME _ => "443"
+ | NONE => "80");
+ TextIO.output (file, ">\n");
+ TextIO.output (file, "\tErrorLog ");
+ TextIO.output (file, ld);
+ TextIO.output (file, "/error.log\n\tCustomLog ");
+ TextIO.output (file, ld);
+ TextIO.output (file, "/access.log combined\n");
+ TextIO.output (file, "\tServerName ");
+ TextIO.output (file, fullHost);
+ app
+ (fn dom => (TextIO.output (file, "\n\tServerAlias ");
+ TextIO.output (file, makeFullHost dom)))
+ (Domain.currentAliasDomains ());
+
+ if suexec then
+ if isVersion1 node then
+ (TextIO.output (file, "\n\tUser ");
TextIO.output (file, user);
- TextIO.output (file, "\n<VirtualHost ");
- TextIO.output (file, ip);
- TextIO.output (file, ":");
- TextIO.output (file, case ssl of
- SOME _ => "443"
- | NONE => "80");
- TextIO.output (file, ">\n");
- TextIO.output (file, "\tErrorLog ");
- TextIO.output (file, ld);
- TextIO.output (file, "/error.log\n\tCustomLog ");
- TextIO.output (file, ld);
- TextIO.output (file, "/access.log combined\n");
- TextIO.output (file, "\tServerName ");
- TextIO.output (file, fullHost);
- app
- (fn dom => (TextIO.output (file, "\n\tServerAlias ");
- TextIO.output (file, host);
- TextIO.output (file, ".");
- TextIO.output (file, dom)))
- (Domain.currentAliasDomains ());
-
- if suexec then
- if isVersion1 node then
- (TextIO.output (file, "\n\tUser ");
- TextIO.output (file, user);
- TextIO.output (file, "\n\tGroup ");
- TextIO.output (file, group))
- else
- (TextIO.output (file, "\n\tSuexecUserGroup ");
- TextIO.output (file, user);
- TextIO.output (file, " ");
- TextIO.output (file, group))
- else
- ();
-
- if isWaklog node then
- (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
- TextIO.output (file, user);
- TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
- TextIO.output (file, user))
- else
- ();
-
- TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
+ TextIO.output (file, "\n\tGroup ");
+ TextIO.output (file, group))
+ else
+ (TextIO.output (file, "\n\tSuexecUserGroup ");
TextIO.output (file, user);
- TextIO.output (file, "/DAVLock");
+ TextIO.output (file, " ");
+ TextIO.output (file, group))
+ else
+ ();
+
+ if isWaklog node then
+ (TextIO.output (file, "\n\tWaklogEnabled on\n\tWaklogLocationPrincipal ");
+ TextIO.output (file, user);
+ TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/");
+ TextIO.output (file, user))
+ else
+ ();
+
+ TextIO.output (file, "\n\tDAVLockDB /var/lock/apache2/dav/");
+ TextIO.output (file, user);
+ TextIO.output (file, "/DAVLock");
+
+ (ld, file)
+ end)
+ places;
+ write "\n\tDocumentRoot ";
+ write docroot;
+ write "\n\tServerAdmin ";
+ write sadmin;
+ case ssl of
+ SOME cert =>
+ (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
+ write cert)
+ | NONE => ();
+ write "\n";
+ !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
+ app (fn dom => !aliaser (makeFullHost dom)) (Domain.currentAliasDomains ())
+ end
- (ld, file)
- end)
- places;
- write "\n\tDocumentRoot ";
- write docroot;
- write "\n\tServerAdmin ";
- write sadmin;
- case ssl of
- SOME cert =>
- (write "\n\tSSLEngine on\n\tSSLCertificateFile ";
- write cert)
- | NONE => ();
- write "\n";
- !pre {user = user, nodes = map #1 places, id = vhostId, hostname = fullHost};
- app (fn dom => !aliaser (host ^ "." ^ dom)) (Domain.currentAliasDomains ())
- end,
- fn () => (!post ();
- write "</VirtualHost>\n";
- app (TextIO.closeOut o #2) (!vhostFiles)))
+val () = Env.containerV_one "vhost"
+ ("host", Env.string)
+ (fn (env, host) => vhostBody (env, fn dom => host ^ "." ^ dom),
+ vhostPost)
+
+val () = Env.containerV_none "vhostDefault"
+ (fn env => vhostBody (env, fn dom => dom),
+ vhostPost)
val inLocal = ref false
app (fn opt => (write " -"; write opt)) opts;
write "\n"))
+val () = Env.action_one "cgiExtension"
+ ("extension", Env.string)
+ (fn ext => (write "\tAddHandler cgi-script ";
+ write ext;
+ write "\n"))
+
val () = Env.action_one "directoryIndex"
("filenames", Env.list Env.string)
(fn opts =>
| ch => str ch) value);
write "\"\n"))
+val () = Env.action_one "diskCache"
+ ("path", Env.string)
+ (fn path => (write "\tCacheEnable disk \"";
+ write path;
+ write "\"\n"))
+
val () = Domain.registerResetLocal (fn () =>
ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/vhosts/*")))
| MX of int * string
| NS of string
| DefaultA of string
+ | AAAA of string * string
+ | DefaultAAAA of string
val record = fn (EApp ((EApp ((EVar "dnsA", _), e1), _), e2), _) =>
(case (Env.string e1, Domain.ip e2) of
| (EApp ((EVar "dnsNS", _), e), _) =>
Option.map NS (Env.string e)
| (EApp ((EVar "dnsDefaultA", _), e), _) =>
- Option.map DefaultA (Env.string e)
+ Option.map DefaultA (Domain.ip e)
+ | (EApp ((EApp ((EVar "dnsAAAA", _), e1), _), e2), _) =>
+ (case (Env.string e1, Env.string e2) of
+ (SOME v1, SOME v2) => SOME (AAAA (v1, v2))
+ | _ => NONE)
+ | (EApp ((EVar "dnsDefaultAAAA", _), e), _) =>
+ Option.map DefaultAAAA (Env.string e)
| _ => NONE
fun writeRecord (evs, r) =
write "\tIN\tNS\t";
write host;
write ".\n")
+ | AAAA (from, to) => (write from;
+ write ".";
+ writeDom ();
+ write ".\t";
+ write (Int.toString ttl);
+ write "\tIN\tAAAA\t";
+ write to;
+ write "\n")
+ | DefaultAAAA to => (writeDom ();
+ write ".\t";
+ write (Int.toString ttl);
+ write "\tIN\tAAAA\t";
+ write to;
+ write "\n")
end
val () = Env.actionV_one "dns"
chmod 770 $DIR/$DBNAME
ln -sf $DIR/$DBNAME /var/lib/mysql/$DBNAME
fs setacl -dir $DIR/$DBNAME/ -acl system:mysql all
- sudo -H mysql -e "GRANT CREATE,SELECT,INSERT,UPDATE,DELETE,INDEX,ALTER,CREATE VIEW,SHOW VIEW,LOCK TABLES,GRANT OPTION ON TABLE * TO '$USERNAME'@$WHERE;" $DBNAME
+ sudo -H mysql -e "GRANT CREATE,CREATE TEMPORARY TABLES,SELECT,INSERT,UPDATE,DELETE,INDEX,ALTER,CREATE VIEW,SHOW VIEW,LOCK TABLES,GRANT OPTION ON TABLE * TO '$USERNAME'@$WHERE;" $DBNAME
sudo -H mysql -e "FLUSH PRIVILEGES;"
;;
StringMap.empty), dl),
(fn () => (ESkip, dl)))
+val _ = Defaults.registerDefault ("CreateWWW",
+ (TBase "bool", dl),
+ (fn () => (EVar "true", dl)))
+
+val _ = Defaults.registerDefault ("DefaultAlias",
+ (TBase "bool", dl),
+ (fn () => (EVar "true", dl)))
+
end
$c/internals/c-int.cm
../openssl/smlnj/FFI/libssl.h.cm
+../pcre/smlnj/FFI/libpcre.h.cm
compat.sig
compat_smlnj.sml
$(SML_LIB)/mlnlffi-lib/internals/c-int.mlb
../openssl/mlton/FFI/libssl.h.mlb
+../pcre/mlton/FFI/libpcre.h.mlb
compat.sig
keyword "end"]
| EWith (e1, (ESkip, _)) => dBox [p_exp e1, space 1, keyword "with", space 1, keyword "end"]
| EWith (e1, e2) => dBox [p_exp e1, space 1, keyword "with", p_exp e2, space 1, keyword "end"]
+ | EIf (e1, e2, e3) => dBox [keyword "if", space 1, p_exp e1,
+ space 1, keyword "then", space 1, p_exp e2,
+ space 1, keyword "else", space 1, p_exp e3]
and p_exp e = p_exp' false e
fun p_decl d =
| EWith (e1, e2) => freeIn x e1 orelse freeIn x e2
| EALam (x', _, b') => x <> x' andalso freeIn x b'
+ | EIf (e1, e2, e3) => freeIn x e1 orelse freeIn x e2 orelse freeIn x e3
+
local
val freshCount = ref 0
in
else
(EALam (x', p, subst x e b'), loc)
+ | EIf (b1, b2, b3) => (EIf (subst x e b1, subst x e b2, subst x e b3), loc)
+
fun findPrim (e, _) =
case e of
EApp (f, x) =>
(EALam (x, p, reduceExp G' e), loc)
end
+ | EIf (e1, e2, e3) =>
+ let
+ val e1' = reduceExp G e1
+ fun e2' () = reduceExp G e2
+ fun e3' () = reduceExp G e3
+ in
+ case e1' of
+ (EVar "true", _) => e2' ()
+ | (EVar "false", _) => e3' ()
+ | _ => (EIf (e1', e2' (), e3' ()), loc)
+ end
+
end
defaults.sig
defaults.sml
+pcre.sig
+pcre.sml
+
openssl.sig
openssl.sml
autodoc.sig
autodoc.sml
+unused.sig
+unused.sml
+
main.sig
main.sml
| _ => NONE
-fun ununify (tAll as (t, _)) =
- case t of
- TUnif (_, ref (SOME t)) => ununify t
- | _ => tAll
+val ununify = Describe.ununify
fun checkExp G (eAll as (e, loc)) =
let
| ESkip => (TAction ((CPrefix (CRoot, loc), loc),
SM.empty, SM.empty), loc)
+
+ | EIf (e1, e2, e3) =>
+ let
+ val t1 = checkExp G e1
+ val t2 = checkExp G e2
+ val t3 = checkExp G e3
+ val bool = (TBase "bool", loc)
+ in
+ (subTyp (t1, bool))
+ handle Unify ue =>
+ dte (WrongType ("\"if\" test",
+ e1,
+ t1,
+ bool,
+ SOME ue));
+ (subTyp (t2, t3); t3)
+ handle Unify _ =>
+ ((subTyp (t3, t2); t2)
+ handle Unify ue =>
+ (dte (WrongType ("\"else\" case",
+ eAll,
+ t3,
+ t2,
+ SOME ue));
+ (TError, loc)))
+ end
end
exception Ununif
--- /dev/null
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2007, 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.
+ *)
+
+(* Domtool configuration language unused environment variable setting analysis *)
+
+signature UNUSED = sig
+
+ val check : Env.env -> Ast.exp -> unit
+
+end
--- /dev/null
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2007, 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.
+ *)
+
+(* Domtool configuration language unused environment variable setting analysis *)
+
+structure Unused :> UNUSED = struct
+
+open Ast
+structure SM = StringMap
+structure SS = StringSet
+
+fun check G e =
+ let
+ fun used vars x =
+ (#1 (SM.remove (vars, x)))
+ handle NotFound => vars
+
+ fun unused loc x =
+ ErrorMsg.warning (SOME loc) ("Unused setting of environment variable " ^ x)
+
+ fun writing vars x loc =
+ (Option.app (fn loc' => unused loc' x) (SM.find (vars, x));
+ SM.insert (vars, x, loc))
+
+ fun findHead (e, _) =
+ case e of
+ EVar x => SOME x
+ | EApp (e, _) => findHead e
+ | _ => NONE
+
+ fun processTy f default loc t =
+ case #1 (Describe.ununify t) of
+ TArrow (_, t) => processTy f default loc t
+ | TNested (_, t) => processTy f default loc t
+
+ | TAction (_, reads, writes) => f (reads, writes)
+
+ | _ => default
+
+ fun writes (e, _) =
+ case e of
+ ESet (x, _) => SS.singleton x
+ | EGet (_, _, _, e) => writes e
+ | ESeq es => foldl (fn (e, s) => SS.union (writes e, s)) SS.empty es
+ | ELocal (_, e) => writes e
+ | EWith (e, _) => writes e
+ | _ => SS.empty
+
+ fun chk (eAll as (e, loc), vars) =
+ case e of
+ EInt _ => vars
+ | EString _ => vars
+ | EList es => vars
+ | ELam _ => vars
+ | ESkip => vars
+
+ | ESet (x, _) => writing vars x loc
+ | EGet (_, _, x, e) => chk (e, used vars x)
+ | ESeq es => foldl chk vars es
+ | ELocal (e1, e2) =>
+ let
+ val vars = chk (e2, chk (e1, vars))
+ val writes1 = writes e1
+ val writes2 = writes e2
+ in
+ SM.foldli (fn (x, _, vars') =>
+ if SS.member (writes1, x)
+ andalso not (SS.member (writes2, x)) then
+ SM.insert (vars', x, valOf (SM.find (vars, x)))
+ else
+ vars') vars vars
+ end
+ | EWith (e1, e2) => chk (e2, chk (e1, vars))
+ | EALam _ => vars
+ | EIf _ => vars
+
+ | _ =>
+ let
+ val processTy = processTy (fn (reads, writes) =>
+ let
+ val vars = SM.foldli (fn (x, _, vars) => used vars x) vars reads
+ in
+ SM.foldli (fn (x, _, vars) => writing vars x loc) vars writes
+ end)
+ vars
+ in
+ case findHead eAll of
+ NONE => raise Fail "Couldn't find the head"
+ | SOME head =>
+ case Env.lookupVal G head of
+ NONE => vars
+ | SOME t => processTy loc t
+ end
+ in
+ SM.appi (fn (x, loc) => unused loc x) (chk (e, SM.empty))
+ end
+end
HCoop / hcoop / zz_old / domtool2-proto.git / commitdiff