From c53e82e40cef407de986aa329d31457915ad0dbe Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 15 Dec 2006 20:38:39 +0000 Subject: [PATCH] Multi-configuration support --- src/autodoc.sml | 2 +- src/main-client.sml | 17 ++++- src/main.sig | 3 + src/main.sml | 152 +++++++++++++++++++++++++++++++++++--------- src/msg.sml | 85 +++++++++++-------------- src/msgTypes.sml | 3 +- src/order.sig | 3 +- src/order.sml | 39 ++++++++---- 8 files changed, 209 insertions(+), 95 deletions(-) diff --git a/src/autodoc.sml b/src/autodoc.sml index b342e6e..231a13e 100644 --- a/src/autodoc.sml +++ b/src/autodoc.sml @@ -41,7 +41,7 @@ fun check' G fname = fun autodoc {outdir, infiles} = let - val (prov, infiles) = Order.order infiles + val (prov, infiles) = Order.order NONE infiles val _ = HtmlPrint.setProviders prov val G = foldl (fn (fname, G) => check' G fname) Env.empty infiles diff --git a/src/main-client.sml b/src/main-client.sml index d6fe010..c70dfb8 100644 --- a/src/main-client.sml +++ b/src/main-client.sml @@ -18,7 +18,22 @@ (* Driver for server *) +fun domtoolRoot () = + let + val uid = Posix.ProcEnv.getuid () + val home = Posix.SysDB.Passwd.home (Posix.SysDB.getpwuid uid) + in + OS.Path.joinDirFile {dir = home, + file = "domtool"} + end + val _ = case CommandLine.arguments () of - [fname] => Main.request fname + [fname] => + if Posix.FileSys.access (fname, []) then + Main.request fname + else + Main.request (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 9e6dda3..ac7f9c9 100644 --- a/src/main.sig +++ b/src/main.sig @@ -24,6 +24,7 @@ signature MAIN = sig val check : string -> Env.env * Ast.exp option val check' : Env.env -> string -> Env.env + val checkDir : string -> bool val basis : unit -> Env.env @@ -31,6 +32,8 @@ signature MAIN = sig val eval : string -> unit val request : string -> unit + val requestDir : string -> unit + val requestGrant : Acl.acl -> unit val requestRevoke : Acl.acl -> unit val requestListPerms : string -> (string * string list) list option diff --git a/src/main.sml b/src/main.sml index 0c60f08..3c0b728 100644 --- a/src/main.sml +++ b/src/main.sml @@ -53,7 +53,7 @@ fun basis () = loop files val files = loop [] - val (_, files) = Order.order files + val (_, files) = Order.order NONE files in if !ErrorMsg.anyErrors then Env.empty @@ -92,6 +92,36 @@ fun check fname = end end +val notTmp = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-") + +fun checkDir dname = + let + val b = basis () + + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + false + else + (foldl (fn (fname, G) => check' G fname) b files; + !ErrorMsg.anyErrors) + end + fun reduce fname = let val (G, body) = check fname @@ -175,6 +205,59 @@ fun request fname = end handle ErrorMsg.Error => () +fun requestDir dname = + let + val (user, bio) = requestBio (fn () => ignore (checkDir dname)) + + val b = basis () + + val dir = Posix.FileSys.opendir dname + + fun loop files = + case Posix.FileSys.readdir dir of + NONE => (Posix.FileSys.closedir dir; + files) + | SOME fname => + if notTmp fname then + loop (OS.Path.joinDirFile {dir = dname, + file = fname} + :: files) + else + loop files + + val files = loop [] + val (_, files) = Order.order (SOME b) files + + val _ = if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + () + + val codes = map (fn fname => + let + val inf = TextIO.openIn fname + + fun loop lines = + case TextIO.inputLine inf of + NONE => String.concat (rev lines) + | SOME line => loop (line :: lines) + in + loop [] + before TextIO.closeIn inf + end) files + in + Msg.send (bio, MsgMultiConfig codes); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Configuration succeeded.\n" + | MsgError s => print ("Configuration failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + handle ErrorMsg.Error => () + fun requestGrant acl = let val (user, bio) = requestBio (fn () => ()) @@ -261,6 +344,42 @@ fun service () = val () = print ("\nConnection from " ^ user ^ "\n") val () = Domain.setUser user + fun doConfig codes = + let + val _ = print "Configuration:\n" + val _ = app (fn s => (print s; print "\n")) codes + val _ = print "\n" + + val outname = OS.FileSys.tmpName () + + fun doOne code = + let + val outf = TextIO.openOut outname + in + TextIO.output (outf, code); + TextIO.closeOut outf; + eval outname + end + in + (app doOne codes; + Msg.send (bio, MsgOk)) + handle ErrorMsg.Error => + (print "Compilation error\n"; + Msg.send (bio, + MsgError "Error during configuration evaluation")) + | OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during configuration evaluation: " + ^ s))); + OS.FileSys.remove outname; + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop () + end + fun cmdLoop () = case Msg.recv bio of NONE => (OpenSSL.close bio @@ -268,35 +387,8 @@ fun service () = loop ()) | SOME m => case m of - MsgConfig code => - let - val _ = print "Configuration:\n" - val _ = print code - val _ = print "\n" - - val outname = OS.FileSys.tmpName () - val outf = TextIO.openOut outname - in - TextIO.output (outf, code); - TextIO.closeOut outf; - (eval outname; - Msg.send (bio, MsgOk)) - handle ErrorMsg.Error => - (print "Compilation error\n"; - Msg.send (bio, - MsgError "Error during configuration evaluation")) - | OpenSSL.OpenSSL s => - (print "OpenSSL error\n"; - Msg.send (bio, - MsgError - ("Error during configuration evaluation: " - ^ s))); - OS.FileSys.remove outname; - (ignore (OpenSSL.readChar bio); - OpenSSL.close bio) - handle OpenSSL.OpenSSL _ => (); - loop () - end + MsgConfig code => doConfig [code] + | MsgMultiConfig codes => doConfig codes | MsgGrant acl => if Acl.query {user = user, class = "priv", value = "all"} then diff --git a/src/msg.sml b/src/msg.sml index faced87..2de4898 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -41,6 +41,26 @@ fun recvAcl bio = (SOME user, SOME class, SOME value) => SOME {user = user, class = class, value = value} | _ => NONE +fun sendList f (bio, ls) = + (app (fn x => + (OpenSSL.writeInt (bio, 1); + f (bio, x))) ls; + OpenSSL.writeInt (bio, 0)) + +fun recvList f bio = + let + fun loop ls = + case OpenSSL.readInt bio of + SOME 0 => SOME (rev ls) + | SOME 1 => + (case f bio of + SOME x => loop (x :: ls) + | NONE => NONE) + | _ => NONE + in + loop [] + end + fun send (bio, m) = case m of MsgOk => OpenSSL.writeInt (bio, 1) @@ -62,22 +82,17 @@ fun send (bio, m) = | MsgListPerms user => (OpenSSL.writeInt (bio, 8); OpenSSL.writeString (bio, user)) | MsgPerms classes => (OpenSSL.writeInt (bio, 9); - app (fn (class, values) => - (OpenSSL.writeInt (bio, 1); - OpenSSL.writeString (bio, class); - app (fn value => - (OpenSSL.writeInt (bio, 1); - OpenSSL.writeString (bio, value))) values; - OpenSSL.writeInt (bio, 0))) classes; - OpenSSL.writeInt (bio, 0)) + sendList (fn (bio, (class, values)) => + (OpenSSL.writeString (bio, class); + sendList OpenSSL.writeString (bio, values))) + (bio, classes)) | MsgWhoHas {class, value} => (OpenSSL.writeInt (bio, 10); OpenSSL.writeString (bio, class); OpenSSL.writeString (bio, value)) | MsgWhoHasResponse users => (OpenSSL.writeInt (bio, 11); - app (fn user => - (OpenSSL.writeInt (bio, 1); - OpenSSL.writeString (bio, user))) users; - OpenSSL.writeInt (bio, 0)) + sendList OpenSSL.writeString (bio, users)) + | MsgMultiConfig codes => (OpenSSL.writeInt (bio, 12); + sendList OpenSSL.writeString (bio, codes)) fun checkIt v = case v of @@ -112,45 +127,19 @@ fun recv bio = | 8 => (case OpenSSL.readString bio of SOME user => SOME (MsgListPerms user) | _ => NONE) - | 9 => let - fun loop classes = - case OpenSSL.readInt bio of - SOME 0 => SOME (MsgPerms (rev classes)) - | SOME 1 => - (case OpenSSL.readString bio of - SOME class => - let - fun loop' values = - case OpenSSL.readInt bio of - SOME 0 => loop ((class, rev values) :: classes) - | SOME 1 => - (case OpenSSL.readString bio of - SOME value => loop' (value :: values) - | NONE => NONE) - | _ => NONE - in - loop' [] - end - | NONE => NONE) - | _ => NONE - in - loop [] - end + | 9 => Option.map MsgPerms + (recvList (fn bio => + case (OpenSSL.readString bio, + recvList OpenSSL.readString bio) of + (SOME class, SOME values) => SOME (class, values) + | _ => NONE) bio) | 10 => (case (OpenSSL.readString bio, OpenSSL.readString bio) of (SOME class, SOME value) => SOME (MsgWhoHas {class = class, value = value}) | _ => NONE) - | 11 => let - fun loop users = - case OpenSSL.readInt bio of - SOME 0 => SOME (MsgWhoHasResponse (rev users)) - | SOME 1 => - (case OpenSSL.readString bio of - SOME user => loop (user :: users) - | NONE => NONE) - | _ => NONE - in - loop [] - end + | 11 => Option.map MsgWhoHasResponse + (recvList OpenSSL.readString bio) + | 12 => Option.map MsgMultiConfig + (recvList OpenSSL.readString bio) | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 97c9745..4e0d68d 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -44,6 +44,7 @@ datatype msg = (* Which users have this permission? *) | MsgWhoHasResponse of string list (* These are the users! *) - + | MsgMultiConfig of string list + (* Multiple Domtool sources in dependency order *) end diff --git a/src/order.sig b/src/order.sig index f33941a..a94d17a 100644 --- a/src/order.sig +++ b/src/order.sig @@ -27,6 +27,7 @@ signature ORDER = sig val providesValue : providers * string -> string option (* Look up which file defines a symbol *) - val order : string list -> providers * string list + val order : Env.env option -> string list -> providers * string list + (* The first argument gives an environment of known symbols *) end diff --git a/src/order.sml b/src/order.sml index 0d0d363..2923c19 100644 --- a/src/order.sml +++ b/src/order.sml @@ -174,7 +174,7 @@ fun mergeProvide kind fname (m1, m2) = SM.insert (provide, name, fname))) m1 m2 -fun order fnames = +fun order basisOpt fnames = let fun doFile (fname, (provideC, provideT, provideV, require)) = let @@ -193,25 +193,38 @@ fun order fnames = val require = SM.mapi (fn (fname, ((rc, rt), rv)) => let - fun consider (kind, provide) = + fun consider (kind, provide, lastChance) = SS.foldl (fn (name, need) => case SM.find (provide, name) of - NONE => (ErrorMsg.error NONE - ("File " - ^ fname - ^ " uses undefined " - ^ kind - ^ " " - ^ name); - need) + NONE => + if lastChance name then + need + else + (ErrorMsg.error NONE + ("File " + ^ fname + ^ " uses undefined " + ^ kind + ^ " " + ^ name); + need) | SOME fname' => SS.add (need, fname')) - val need = consider ("context", provideC) + val need = consider ("context", provideC, + case basisOpt of + NONE => (fn _ => false) + | SOME b => Env.lookupContext b) SS.empty rc - val need = consider ("type", provideT) + val need = consider ("type", provideT, + case basisOpt of + NONE => (fn _ => false) + | SOME b => Env.lookupType b) need rt - val need = consider ("value", provideV) + val need = consider ("value", provideV, + case basisOpt of + NONE => (fn _ => false) + | SOME b => (fn name => Option.isSome (Env.lookupVal b name))) need rv in need -- 2.20.1