From 1824f573f7f8720514af1dc94d7cfb1de5b15fef Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 15 Dec 2006 23:59:30 +0000 Subject: [PATCH] Preliminary regeneration support --- configDefault/domtool.cfg | 5 ++ configDefault/domtool.cfs | 2 + src/acl.sig | 3 + src/acl.sml | 2 + src/eval.sig | 1 + src/eval.sml | 94 ++++++++++++++-------------- src/main-admin.sml | 1 + src/main.sig | 3 +- src/main.sml | 128 +++++++++++++++++++++++++++++++++----- src/msg.sml | 2 + src/msgTypes.sml | 2 + 11 files changed, 181 insertions(+), 62 deletions(-) diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 6d1c7e1..e1d427a 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -51,3 +51,8 @@ val serialDir = "/afs/hcoop.net/common/etc/domtool/serials" val dispatcherName = "deleuze.hcoop.net" val homeBase = "/afs/hcoop.net/usr" + +fun domtoolDir user = + case user of + "domtool" => "/afs/hcoop.net/common/etc/domtool/domtool" + | _ => "/afs/hcoop.net/usr/" ^ user ^ "/domtool" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index b27b48a..61375b1 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -60,3 +60,5 @@ val dnsNodes_admin : string list val mailNodes_all : string list val mailNodes_admin : string list + +val domtoolDir : string -> string diff --git a/src/acl.sig b/src/acl.sig index 2ac1f19..10abcde 100644 --- a/src/acl.sig +++ b/src/acl.sig @@ -30,6 +30,9 @@ signature ACL = sig val queryAll : string -> (string * string list) list (* What are all of a user's permissions, by class? *) + val users : unit -> string list + (* Which users have been granted privileges? *) + val whoHas : {class : string, value : string} -> string list (* Which users have a permission? *) diff --git a/src/acl.sml b/src/acl.sml index 6634f91..be30fdf 100644 --- a/src/acl.sml +++ b/src/acl.sml @@ -44,6 +44,8 @@ fun queryAll user = (class, SS.foldr (op::) [] values) :: out) [] classes +fun users () = SM.foldri (fn (user, _, ls) => user :: ls) [] (!acl) + fun whoHas {class, value} = SM.foldri (fn (user, classes, users) => case SM.find (classes, class) of diff --git a/src/eval.sig b/src/eval.sig index e9cd6aa..3d05210 100644 --- a/src/eval.sig +++ b/src/eval.sig @@ -21,5 +21,6 @@ signature EVAL = sig val exec : Env.env_vars -> Ast.exp -> unit + val exec' : Env.env_vars -> Ast.exp -> Env.env_vars end diff --git a/src/eval.sml b/src/eval.sml index 7aa8053..6cbeca7 100644 --- a/src/eval.sml +++ b/src/eval.sml @@ -56,58 +56,58 @@ fun findPrimitive e = (name, rev args) end -fun exec evs e = - let - fun exec' evs (eAll as (e, _)) = - 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) - | ESeq es => - let - val (new, _) = - foldl (fn (e, (new, keep)) => - let - val new' = exec' keep e - in - (conjoin (new, new'), - conjoin (keep, new')) - end) (SM.empty, evs) es - in - new - end - | ELocal (e1, e2) => - let - val evs' = exec' evs e1 - val evs'' = exec' (conjoin (evs, evs')) e2 - in - conjoin (evs, evs'') - end - | EWith (e1, e2) => +fun exec' evs (eAll as (e, _)) = + 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) + | ESeq es => + let + val (new, _) = + foldl (fn (e, (new, keep)) => + let + val new' = exec' keep e + in + (conjoin (new, new'), + conjoin (keep, new')) + end) (SM.empty, evs) es + in + new + end + | ELocal (e1, e2) => + let + val evs' = exec' evs e1 + val evs'' = exec' (conjoin (evs, evs')) e2 + in + conjoin (evs, evs'') + end + | EWith (e1, e2) => + let + val (prim, args) = findPrimitive e1 + in + case Env.container prim of + NONE => raise Fail "Unbound primitive container" + | SOME (action, cleanup) => let - val (prim, args) = findPrimitive e1 + val evs' = action (evs, args) + val evs'' = exec' evs e2 in - case Env.container prim of - NONE => raise Fail "Unbound primitive container" - | SOME (action, cleanup) => - let - val evs' = action (evs, args) - val evs'' = exec' evs e2 - in - cleanup (); - evs' - end + cleanup (); + evs' end + end - | _ => - let - val (prim, args) = findPrimitive eAll - in - case Env.action prim of - NONE => raise Fail "Unbound primitive action" - | SOME action => action (evs, args) - end + | _ => + let + val (prim, args) = findPrimitive eAll + in + case Env.action prim of + NONE => raise Fail "Unbound primitive action" + | SOME action => action (evs, args) + end +fun exec evs e = + let val _ = Env.pre () val evs' = exec' evs e in diff --git a/src/main-admin.sml b/src/main-admin.sml index e0081b4..2931ae6 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -42,4 +42,5 @@ val _ = app (fn user => print (" " ^ user)) users; print "\n")) | ["rmdom", dom] => Main.requestRmdom dom + | ["regen"] => Main.requestRegen () | _ => print "Invalid command-line arguments\n" diff --git a/src/main.sig b/src/main.sig index 941b704..c086bd5 100644 --- a/src/main.sig +++ b/src/main.sig @@ -24,7 +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 checkDir : string -> unit val basis : unit -> Env.env @@ -39,6 +39,7 @@ signature MAIN = sig val requestListPerms : string -> (string * string list) list option val requestWhoHas : {class : string, value : string} -> string list option val requestRmdom : string -> unit + val requestRegen : unit -> unit val service : unit -> unit val slave : unit -> unit diff --git a/src/main.sml b/src/main.sml index 0f65362..715b486 100644 --- a/src/main.sml +++ b/src/main.sml @@ -116,10 +116,13 @@ fun checkDir dname = val (_, files) = Order.order (SOME b) files in if !ErrorMsg.anyErrors then - false + raise ErrorMsg.Error else (foldl (fn (fname, G) => check' G fname) b files; - !ErrorMsg.anyErrors) + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + ()) end fun reduce fname = @@ -152,6 +155,15 @@ fun eval fname = Eval.exec (Defaults.eInit ()) body' | NONE => raise ErrorMsg.Error +fun eval' fname = + case reduce fname of + (SOME body') => + if !ErrorMsg.anyErrors then + raise ErrorMsg.Error + else + ignore (Eval.exec' (Defaults.eInit ()) body') + | NONE => raise ErrorMsg.Error + val dispatcher = Config.dispatcher ^ ":" ^ Int.toString Config.dispatcherPort @@ -207,7 +219,9 @@ fun request fname = fun requestDir dname = let - val (user, bio) = requestBio (fn () => ignore (checkDir dname)) + val _ = ErrorMsg.reset () + + val (user, bio) = requestBio (fn () => checkDir dname) val b = basis () @@ -246,15 +260,18 @@ fun requestDir dname = 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 + if !ErrorMsg.anyErrors then + () + else + (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 => () @@ -324,6 +341,21 @@ fun requestWhoHas perm = before OpenSSL.close bio end +fun requestRegen () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRegenerate); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "Regeneration succeeded.\n" + | MsgError s => print ("Regeneration failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestRmdom dom = let val (_, bio) = requestBio (fn () => ()) @@ -339,6 +371,48 @@ fun requestRmdom dom = OpenSSL.close bio end +fun regenerate () = + let + val b = basis () + val _ = Tycheck.disallowExterns () + + fun doUser user = + let + val _ = Domain.setUser user + val _ = ErrorMsg.reset () + + val dname = Config.domtoolDir user + + 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 + print ("User " ^ user ^ "'s configuration has errors!\n") + else + app eval' files + end + handle IO.Io _ => () + | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + in + Env.pre (); + app doUser (Acl.users ()); + Env.post () + end + fun service () = let val () = Acl.read Config.aclFile @@ -373,10 +447,12 @@ fun service () = in TextIO.output (outf, code); TextIO.closeOut outf; - eval outname + eval' outname end in - (app doOne codes; + (Env.pre (); + app doOne codes; + Env.post (); Msg.send (bio, MsgOk)) handle ErrorMsg.Error => (print "Compilation error\n"; @@ -503,6 +579,30 @@ fun service () = ignore (OpenSSL.readChar bio); OpenSSL.close bio) handle OpenSSL.OpenSSL _ => (); + loop ()) + + | MsgRegenerate => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + ((regenerate (); + Msg.send (bio, MsgOk); + print "Regenerated all configuration.\n") + handle OpenSSL.OpenSSL s => + (print "OpenSSL error\n"; + Msg.send (bio, + MsgError + ("Error during regeneration: " + ^ s))); + (ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); + loop ()) + else + ((Msg.send (bio, MsgError "Not authorized to regeneration"); + print "Unauthorized user asked to regenerate!\n"; + ignore (OpenSSL.readChar bio); + OpenSSL.close bio) + handle OpenSSL.OpenSSL _ => (); loop ()) | _ => diff --git a/src/msg.sml b/src/msg.sml index aa5cf35..bb6a2b1 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -95,6 +95,7 @@ fun send (bio, m) = sendList OpenSSL.writeString (bio, codes)) | MsgRmdom dom => (OpenSSL.writeInt (bio, 13); OpenSSL.writeString (bio, dom)) + | MsgRegenerate => OpenSSL.writeInt (bio, 14) fun checkIt v = case v of @@ -143,6 +144,7 @@ fun recv bio = | 12 => Option.map MsgMultiConfig (recvList OpenSSL.readString bio) | 13 => Option.map MsgRmdom (OpenSSL.readString bio) + | 14 => SOME MsgRegenerate | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index bf74086..89ab255 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -49,5 +49,7 @@ datatype msg = | MsgRmdom of string (* Remove all configuration associated with a domain and revoke rights * to that domain from all users. *) + | MsgRegenerate + (* Make a clean slate of it and reprocess all configuration from scratch. *) end -- 2.20.1