From 1c5aa57d808d51f0ac15f6613125b9f5029b89a7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 17 May 2007 23:27:56 +0000 Subject: [PATCH 01/16] dom adds an MX record --- lib/easy_domain.dtl | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index 0b4027d..585ebf1 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -27,6 +27,7 @@ val dom = dns (dnsDefaultA (ip_of_node default_node)); handleMail; + dns (dnsMX 1 "deleuze.hcoop.net"); mailbox <- Mailbox; catchAllAlias mailbox; -- 2.20.1 From e47271a147faaa62f43929ab16b3a668b87cd89e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 20 May 2007 21:41:14 +0000 Subject: [PATCH 02/16] Fix environment calculation rule for ELocal --- src/eval.sml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/eval.sml b/src/eval.sml index 6cbeca7..0cabf34 100644 --- a/src/eval.sml +++ b/src/eval.sml @@ -77,9 +77,8 @@ fun exec' evs (eAll as (e, _)) = | ELocal (e1, e2) => let val evs' = exec' evs e1 - val evs'' = exec' (conjoin (evs, evs')) e2 in - conjoin (evs, evs'') + exec' (conjoin (evs, evs')) e2 end | EWith (e1, e2) => let -- 2.20.1 From a431ca343f74b88dab08f79f1cd118dd7b1c2922 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 23 May 2007 04:31:52 +0000 Subject: [PATCH 03/16] Correct MySQL script syntax error --- configDefault/domtool.cfg | 2 +- src/domain.sml | 18 ++++++++++++------ src/plugins/domtool-mysql | 2 ++ 3 files changed, 15 insertions(+), 7 deletions(-) diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index f668791..b6b56a0 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -11,7 +11,7 @@ val grep = "/bin/grep" val sudo = "/usr/bin/sudo" val domtool_publish = "/usr/local/sbin/domtool-publish" -val defaultNs = "deleuze.hcoop.net" +val defaultNs = "ns1.hcoop.net" val defaultRefresh = 172800 val defaultRetry = 900 diff --git a/src/domain.sml b/src/domain.sml index ea3d70a..b192236 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -538,7 +538,7 @@ val _ = Env.containerV_one "domain" close () end - fun saveNamed (kind, soa : soa, masterIp) node = + fun saveNamed (kind, soa : soa, masterIp, slaveIps) node = if dom = "localhost" then () else let @@ -546,7 +546,7 @@ val _ = Env.containerV_one "domain" in write "\nzone \""; writeDom (); - write "\" IN {\n\ttype "; + write "\" {\n\ttype "; write kind; write ";\n\tfile \""; write Config.Bind.zonePath_real; @@ -554,7 +554,11 @@ val _ = Env.containerV_one "domain" writeDom (); write ".zone\";\n"; case kind of - "master" => write "\tallow-update { none; };\n" + "master" => (write "\tallow-transfer {\n"; + app (fn ip => (write "\t\t"; + write ip; + write ";\n")) slaveIps; + write "\t};\n") | _ => (write "\tmasters { "; write masterIp; write "; };\n"); @@ -568,16 +572,18 @@ val _ = Env.containerV_one "domain" let val masterIp = case #master dns of - InternalMaster node => valOf (SM.find (nodeMap, node)) + InternalMaster node => nodeIp node | ExternalMaster ip => ip + + val slaveIps = map nodeIp (#slaves dns) in app (saveSoa ("slave", #soa dns)) (#slaves dns); - app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns); + app (saveNamed ("slave", #soa dns, masterIp, slaveIps)) (#slaves dns); case #master dns of InternalMaster node => (masterNode := SOME node; saveSoa ("master", #soa dns) node; - saveNamed ("master", #soa dns, masterIp) node) + saveNamed ("master", #soa dns, masterIp, slaveIps) node) | _ => masterNode := NONE; !befores dom end diff --git a/src/plugins/domtool-mysql b/src/plugins/domtool-mysql index 657ed00..48af512 100755 --- a/src/plugins/domtool-mysql +++ b/src/plugins/domtool-mysql @@ -6,6 +6,7 @@ case $1 in PASSWORD=$3 sudo -H mysql -e "CREATE USER '$USERNAME'@'localhost' IDENTIFIED BY '$PASSWORD';" + ;; passwd) USERNAME=$2 @@ -13,6 +14,7 @@ case $1 in sudo -H mysql -e "SET PASSWORD FOR '$USERNAME'@'localhost' = PASSWORD('$PASSWORD');" ;; + createdb) USERNAME=$2 DBNAME_BASE=$3 -- 2.20.1 From 68d797e9baea9dac27d01e768ee3d860c61d8927 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 23 May 2007 17:01:14 +0000 Subject: [PATCH 04/16] Change MySQL script to follow multi-level directory scheme --- src/plugins/domtool-mysql | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/plugins/domtool-mysql b/src/plugins/domtool-mysql index 48af512..c7aac5f 100755 --- a/src/plugins/domtool-mysql +++ b/src/plugins/domtool-mysql @@ -1,4 +1,4 @@ -#!/bin/sh -e +#!/bin/bash -e case $1 in adduser) @@ -19,12 +19,12 @@ case $1 in USERNAME=$2 DBNAME_BASE=$3 DBNAME="${USERNAME}_${DBNAME_BASE}" - DIR=/afs/hcoop.net/common/databases/$USERNAME/mysql + DIR=/afs/hcoop.net/common/databases/${USERNAME:0:1}/${USERNAME:0:2}/$USERNAME/mysql kinit -k -t /etc/keytabs/root.admin.keytab root/admin aklog - if ! -d $DIR; then + if [ ! -d $DIR ]; then echo WARNING: $DIR must already exist! fi -- 2.20.1 From ec554091c6da696972d95da7d3c69fe7ca107fa2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 24 May 2007 23:12:15 +0000 Subject: [PATCH 05/16] Full records for IN and MX --- src/plugins/bind.sml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/plugins/bind.sml b/src/plugins/bind.sml index b6a07b6..5f37520 100644 --- a/src/plugins/bind.sml +++ b/src/plugins/bind.sml @@ -101,14 +101,16 @@ fun writeRecord (evs, r) = write "\tIN\tCNAME\t"; write to; write ".\n") - | MX (num, host) => (write "\t"; + | MX (num, host) => (writeDom (); + write ".\t"; write (Int.toString ttl); write "\tIN\tMX\t"; write (Int.toString num); write "\t"; write host; write ".\n") - | NS host => (write "\t"; + | NS host => (writeDom (); + write ".\t"; write (Int.toString ttl); write "\tIN\tNS\t"; write host; -- 2.20.1 From 8c57a89d75cc1d4fd050bd3767f9c881b1766c4a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 26 May 2007 15:45:48 +0000 Subject: [PATCH 06/16] Make HTML pretty-printing prettier --- src/htmlPrint.sml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/htmlPrint.sml b/src/htmlPrint.sml index 2018556..c752c3f 100644 --- a/src/htmlPrint.sml +++ b/src/htmlPrint.sml @@ -95,10 +95,13 @@ fun p_typ' pn (t, _) = TBase s => typ s | TList t => dBox [punct "[", p_typ' false t, punct "]"] | TArrow (t1, t2) => - parenIf pn [p_typ' true t1, space 1, punct "->", space 1, p_typ' true t2] + parenIf pn [p_typ' true t1, space 1, punct "->", space 1, p_typ' false t2] | TAction (p, r1, r2) => - parenIf pn [p_predBoxed p, space 1, p_record r1, space 1, - punct "=>", space 1, p_record r2] + (case (StringMap.numItems r1, StringMap.numItems r2) of + (0, 0) => parenIf pn [p_predBoxed p] + | (_, 0) => parenIf pn [p_predBoxed p, space 1, p_record r1] + | _ => parenIf pn [p_predBoxed p, space 1, p_record r1, space 1, + punct "=>", space 1, p_record r2]) | TNested (p, t) => parenIf pn [p_pred' false p, space 1, punct "=>", space 1, p_typ' false t] -- 2.20.1 From e1b99e23f8d30efc7842ee006e0ff3ef0347b7df Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 26 May 2007 16:11:32 +0000 Subject: [PATCH 07/16] Factor error message generation into a separate file; add '-tc' flag to domtool-client --- src/ast.sml | 13 +++++ src/describe.sig | 26 +++++++++ src/describe.sml | 125 ++++++++++++++++++++++++++++++++++++++++++++ src/main-client.sml | 13 +++-- src/main.sig | 1 + src/main.sml | 14 +++-- src/sources | 3 ++ src/tycheck.sml | 71 +++---------------------- 8 files changed, 195 insertions(+), 71 deletions(-) create mode 100644 src/describe.sig create mode 100644 src/describe.sml diff --git a/src/ast.sml b/src/ast.sml index ba00f78..0e8688d 100644 --- a/src/ast.sml +++ b/src/ast.sml @@ -105,4 +105,17 @@ type file = string option * decl list * exp option fun multiApp (f, loc, args) = foldl (fn (arg, e) => (EApp (e, arg), loc)) f args +datatype unification_error = + UnifyPred of pred * pred + | UnifyTyp of typ * typ + | UnifyOccurs of string * typ + +exception Unify of unification_error + +datatype type_error = + WrongType of string * exp * typ * typ * unification_error option + | WrongForm of string * string * exp * typ * unification_error option + | UnboundVariable of string + | WrongPred of string * pred * pred + end diff --git a/src/describe.sig b/src/describe.sig new file mode 100644 index 0000000..43be39a --- /dev/null +++ b/src/describe.sig @@ -0,0 +1,26 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * 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 + * 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. + *) + +(* Error message generation *) + +signature DESCRIBE = sig + + val describe_unification_error : Ast.typ -> Ast.unification_error -> unit + + val describe_type_error : Ast.position -> Ast.type_error -> unit +end diff --git a/src/describe.sml b/src/describe.sml new file mode 100644 index 0000000..a39faeb --- /dev/null +++ b/src/describe.sml @@ -0,0 +1,125 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * 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 + * 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. + *) + +(* Error message generation *) + +structure Describe :> DESCRIBE = struct + +open Ast Print + +structure SM = StringMap + +exception UnequalDomains + +fun eqRecord f (r1, r2) = + (SM.appi (fn (k, v1) => + case SM.find (r2, k) of + NONE => raise UnequalDomains + | SOME v2 => + if f (v1, v2) then + () + else + raise UnequalDomains) r1; + SM.appi (fn (k, v2) => + case SM.find (r1, k) of + NONE => raise UnequalDomains + | SOME v1 => + if f (v1, v2) then + () + else + raise UnequalDomains) r2; + true) + handle UnequalDomains => false + +fun eqPred ((p1, _), (p2, _)) = + case (p1, p2) of + (CRoot, CRoot) => true + | (CConst s1, CConst s2) => s1 = s2 + | (CPrefix p1, CPrefix p2) => eqPred (p1, p2) + | (CNot p1, CNot p2) => eqPred (p1, p2) + | (CAnd (p1, q1), CAnd (p2, q2)) => + eqPred (p1, p2) andalso eqPred (q1, q2) + + | _ => false + +fun eqTy (t1All as (t1, _), t2All as (t2, _)) = + case (t1, t2) of + (TBase s1, TBase s2) => s1 = s2 + | (TList t1, TList t2) => eqTy (t1, t2) + | (TArrow (d1, r1), TArrow (d2, r2)) => + eqTy (d1, d2) andalso eqTy (r1, r2) + + | (TAction (p1, d1, r1), TAction (p2, d2, r2)) => + eqPred (p1, p2) andalso eqRecord eqTy (d1, d2) + andalso eqRecord eqTy (r1, r2) + + | (TNested (p1, q1), TNested (p2, q2)) => + eqPred (p1, p2) andalso eqTy (q1, q2) + + | (TUnif (_, ref (SOME t1)), _) => eqTy (t1, t2All) + | (_, TUnif (_, ref (SOME t2))) => eqTy (t1All, t2) + + | (TUnif (_, r1), TUnif (_, r2)) => r1 = r2 + + | (TError, TError) => true + + | _ => false + +fun describe_unification_error t ue = + case ue of + UnifyPred (p1, p2) => + (print "Reason: Incompatible contexts.\n"; + preface ("Have:", p_pred p1); + preface ("Need:", p_pred p2)) + | UnifyTyp (t1, t2) => + if eqTy (t, t1) then + () + else + (print "Reason: Incompatible types.\n"; + preface ("Have:", p_typ t1); + preface ("Need:", p_typ t2)) + | UnifyOccurs (name, t') => + if eqTy (t, t') then + () + else + (print "Reason: Occurs check failed for "; + print name; + print " in:\n"; + printd (p_typ t)) + +fun describe_type_error loc te = + case te of + WrongType (place, e, t1, t2, ueo) => + (ErrorMsg.error (SOME loc) (place ^ " has wrong type."); + preface (" Expression:", p_exp e); + preface ("Actual type:", p_typ t1); + preface ("Needed type:", p_typ t2); + Option.app (describe_unification_error t1) ueo) + | WrongForm (place, form, e, t, ueo) => + (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type."); + preface ("Expression:", p_exp e); + preface (" Type:", p_typ t); + Option.app (describe_unification_error t) ueo) + | UnboundVariable name => + ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n") + | WrongPred (place, p1, p2) => + (ErrorMsg.error (SOME loc) ("Context incompatibility for " ^ place ^ "."); + preface ("Have:", p_pred p1); + preface ("Need:", p_pred p2)) + +end diff --git a/src/main-client.sml b/src/main-client.sml index 29db1b4..f0a6f69 100644 --- a/src/main-client.sml +++ b/src/main-client.sml @@ -27,13 +27,18 @@ fun domtoolRoot () = file = "domtool"} end -val _ = +val (doit, args) = case CommandLine.arguments () of + "-tc" :: args => (fn fname => (Main.setupUser (); ignore (Main.check fname)), args) + | args => (Main.request, args) + +val _ = + case args of [fname] => if Posix.FileSys.access (fname, []) then - Main.request fname + doit fname else - Main.request (OS.Path.joinDirFile {dir = domtoolRoot (), - file = fname}) + doit (OS.Path.joinDirFile {dir = domtoolRoot (), + file = fname}) | [] => Main.requestDir (domtoolRoot ()) | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index 3b0c791..78bb42f 100644 --- a/src/main.sig +++ b/src/main.sig @@ -21,6 +21,7 @@ signature MAIN = sig val init : unit -> unit + val setupUser : unit -> string val check : string -> Env.env * Ast.exp option val check' : Env.env -> string -> Env.env diff --git a/src/main.sml b/src/main.sml index 51b8347..a8cf180 100644 --- a/src/main.sml +++ b/src/main.sml @@ -176,7 +176,7 @@ fun context x = (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n"; raise e) -fun requestContext f = +fun setupUser () = let val user = case Posix.ProcEnv.getenv "DOMTOOL_USER" of @@ -187,9 +187,15 @@ fun requestContext f = Posix.SysDB.Passwd.name (Posix.SysDB.getpwuid uid) end | SOME user => user - - val () = Acl.read Config.aclFile - val () = Domain.setUser user + in + Acl.read Config.aclFile; + Domain.setUser user; + user + end + +fun requestContext f = + let + val user = setupUser () val () = f () diff --git a/src/sources b/src/sources index a544a3b..7809a93 100644 --- a/src/sources +++ b/src/sources @@ -24,6 +24,9 @@ print.sml env.sig env.sml +describe.sig +describe.sml + tycheck.sig tycheck.sml diff --git a/src/tycheck.sml b/src/tycheck.sml index 007a0fe..6f62a6c 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -1,5 +1,5 @@ (* 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 @@ -103,61 +103,6 @@ fun eqTy (t1All as (t1, _), t2All as (t2, _)) = | _ => false -datatype unification_error = - UnifyPred of pred * pred - | UnifyTyp of typ * typ - | UnifyOccurs of string * typ - -exception Unify of unification_error - -datatype type_error = - WrongType of string * exp * typ * typ * unification_error option - | WrongForm of string * string * exp * typ * unification_error option - | UnboundVariable of string - | WrongPred of string * pred * pred - -fun describe_unification_error t ue = - case ue of - UnifyPred (p1, p2) => - (print "Reason: Incompatible contexts.\n"; - preface ("Have:", p_pred p1); - preface ("Need:", p_pred p2)) - | UnifyTyp (t1, t2) => - if eqTy (t, t1) then - () - else - (print "Reason: Incompatible types.\n"; - preface ("Have:", p_typ t1); - preface ("Need:", p_typ t2)) - | UnifyOccurs (name, t') => - if eqTy (t, t') then - () - else - (print "Reason: Occurs check failed for "; - print name; - print " in:\n"; - printd (p_typ t)) - -fun describe_type_error loc te = - case te of - WrongType (place, e, t1, t2, ueo) => - (ErrorMsg.error (SOME loc) (place ^ " has wrong type."); - preface (" Expression:", p_exp e); - preface ("Actual type:", p_typ t1); - preface ("Needed type:", p_typ t2); - Option.app (describe_unification_error t1) ueo) - | WrongForm (place, form, e, t, ueo) => - (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type."); - preface ("Expression:", p_exp e); - preface (" Type:", p_typ t); - Option.app (describe_unification_error t) ueo) - | UnboundVariable name => - ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n") - | WrongPred (place, p1, p2) => - (ErrorMsg.error (SOME loc) ("Context incompatibility for " ^ place ^ "."); - preface ("Have:", p_pred p1); - preface ("Need:", p_pred p2)) - fun predImplies (p1All as (p1, _), p2All as (p2, _)) = case (p1, p2) of (_, CAnd (p1, p2)) => predImplies (p1All, p1) andalso predImplies (p1All, p2) @@ -359,7 +304,7 @@ fun envVarSetFrom v (e, _) = fun checkExp G (eAll as (e, loc)) = let - val dte = describe_type_error loc + val dte = Describe.describe_type_error loc in case e of EInt _ => (TBase "int", loc) @@ -730,12 +675,12 @@ fun checkDecl G (d, _, loc) = in hasTyp (e, t, to) handle Unify ue => - describe_type_error loc - (WrongType ("Bound value", - e, - t, - to, - SOME ue)); + Describe.describe_type_error loc + (WrongType ("Bound value", + e, + t, + to, + SOME ue)); bindVal G (name, to, SOME e) end | DContext name => bindContext G name -- 2.20.1 From 9b7ee2b22abce813120a633f5a4f5523a630a2ea Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 26 May 2007 17:14:42 +0000 Subject: [PATCH 08/16] Factor common printing functionality between text and HTML into a functor --- src/autodoc.sml | 2 +- src/describe.sig | 3 + src/describe.sml | 2 +- src/htmlPrint.sml | 311 +++++++++-------------------- src/print.sml | 187 +++++------------ src/printFn.sig | 58 ++++++ src/{htmlPrint.sml => printFn.sml} | 100 +++------- src/sources | 3 + src/tycheck.sml | 59 +----- 9 files changed, 240 insertions(+), 485 deletions(-) rewrite src/htmlPrint.sml (71%) rewrite src/print.sml (79%) create mode 100644 src/printFn.sig copy src/{htmlPrint.sml => printFn.sml} (67%) diff --git a/src/autodoc.sml b/src/autodoc.sml index 231a13e..86c8651 100644 --- a/src/autodoc.sml +++ b/src/autodoc.sml @@ -42,7 +42,7 @@ fun check' G fname = fun autodoc {outdir, infiles} = let val (prov, infiles) = Order.order NONE infiles - val _ = HtmlPrint.setProviders prov + val _ = HtmlPrintArg.setProviders prov val G = foldl (fn (fname, G) => check' G fname) Env.empty infiles diff --git a/src/describe.sig b/src/describe.sig index 43be39a..514c2a2 100644 --- a/src/describe.sig +++ b/src/describe.sig @@ -20,7 +20,10 @@ signature DESCRIBE = sig + exception UnequalDomains + val describe_unification_error : Ast.typ -> Ast.unification_error -> unit val describe_type_error : Ast.position -> Ast.type_error -> unit + end diff --git a/src/describe.sml b/src/describe.sml index a39faeb..1384d3b 100644 --- a/src/describe.sml +++ b/src/describe.sml @@ -100,7 +100,7 @@ fun describe_unification_error t ue = (print "Reason: Occurs check failed for "; print name; print " in:\n"; - printd (p_typ t)) + output (p_typ t)) fun describe_type_error loc te = case te of diff --git a/src/htmlPrint.sml b/src/htmlPrint.sml dissimilarity index 71% index c752c3f..f72c742 100644 --- a/src/htmlPrint.sml +++ b/src/htmlPrint.sml @@ -1,221 +1,90 @@ -(* 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. - *) - -(* Pretty-printing Domtool configuration file ASTs for HTML *) - -structure HtmlPrint :> HTML_PRINT = struct - -open Ast Order - -val prov : providers option ref = ref NONE -fun setProviders p = prov := SOME p - -structure TextToken = struct -type token = string -type style = HTMLDev.style -fun string t = t -fun style t = HTMLDev.styleTT -fun size t = String.size t -end - -structure SM = PPStreamFn(structure Token = TextToken - structure Device = HTMLDev) - -structure PD = PPDescFn(SM) -open PD - -fun dBox ds = hovBox (PPS.Rel 1, ds) -fun dvBox ds = vBox (PPS.Rel 0, ds) -fun ivBox ds = vBox (PPS.Rel 1, ds) - -fun keyword s = style (HTMLDev.styleB, [string s]) -val punct = string - -fun modify file = - let - val file' = #file (OS.Path.splitDirFile file) - val file' = #base (OS.Path.splitBaseExt file') - in - file' - end - -fun context s = - case providesContext (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#C_" ^ s), [string s]) -fun typ s = - case providesType (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#T_" ^ s), [string s]) -fun exp s = - case providesValue (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#V_" ^ s), [string s]) - -val field = string -val lit = string -val ident = string - -fun parenIf pn ds = - if pn then - dBox (punct "(" :: ds @ [punct ")"]) - else - dBox ds - -fun p_pred' pn (p, _) = - case p of - CRoot => keyword "Root" - | CConst s => context s - | CPrefix p => dBox [punct "^", p_pred' true p] - | CNot p => dBox [punct "!", p_pred' true p] - | CAnd (p1, p2) => - parenIf pn [p_pred' true p1, space 1, punct "&", space 1, p_pred' true p2] - -val p_pred = p_pred' false - -fun p_predBoxed p = dBox [punct "[", p_pred p, punct "]"] - -fun p_typ' pn (t, _) = - case t of - TBase s => typ s - | TList t => dBox [punct "[", p_typ' false t, punct "]"] - | TArrow (t1, t2) => - parenIf pn [p_typ' true t1, space 1, punct "->", space 1, p_typ' false t2] - | TAction (p, r1, r2) => - (case (StringMap.numItems r1, StringMap.numItems r2) of - (0, 0) => parenIf pn [p_predBoxed p] - | (_, 0) => parenIf pn [p_predBoxed p, space 1, p_record r1] - | _ => parenIf pn [p_predBoxed p, space 1, p_record r1, space 1, - punct "=>", space 1, p_record r2]) - | TNested (p, t) => - parenIf pn [p_pred' false p, space 1, punct "=>", space 1, p_typ' false t] - - | TError => keyword "" - | TUnif (_, ref (SOME t)) => p_typ' pn t - | TUnif (name, ref NONE) => string ("<" ^ name ^ ">") - -and p_record r = - case StringMap.foldri (fn (name, t, d) => - SOME (case d of - NONE => dBox [field name, space 1, - punct ":", space 1, p_typ t] - | SOME d => dBox [dBox [field name, space 1, - punct ":", space 1, p_typ t], - punct ",", space 1, d])) - NONE r of - NONE => punct "{}" - | SOME d => dBox [punct "{", d, punct "}"] - -and p_typ t = p_typ' false t - -fun p_exp (e, _) = - case e of - EInt n => lit (Int.toString n) - | EString s => lit (String.concat ["\"", String.toString s, "\""]) - | EList es => - (case foldr (fn (e, d) => - SOME (case d of - NONE => p_exp e - | SOME d => dBox [p_exp e, punct ",", space 1, d])) - NONE es of - NONE => punct "[]" - | SOME d => dBox [punct "[", d, punct "]"]) - - | ELam (x, NONE, e) => dBox [punct "(\\", space 1, exp x, space 1, - punct "->", space 1, p_exp e, punct ")"] - | ELam (x, SOME t, e) => dBox [punct "(\\", space 1, exp x, space 1, - 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 ")"] - - | ESkip => keyword "_" - | ESet (x, e) => dBox [exp x, space 1, punct "=", space 1, p_exp e] - | EGet (x1, x2, e) => dBox [dBox [exp x1, space 1, punct "<-", - space 1, exp x2, punct ";", space 1], - p_exp e] - | ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e] - | (e, SOME ds) => SOME (dBox [p_exp e, punct ";", newline] :: ds)) - NONE es)) - | ELocal (e1, e2) => dBox [keyword "let", space 1, - p_exp e1, space 1, - keyword "in", space 1, - p_exp e2, space 1, - 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"] - -fun p_decl d = - case d of - DExternType name => style (HTMLDev.anchor ("T_" ^ name), - [dBox [keyword "extern", space 1, - keyword "type", space 1, - ident name]]) - | DExternVal (name, t) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "extern", space 1, - keyword "val", space 1, - ident name, space 1, - string ":", space 1, - p_typ t]]) - | DVal (name, NONE, _) => string "Unannotated val declaration!" - | DVal (name, SOME t, _) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "val", space 1, - ident name, space 1, - punct ":", space 1, - p_typ t]]) - | DContext name => style (HTMLDev.anchor ("C_" ^ name), - [dBox [keyword "context", space 1, - ident name]]) - -fun p_decl_fref d = - case d of - DExternType name => dBox [keyword "extern", space 1, - keyword "type", space 1, - style (HTMLDev.link ("#T_" ^ name), [ident name])] - | DExternVal (name, t) => dBox [keyword "extern", space 1, - keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), - space 1, - string ":", space 1, - p_typ t] - | DVal (name, NONE, _) => string "Unannotated val declaration!" - | DVal (name, SOME t, _) => dBox [keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), - space 1, - punct ":", space 1, - p_typ t] - | DContext name => dBox [keyword "context", space 1, - style (HTMLDev.link ("#C_" ^ name), [ident name])] - -fun output d = - let - val dev = HTMLDev.openDev {wid = 80, - textWid = NONE} - val myStream = SM.openStream dev - in - description (myStream, d); - SM.flushStream myStream; - HTMLDev.done dev - end - -end +(* 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. + *) + +(* Pretty-printing Domtool configuration file ASTs for HTML *) + +signature HTML_PRINT_ARG = sig + include PRINTFN_INPUT where type rendering = HTML.text + + val setProviders : Order.providers -> unit +end + +structure HtmlPrintArg :> HTML_PRINT_ARG = struct + +open Ast Order + +structure TextToken = struct +type token = string +type style = HTMLDev.style +fun string t = t +fun style t = HTMLDev.styleTT +fun size t = String.size t +end + +structure SM = PPStreamFn(structure Token = TextToken + structure Device = HTMLDev) + +structure PD = PPDescFn(SM) +open PD + +fun keyword s = style (HTMLDev.styleB, [string s]) +val punct = string +val field = string +val lit = string +val ident = string + +val prov : providers option ref = ref NONE +fun setProviders p = prov := SOME p + +fun modify file = + let + val file' = #file (OS.Path.splitDirFile file) + val file' = #base (OS.Path.splitBaseExt file') + in + file' + end + +fun context s = + case providesContext (valOf (!prov), s) of + NONE => string s + | SOME m => style (HTMLDev.link (modify m ^ ".html#C_" ^ s), [string s]) +fun typ s = + case providesType (valOf (!prov), s) of + NONE => string s + | SOME m => style (HTMLDev.link (modify m ^ ".html#T_" ^ s), [string s]) +fun exp s = + case providesValue (valOf (!prov), s) of + NONE => string s + | SOME m => style (HTMLDev.link (modify m ^ ".html#V_" ^ s), [string s]) + +fun anchor (s, d) = style (HTMLDev.anchor s, [d]) +fun link (s, d) = style (HTMLDev.link s, [d]) + +type rendering = HTML.text +fun openStream () = + let + val dev = HTMLDev.openDev {wid = 80, + textWid = NONE} + in + SM.openStream dev + end +fun closeStream s = HTMLDev.done (SM.getDevice s) + +end + +structure HtmlPrint = PrintFn(HtmlPrintArg) diff --git a/src/print.sml b/src/print.sml dissimilarity index 79% index 7e38bb5..eb7421d 100644 --- a/src/print.sml +++ b/src/print.sml @@ -1,138 +1,49 @@ -(* 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. - *) - -(* Pretty-printing Domtool configuration file ASTs *) - -structure Print :> PRINT = struct - -open Ast - -structure SM = TextIOPP - -structure PD = PPDescFn(SM) -open PD - -fun dBox ds = hovBox (PPS.Rel 1, ds) -fun dvBox ds = vBox (PPS.Rel 0, ds) -fun ivBox ds = vBox (PPS.Rel 1, ds) - -fun parenIf pn ds = - if pn then - dBox (string "(" :: ds @ [string ")"]) - else - dBox ds - -fun p_pred' pn (p, _) = - case p of - CRoot => string "Root" - | CConst s => string s - | CPrefix p => dBox [string "^", p_pred' true p] - | CNot p => dBox [string "!", p_pred' true p] - | CAnd (p1, p2) => - parenIf pn [p_pred' true p1, space 1, string "&", space 1, p_pred' true p2] - -val p_pred = p_pred' false - -fun p_predBoxed p = dBox [string "[", p_pred p, string "]"] - -fun p_typ' pn (t, _) = - case t of - TBase s => string s - | TList t => dBox [string "[", p_typ' false t, string "]"] - | TArrow (t1, t2) => - parenIf pn [p_typ' true t1, space 1, string "->", space 1, p_typ' true t2] - | TAction (p, r1, r2) => - parenIf pn [p_predBoxed p, space 1, p_record r1, space 1, - string "=>", space 1, p_record r2] - | TNested (p, t) => - parenIf pn [p_pred' false p, space 1, string "=>", space 1, p_typ' false t] - - | TError => string "" - | TUnif (_, ref (SOME t)) => p_typ' pn t - | TUnif (name, ref NONE) => string ("<" ^ name ^ ">") - -and p_record r = - case StringMap.foldri (fn (name, t, d) => - SOME (case d of - NONE => dBox [string name, space 1, - string ":", space 1, p_typ t] - | SOME d => dBox [dBox [string name, space 1, - string ":", space 1, p_typ t], - string ",", space 1, d])) - NONE r of - NONE => string "{}" - | SOME d => dBox [string "{", d, string "}"] - -and p_typ t = p_typ' false t - -fun p_exp (e, _) = - case e of - EInt n => string (Int.toString n) - | EString s => string (String.concat ["\"", String.toString s, "\""]) - | EList es => - (case foldr (fn (e, d) => - SOME (case d of - NONE => p_exp e - | SOME d => dBox [p_exp e, string ",", space 1, d])) - NONE es of - NONE => string "[]" - | SOME d => dBox [string "[", d, string "]"]) - - | ELam (x, NONE, e) => dBox [string "(\\", space 1, string x, space 1, - string "->", space 1, p_exp e, string ")"] - | ELam (x, SOME t, e) => dBox [string "(\\", space 1, string x, space 1, - 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 ")"] - - | ESkip => string "_" - | ESet (x, e) => dBox [string x, space 1, string "=", space 1, p_exp e] - | EGet (x1, x2, e) => dBox [dBox [string x1, space 1, string "<-", - space 1, string x2, string ";", space 1], - p_exp e] - | ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e] - | (e, SOME ds) => SOME (dBox [p_exp e, string ";", newline] :: ds)) - NONE es)) - | ELocal (e1, e2) => dBox [string "let", space 1, - p_exp e1, space 1, - string "in", space 1, - p_exp e2, space 1, - string "end"] - | EWith (e1, (ESkip, _)) => dBox [p_exp e1, space 1, string "with", space 1, string "end"] - | EWith (e1, e2) => dBox [p_exp e1, space 1, string "with", p_exp e2, space 1, string "end"] - -fun printd d = - let - val myStream = SM.openOut {dst = TextIO.stdOut, - wid = 80} - in - description (myStream, d); - SM.newline myStream; - SM.closeStream myStream - end - -fun preface (s, d) = printd (PD.hovBox (PD.PPS.Rel 0, - [PD.string s, PD.space 1, d])) - -end +(* 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. + *) + +(* Pretty-printing Domtool configuration file ASTs *) + +signature PRINT_ARG = PRINTFN_INPUT where type rendering = unit + +structure PrintArg :> PRINT_ARG = struct + +structure SM = TextIOPP + +structure PD = PPDescFn(SM) +open PD + +val keyword = string +val punct = string +val field = string +val lit = string +val ident = string + +val context = string +val typ = string +val exp = string + +fun anchor (_, d) = d +fun link (_, d) = d + +type rendering = unit +fun openStream () = SM.openOut {dst = TextIO.stdOut, wid = 80} +fun closeStream s = (SM.newline s; SM.closeStream s) + +end + +structure Print = PrintFn(PrintArg) diff --git a/src/printFn.sig b/src/printFn.sig new file mode 100644 index 0000000..b2afaf0 --- /dev/null +++ b/src/printFn.sig @@ -0,0 +1,58 @@ +(* 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. + *) + +(* Pretty-printing Domtool configuration file ASTs *) + +signature PRINTFN_INPUT = sig + + structure PD : PP_DESC + + val keyword : string -> PD.pp_desc + val punct : string -> PD.pp_desc + val field : string -> PD.pp_desc + val lit : string -> PD.pp_desc + val ident : string -> PD.pp_desc + + val context : string -> PD.pp_desc + val typ : string -> PD.pp_desc + val exp : string -> PD.pp_desc + + val anchor : string * PD.pp_desc -> PD.pp_desc + val link : string * PD.pp_desc -> PD.pp_desc + + type rendering + val openStream : unit -> PD.PPS.stream + val closeStream : PD.PPS.stream -> rendering + +end + +signature PRINTFN_OUTPUT = sig + + structure PD : PP_DESC + type rendering + + val p_pred : Ast.pred -> PD.pp_desc + val p_typ : Ast.typ -> PD.pp_desc + val p_exp : Ast.exp -> PD.pp_desc + val p_decl : Ast.decl' -> PD.pp_desc + val p_decl_fref : Ast.decl' -> PD.pp_desc + + val output : PD.pp_desc -> rendering + val preface : string * PD.pp_desc -> rendering + +end diff --git a/src/htmlPrint.sml b/src/printFn.sml similarity index 67% copy from src/htmlPrint.sml copy to src/printFn.sml index c752c3f..871c1df 100644 --- a/src/htmlPrint.sml +++ b/src/printFn.sml @@ -16,36 +16,17 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) -(* Pretty-printing Domtool configuration file ASTs for HTML *) +(* Pretty-printing Domtool configuration file ASTs *) -structure HtmlPrint :> HTML_PRINT = struct +functor PrintFn (PF : PRINTFN_INPUT) :> PRINTFN_OUTPUT where type rendering = PF.rendering = struct -open Ast Order - -val prov : providers option ref = ref NONE -fun setProviders p = prov := SOME p - -structure TextToken = struct -type token = string -type style = HTMLDev.style -fun string t = t -fun style t = HTMLDev.styleTT -fun size t = String.size t -end - -structure SM = PPStreamFn(structure Token = TextToken - structure Device = HTMLDev) - -structure PD = PPDescFn(SM) +open Ast PF open PD fun dBox ds = hovBox (PPS.Rel 1, ds) fun dvBox ds = vBox (PPS.Rel 0, ds) fun ivBox ds = vBox (PPS.Rel 1, ds) -fun keyword s = style (HTMLDev.styleB, [string s]) -val punct = string - fun modify file = let val file' = #file (OS.Path.splitDirFile file) @@ -54,23 +35,6 @@ fun modify file = file' end -fun context s = - case providesContext (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#C_" ^ s), [string s]) -fun typ s = - case providesType (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#T_" ^ s), [string s]) -fun exp s = - case providesValue (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#V_" ^ s), [string s]) - -val field = string -val lit = string -val ident = string - fun parenIf pn ds = if pn then dBox (punct "(" :: ds @ [punct ")"]) @@ -123,7 +87,7 @@ and p_record r = and p_typ t = p_typ' false t -fun p_exp (e, _) = +fun p_exp' pn (e, _) = case e of EInt n => lit (Int.toString n) | EString s => lit (String.concat ["\"", String.toString s, "\""]) @@ -147,14 +111,14 @@ fun p_exp (e, _) = 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 ")"] + | EApp (e1, e2) => parenIf pn [p_exp e1, break {nsp = 1, offset = 0}, p_exp' true e2] | ESkip => keyword "_" - | ESet (x, e) => dBox [exp x, space 1, punct "=", space 1, p_exp e] - | EGet (x1, x2, e) => dBox [dBox [exp x1, space 1, punct "<-", - space 1, exp x2, punct ";", space 1], - p_exp e] - | ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e] + | ESet (x, e) => parenIf pn [exp x, space 1, punct "=", space 1, p_exp e] + | EGet (x1, x2, e) => parenIf pn [dBox [exp x1, space 1, punct "<-", + space 1, exp x2, punct ";", space 1], + p_exp e] + | ESeq es => parenIf pn (valOf (foldr (fn (e, NONE) => SOME [p_exp e] | (e, SOME ds) => SOME (dBox [p_exp e, punct ";", newline] :: ds)) NONE es)) | ELocal (e1, e2) => dBox [keyword "let", space 1, @@ -164,58 +128,60 @@ fun p_exp (e, _) = 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"] +and p_exp e = p_exp' false e fun p_decl d = case d of - DExternType name => style (HTMLDev.anchor ("T_" ^ name), - [dBox [keyword "extern", space 1, + DExternType name => anchor ("T_" ^ name, + dBox [keyword "extern", space 1, keyword "type", space 1, - ident name]]) - | DExternVal (name, t) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "extern", space 1, + ident name]) + | DExternVal (name, t) => anchor ("V_" ^ name, + dBox [keyword "extern", space 1, keyword "val", space 1, ident name, space 1, string ":", space 1, - p_typ t]]) + p_typ t]) | DVal (name, NONE, _) => string "Unannotated val declaration!" - | DVal (name, SOME t, _) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "val", space 1, + | DVal (name, SOME t, _) => anchor ("V_" ^ name, + dBox [keyword "val", space 1, ident name, space 1, punct ":", space 1, - p_typ t]]) - | DContext name => style (HTMLDev.anchor ("C_" ^ name), - [dBox [keyword "context", space 1, - ident name]]) + p_typ t]) + | DContext name => anchor ("C_" ^ name, + dBox [keyword "context", space 1, + ident name]) fun p_decl_fref d = case d of DExternType name => dBox [keyword "extern", space 1, keyword "type", space 1, - style (HTMLDev.link ("#T_" ^ name), [ident name])] + link ("#T_" ^ name, ident name)] | DExternVal (name, t) => dBox [keyword "extern", space 1, keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), + link ("#V_" ^ name, ident name), space 1, string ":", space 1, p_typ t] | DVal (name, NONE, _) => string "Unannotated val declaration!" | DVal (name, SOME t, _) => dBox [keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), + link ("#V_" ^ name, ident name), space 1, punct ":", space 1, p_typ t] | DContext name => dBox [keyword "context", space 1, - style (HTMLDev.link ("#C_" ^ name), [ident name])] + link ("#C_" ^ name, ident name)] fun output d = let - val dev = HTMLDev.openDev {wid = 80, - textWid = NONE} - val myStream = SM.openStream dev + val myStream = openStream () in description (myStream, d); - SM.flushStream myStream; - HTMLDev.done dev + PPS.flushStream myStream; + closeStream myStream end +fun preface (s, d) = output (PD.hovBox (PD.PPS.Rel 0, + [PD.string s, PD.space 1, d])) + end diff --git a/src/sources b/src/sources index 7809a93..3b129fd 100644 --- a/src/sources +++ b/src/sources @@ -18,6 +18,9 @@ domtool.lex parse.sig parse.sml +printFn.sig +printFn.sml + print.sig print.sml diff --git a/src/tycheck.sml b/src/tycheck.sml index 6f62a6c..d486603 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -47,61 +47,6 @@ fun newUnif () = end end -exception UnequalDomains - -fun eqRecord f (r1, r2) = - (SM.appi (fn (k, v1) => - case SM.find (r2, k) of - NONE => raise UnequalDomains - | SOME v2 => - if f (v1, v2) then - () - else - raise UnequalDomains) r1; - SM.appi (fn (k, v2) => - case SM.find (r1, k) of - NONE => raise UnequalDomains - | SOME v1 => - if f (v1, v2) then - () - else - raise UnequalDomains) r2; - true) - handle UnequalDomains => false - -fun eqPred ((p1, _), (p2, _)) = - case (p1, p2) of - (CRoot, CRoot) => true - | (CConst s1, CConst s2) => s1 = s2 - | (CPrefix p1, CPrefix p2) => eqPred (p1, p2) - | (CNot p1, CNot p2) => eqPred (p1, p2) - | (CAnd (p1, q1), CAnd (p2, q2)) => - eqPred (p1, p2) andalso eqPred (q1, q2) - - | _ => false - -fun eqTy (t1All as (t1, _), t2All as (t2, _)) = - case (t1, t2) of - (TBase s1, TBase s2) => s1 = s2 - | (TList t1, TList t2) => eqTy (t1, t2) - | (TArrow (d1, r1), TArrow (d2, r2)) => - eqTy (d1, d2) andalso eqTy (r1, r2) - - | (TAction (p1, d1, r1), TAction (p2, d2, r2)) => - eqPred (p1, p2) andalso eqRecord eqTy (d1, d2) - andalso eqRecord eqTy (r1, r2) - - | (TNested (p1, q1), TNested (p2, q2)) => - eqPred (p1, p2) andalso eqTy (q1, q2) - - | (TUnif (_, ref (SOME t1)), _) => eqTy (t1, t2All) - | (_, TUnif (_, ref (SOME t2))) => eqTy (t1All, t2) - - | (TUnif (_, r1), TUnif (_, r2)) => r1 = r2 - - | (TError, TError) => true - - | _ => false fun predImplies (p1All as (p1, _), p2All as (p2, _)) = case (p1, p2) of @@ -154,7 +99,7 @@ fun subPred (p1, p2) = fun subRecord f (r1, r2) = SM.appi (fn (k, v2) => case SM.find (r1, k) of - NONE => raise UnequalDomains + NONE => raise Describe.UnequalDomains | SOME v1 => f (v1, v2)) r2 fun occurs u (t, _) = @@ -646,7 +591,7 @@ fun checkUnit G (eAll as (_, loc)) = ununif t handle Ununif => (ErrorMsg.error (SOME loc) "Unification variables remain in type:"; - printd (p_typ t); + output (p_typ t); t) end -- 2.20.1 From 07d66c3691fac5239dfa1f5a8858623ef542c71f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 26 May 2007 17:24:58 +0000 Subject: [PATCH 09/16] Special error message for withholding arguments to configuration functions --- src/describe.sml | 27 +++++++++++++++++++++++---- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/src/describe.sml b/src/describe.sml index 1384d3b..a753ddb 100644 --- a/src/describe.sml +++ b/src/describe.sml @@ -102,6 +102,20 @@ fun describe_unification_error t ue = print " in:\n"; output (p_typ t)) +fun will_be_action (t, _) = + case t of + TArrow (_, t') => will_be_action t' + | TAction _ => true + | TNested _ => true + | TUnif (_, ref (SOME t')) => will_be_action t' + | _ => false + +fun get_first_arg (t, _) = + case t of + TArrow (t', _) => t' + | TUnif (_, ref (SOME t')) => get_first_arg t' + | _ => raise Fail "get_first_arg failed!" + fun describe_type_error loc te = case te of WrongType (place, e, t1, t2, ueo) => @@ -111,10 +125,15 @@ fun describe_type_error loc te = preface ("Needed type:", p_typ t2); Option.app (describe_unification_error t1) ueo) | WrongForm (place, form, e, t, ueo) => - (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type."); - preface ("Expression:", p_exp e); - preface (" Type:", p_typ t); - Option.app (describe_unification_error t) ueo) + if form = "action" andalso will_be_action t then + (ErrorMsg.error (SOME loc) "Not enough arguments passed to configuration function."; + preface (" Expression so far:", p_exp e); + preface ("Next argument type:", p_typ (get_first_arg t))) + else + (ErrorMsg.error (SOME loc) (place ^ " has a non-" ^ form ^ " type."); + preface ("Expression:", p_exp e); + preface (" Type:", p_typ t); + Option.app (describe_unification_error t) ueo) | UnboundVariable name => ErrorMsg.error (SOME loc) ("Unbound variable " ^ name ^ ".\n") | WrongPred (place, p1, p2) => -- 2.20.1 From 94b7b11acaf25eadda183ff48cf2cf497e8aef58 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 27 May 2007 21:56:21 +0000 Subject: [PATCH 10/16] rewriteBase --- lib/easy_domain.dtl | 4 ++-- lib/mod_rewrite.dtl | 6 +++++- src/plugins/apache.sml | 8 ++++++++ 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index 585ebf1..925802d 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -21,8 +21,8 @@ val dom = \ d : (your_domain) -> \\ config : Domain -> domain d with - dns (dnsNS "deleuze.hcoop.net"); - dns (dnsNS "mire.hcoop.net"); + dns (dnsNS "ns1.hcoop.net"); + dns (dnsNS "ns3.hcoop.net"); dns (dnsDefaultA (ip_of_node default_node)); diff --git a/lib/mod_rewrite.dtl b/lib/mod_rewrite.dtl index 9a6795a..877e1c4 100644 --- a/lib/mod_rewrite.dtl +++ b/lib/mod_rewrite.dtl @@ -50,10 +50,14 @@ extern val rewriteRule : no_spaces -> no_spaces -> [mod_rewrite_flag] -> [^Vhost {{See Apache documentation for RewriteRule.}} -extern val rewriteCond: no_spaces -> no_spaces -> [mod_rewrite_cond_flag] -> [^Vhost]; +extern val rewriteCond : no_spaces -> no_spaces -> [mod_rewrite_cond_flag] -> [^Vhost]; {{See Apache documentation for RewriteCond.}} +extern val rewriteBase : no_spaces -> [^Vhost]; +{{See Apache + documentation for RewriteBase.}} + extern type proxy_port; {{A port number above 1024}} diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 4c60d7a..4a399e8 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -570,6 +570,14 @@ val () = Env.action_three "rewriteCond" write "]"); write "\n")) +val () = Env.action_one "rewriteBase" + ("prefix", Env.string) + (fn prefix => + (checkRewrite (); + write "\tRewriteBase\t"; + write prefix; + write "\n")) + val () = Env.action_one "rewriteLogLevel" ("level", Env.int) (fn level => -- 2.20.1 From c8cc5b95c52de03af79196cf76d2197a846913c8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 30 May 2007 02:24:05 +0000 Subject: [PATCH 11/16] Change MySQL user hostmask --- src/plugins/domtool-mysql | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/plugins/domtool-mysql b/src/plugins/domtool-mysql index c7aac5f..f476482 100755 --- a/src/plugins/domtool-mysql +++ b/src/plugins/domtool-mysql @@ -1,18 +1,20 @@ #!/bin/bash -e +WHERE="'%.hcoop.net'" + case $1 in adduser) USERNAME=$2 PASSWORD=$3 - sudo -H mysql -e "CREATE USER '$USERNAME'@'localhost' IDENTIFIED BY '$PASSWORD';" + sudo -H mysql -e "CREATE USER '$USERNAME'@$WHERE IDENTIFIED BY '$PASSWORD';" ;; passwd) USERNAME=$2 PASSWORD=$3 - sudo -H mysql -e "SET PASSWORD FOR '$USERNAME'@'localhost' = PASSWORD('$PASSWORD');" + sudo -H mysql -e "SET PASSWORD FOR '$USERNAME'@$WHERE = PASSWORD('$PASSWORD');" ;; createdb) @@ -34,7 +36,7 @@ case $1 in 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,GRANT OPTION ON TABLE * TO '$USERNAME'@'localhost';" $DBNAME + sudo -H mysql -e "GRANT CREATE,SELECT,INSERT,UPDATE,DELETE,INDEX,ALTER,CREATE VIEW,SHOW VIEW,GRANT OPTION ON TABLE * TO '$USERNAME'@$WHERE;" $DBNAME sudo -H mysql -e "FLUSH PRIVILEGES;" ;; *) -- 2.20.1 From fdf9a42df2892bae989ec2d47d5c22817dec7271 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 6 Jun 2007 16:14:37 +0000 Subject: [PATCH 12/16] Change context requirement for rewriteBase; change CGI principal convention --- lib/mod_rewrite.dtl | 2 +- src/plugins/apache.sml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/mod_rewrite.dtl b/lib/mod_rewrite.dtl index 877e1c4..2e29877 100644 --- a/lib/mod_rewrite.dtl +++ b/lib/mod_rewrite.dtl @@ -54,7 +54,7 @@ extern val rewriteCond : no_spaces -> no_spaces -> [mod_rewrite_cond_flag] -> [^ {{See Apache documentation for RewriteCond.}} -extern val rewriteBase : no_spaces -> [^Vhost]; +extern val rewriteBase : no_spaces -> [Location]; {{See Apache documentation for RewriteBase.}} diff --git a/src/plugins/apache.sml b/src/plugins/apache.sml index 4a399e8..3266d54 100644 --- a/src/plugins/apache.sml +++ b/src/plugins/apache.sml @@ -445,7 +445,7 @@ val () = Env.containerV_one "vhost" if isWaklog node then (TextIO.output (file, "\n\tWaklogProtected on\n\tWaklogPrincipal "); TextIO.output (file, user); - TextIO.output (file, "/cgi@HCOOP.NET /etc/keytabs/cgi/"); + TextIO.output (file, "/daemon@HCOOP.NET /etc/keytabs/user.daemon/"); TextIO.output (file, user)) else (); -- 2.20.1 From 25c93232ead88499dc1d1b5bf145e8fbfdb5bbe8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jun 2007 20:32:36 +0000 Subject: [PATCH 13/16] A little more verbose on SSL context error; script for creating daemon certs --- Makefile | 1 + scripts/domtool-addcert-daemon | 28 ++++++++++++++++++++++++++++ src/main.sml | 3 ++- 3 files changed, 31 insertions(+), 1 deletion(-) create mode 100755 scripts/domtool-addcert-daemon diff --git a/Makefile b/Makefile index b812465..68feaf0 100644 --- a/Makefile +++ b/Makefile @@ -143,6 +143,7 @@ install: cp scripts/domtool-reset-local /usr/local/sbin/ cp scripts/domtool-adduser /usr/local/bin/ cp scripts/domtool-addcert /usr/local/bin/ + cp scripts/domtool-addcert-daemon /usr/local/bin/ cp scripts/domtool-addacl /usr/local/bin/ cp scripts/domtool-rmuser /usr/local/bin/ cp scripts/domtool-admin-sudo /usr/local/bin/ diff --git a/scripts/domtool-addcert-daemon b/scripts/domtool-addcert-daemon new file mode 100755 index 0000000..96242f4 --- /dev/null +++ b/scripts/domtool-addcert-daemon @@ -0,0 +1,28 @@ +#!/bin/sh -e + + KEYDIR=/afs/hcoop.net/common/etc/domtool/keys/$1 + KEYFILE=$KEYDIR/key.pem +CERTFILE=/afs/hcoop.net/common/etc/domtool/certs/$1.pem + NEWREQ=~/.newreq.pem + NEW=~/.new.pem + KEYIN=~/.keyin + +mkdir $KEYDIR || echo Already exists +openssl genrsa -out $KEYFILE +chown -R domtool.domtool $KEYDIR +echo "." >$KEYIN +echo "." >>$KEYIN +echo "." >>$KEYIN +echo "." >>$KEYIN +echo "." >>$KEYIN +echo "$1" >>$KEYIN +echo "$1@hcoop.net" >>$KEYIN +echo "" >>$KEYIN +echo "" >>$KEYIN +openssl req -new -key $KEYFILE -out $NEWREQ -days 365 <$KEYIN +rm $KEYIN +cat $NEWREQ $KEYFILE >$NEW +rm $NEWREQ +openssl ca -batch -config /etc/domtool/openssl.cnf -policy policy_anything -out $CERTFILE -infiles $NEW +rm $NEW +chown domtool.domtool $CERTFILE diff --git a/src/main.sml b/src/main.sml index a8cf180..798ede2 100644 --- a/src/main.sml +++ b/src/main.sml @@ -172,8 +172,9 @@ val self = fun context x = (OpenSSL.context false x) - handle e as OpenSSL.OpenSSL _ => + handle e as OpenSSL.OpenSSL s => (print "Couldn't find your certificate.\nYou probably haven't been given any Domtool privileges.\n"; + print ("Additional information: " ^ s ^ "\n"); raise e) fun setupUser () = -- 2.20.1 From 64a44dc0899e92d8c1b708fb754ad1b2126c67fe Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jun 2007 21:34:48 +0000 Subject: [PATCH 14/16] Some OpenSSL frobbing --- openssl/openssl_sml.c | 4 ++++ openssl/openssl_sml.h | 1 + src/main.sml | 8 +++++--- src/openssl.sml | 19 +++++++++---------- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/openssl/openssl_sml.c b/openssl/openssl_sml.c index fc82769..407e74f 100644 --- a/openssl/openssl_sml.c +++ b/openssl/openssl_sml.c @@ -24,6 +24,10 @@ int OpenSSL_SML_get_error() { return ERR_get_error(); } +int OpenSSL_SML_should_retry(BIO *b) { + return BIO_should_retry(b); +} + const char *OpenSSL_SML_lib_error_string(int err) { return ERR_lib_error_string(err); } diff --git a/openssl/openssl_sml.h b/openssl/openssl_sml.h index 0568d29..3d5cd46 100644 --- a/openssl/openssl_sml.h +++ b/openssl/openssl_sml.h @@ -7,6 +7,7 @@ void OpenSSL_SML_load_error_strings(void); void OpenSSL_SML_load_BIO_strings(void); int OpenSSL_SML_get_error(void); +int OpenSSL_SML_should_retry(BIO *b); const char *OpenSSL_SML_lib_error_string(int err); const char *OpenSSL_SML_func_error_string(int err); const char *OpenSSL_SML_reason_error_string(int err); diff --git a/src/main.sml b/src/main.sml index 798ede2..fd4ff63 100644 --- a/src/main.sml +++ b/src/main.sml @@ -942,8 +942,9 @@ fun service () = (print msgLocal; print "\n"; Msg.send (bio, MsgOk))) - handle OpenSSL.OpenSSL _ => - print "OpenSSL error\n" + handle e as (OpenSSL.OpenSSL s) => + (print "OpenSSL error\n"; + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e)) | OS.SysErr (s, _) => (print "System error: "; print s; @@ -1268,8 +1269,9 @@ fun service () = in cmdLoop () end - handle OpenSSL.OpenSSL s => + handle e as (OpenSSL.OpenSSL s) => (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); OpenSSL.close bio handle OpenSSL.OpenSSL _ => (); loop ()) diff --git a/src/openssl.sml b/src/openssl.sml index 3f3b292..df63276 100644 --- a/src/openssl.sml +++ b/src/openssl.sml @@ -45,16 +45,15 @@ fun ssl_err s = else (print (ZString.toML lib); print ":"); - if C.Ptr.isNull func then - () - else - (print (ZString.toML func); - print ":"); - if C.Ptr.isNull reason then - () - else - print (ZString.toML reason); - print "\n" + if C.Ptr.isNull func then + () + else + (print (ZString.toML func); + print ":"); + if C.Ptr.isNull reason then + () + else + print (ZString.toML reason) end val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize) -- 2.20.1 From d307ad55e460dd1ceb4fa0601e45546e2f2a87d3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 16 Jun 2007 21:35:17 +0000 Subject: [PATCH 15/16] Change dispatcher principal name to be more consistent with other cases --- configDefault/domtool.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index b6b56a0..34b7d69 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -51,7 +51,7 @@ val certDir = "/afs/hcoop.net/common/etc/domtool/certs" val keyDir = "/afs/hcoop.net/common/etc/domtool/keys" val serialDir = "/afs/hcoop.net/common/etc/domtool/serials" -val dispatcherName = "deleuze.hcoop.net" +val dispatcherName = "deleuze" fun domtoolDir user = case user of -- 2.20.1 From 16465a9ab10d41506006aa27499513a42d2b7de6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 20 Jun 2007 23:43:21 +0000 Subject: [PATCH 16/16] Remove catchAllAlias in favor of defaultAlias; add better handling of slave servers being down --- lib/alias.dtl | 7 ++----- lib/easy_domain.dtl | 5 +++-- src/main.sml | 9 ++++++--- src/openssl.sml | 3 ++- 4 files changed, 13 insertions(+), 11 deletions(-) diff --git a/lib/alias.dtl b/lib/alias.dtl index 10f7dde..113654b 100644 --- a/lib/alias.dtl +++ b/lib/alias.dtl @@ -41,8 +41,5 @@ val aliasDrop = \user -> aliasPrim (userSource user) dropTarget; {{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, and it - doesn't match any systemwide username, send it to this e-mail address.}} -val catchAllAlias = \email -> aliasPrim catchAllSource (addressTarget email); -{{When a message to the current domain doesn't match any other alias, send it - to this e-mail address, even if it matches a systemwide username.}} +{{When a message to the current domain doesn't match any other alias, send it to + this e-mail address.}} diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index 925802d..03af55f 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -24,14 +24,15 @@ val dom = dns (dnsNS "ns1.hcoop.net"); dns (dnsNS "ns3.hcoop.net"); - dns (dnsDefaultA (ip_of_node default_node)); + dns (dnsDefaultA (ip_of_node (web_node_to_node web_node))); handleMail; dns (dnsMX 1 "deleuze.hcoop.net"); mailbox <- Mailbox; - catchAllAlias mailbox; + defaultAlias mailbox; web "www" with + serverAliasDefault end; config diff --git a/src/main.sml b/src/main.sml index fd4ff63..87f2869 100644 --- a/src/main.sml +++ b/src/main.sml @@ -836,7 +836,8 @@ fun regenerate context = | _ => print ("Slave " ^ node ^ " returned unexpected command\n"); OpenSSL.close bio - end + end + handle OpenSSL.OpenSSL s => print ("OpenSSL error: " ^ s ^ "\n") fun doUser user = let @@ -943,8 +944,10 @@ fun service () = print "\n"; Msg.send (bio, MsgOk))) handle e as (OpenSSL.OpenSSL s) => - (print "OpenSSL error\n"; - app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e)) + (print ("OpenSSL error: " ^ s ^ "\n"); + app (fn x => print (x ^ "\n")) (SMLofNJ.exnHistory e); + Msg.send (bio, MsgError ("OpenSSL error: " ^ s)) + handle OpenSSL.OpenSSL _ => ()) | OS.SysErr (s, _) => (print "System error: "; print s; diff --git a/src/openssl.sml b/src/openssl.sml index df63276..d309a61 100644 --- a/src/openssl.sml +++ b/src/openssl.sml @@ -53,7 +53,8 @@ fun ssl_err s = if C.Ptr.isNull reason then () else - print (ZString.toML reason) + print (ZString.toML reason); + print "\n" end val readBuf : (C.uchar, C.rw) C.obj C.ptr' = C.alloc' C.S.uchar (Word.fromInt Config.bufSize) -- 2.20.1