From fb6fac97106809e2b90f16e9f1d6176c329a5d40 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 21 Jun 2007 17:40:32 +0000 Subject: [PATCH] domtool-admin regen -tc --- src/main-admin.sml | 1 + src/main.sig | 1 + src/main.sml | 159 ++++++++++++++++++++++++++++++++++++--------- src/msg.sml | 2 + src/msgTypes.sml | 2 + 5 files changed, 136 insertions(+), 29 deletions(-) diff --git a/src/main-admin.sml b/src/main-admin.sml index 967f1e1..3e23264 100644 --- a/src/main-admin.sml +++ b/src/main-admin.sml @@ -44,6 +44,7 @@ val _ = print "\n")) | "rmdom" :: doms => Main.requestRmdom doms | ["regen"] => Main.requestRegen () + | ["regen", "-tc"] => Main.requestRegenTc () | ["rmuser", user] => Main.requestRmuser user | ["ping"] => OS.Process.exit (Main.requestPing ()) | ["slave-shutdown"] => Main.requestSlaveShutdown () diff --git a/src/main.sig b/src/main.sig index 78bb42f..cddbeba 100644 --- a/src/main.sig +++ b/src/main.sig @@ -43,6 +43,7 @@ signature MAIN = sig val requestWhoHas : {class : string, value : string} -> string list option val requestRmdom : string list -> unit val requestRegen : unit -> unit + val requestRegenTc : unit -> unit val requestRmuser : string -> unit val requestSlavePing : unit -> OS.Process.status diff --git a/src/main.sml b/src/main.sml index 87f2869..164297f 100644 --- a/src/main.sml +++ b/src/main.sml @@ -442,6 +442,21 @@ fun requestRegen () = OpenSSL.close bio end +fun requestRegenTc () = + let + val (_, bio) = requestBio (fn () => ()) + in + Msg.send (bio, MsgRegenerateTc); + case Msg.recv bio of + NONE => print "Server closed connection unexpectedly.\n" + | SOME m => + case m of + MsgOk => print "All configuration validated.\n" + | MsgError s => print ("Configuration validation failed: " ^ s ^ "\n") + | _ => print "Unexpected server reply.\n"; + OpenSSL.close bio + end + fun requestRmdom dom = let val (_, bio) = requestBio (fn () => ()) @@ -815,6 +830,8 @@ fun regenerate context = val () = Domain.resetGlobal () + val ok = ref true + fun contactNode (node, ip) = if node = Config.defaultNode then Domain.resetLocal () @@ -845,40 +862,106 @@ fun regenerate context = val _ = ErrorMsg.reset () val dname = Config.domtoolDir user + in + if Posix.FileSys.access (dname, []) then + let + 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 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) + val files = loop [] + val (_, files) = Order.order (SOME b) files + in + if !ErrorMsg.anyErrors then + (ErrorMsg.reset (); + print ("User " ^ user ^ "'s configuration has errors!\n")) else - loop files - - val files = loop [] - val (_, files) = Order.order (SOME b) files - in - if !ErrorMsg.anyErrors then - (ErrorMsg.reset (); - print ("User " ^ user ^ "'s configuration has errors!\n")) + app eval' files + end else - app eval' files + () end - handle IO.Io _ => () - | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") - | ErrorMsg.Error => (ErrorMsg.reset (); - print ("User " ^ user ^ " had a compilation error.\n")) - | _ => print "Unknown exception during regeneration!\n" + handle IO.Io _ => () + | OS.SysErr (s, _) => (print ("System error processing user " ^ user ^ ": " ^ s ^ "\n"); + ok := false) + | ErrorMsg.Error => (ErrorMsg.reset (); + print ("User " ^ user ^ " had a compilation error.\n"); + ok := false) + | _ => (print "Unknown exception during regeneration!\n"; + ok := false) in app contactNode Config.nodeIps; Env.pre (); app doUser (Acl.users ()); - Env.post () + Env.post (); + !ok + end + +fun regenerateTc context = + let + val _ = ErrorMsg.reset () + + val b = basis () + val () = Tycheck.disallowExterns () + + val () = Domain.resetGlobal () + + val ok = ref true + + fun doUser user = + let + val _ = Domain.setUser user + val _ = ErrorMsg.reset () + + val dname = Config.domtoolDir user + in + if Posix.FileSys.access (dname, []) then + let + 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 + (ErrorMsg.reset (); + print ("User " ^ user ^ "'s configuration has errors!\n"); + ok := false) + else + app (ignore o check) files + end + else + () + end + handle IO.Io _ => () + | OS.SysErr (s, _) => print ("System error processing user " ^ user ^ ": " ^ s ^ "\n") + | ErrorMsg.Error => (ErrorMsg.reset (); + print ("User " ^ user ^ " had a compilation error.\n")) + | _ => print "Unknown exception during -tc regeneration!\n" + in + app doUser (Acl.users ()); + !ok end fun rmuser user = @@ -1086,14 +1169,32 @@ fun service () = doIt (fn () => if Acl.query {user = user, class = "priv", value = "regen"} orelse Acl.query {user = user, class = "priv", value = "all"} then - (regenerate context; - ("Regenerated all configuration.", - NONE)) + (if regenerate context then + ("Regenerated all configuration.", + NONE) + else + ("Error regenerating configuration!", + SOME "Error regenerating configuration! Consult /var/log/domtool.log.")) else ("Unauthorized user asked to regenerate!", SOME "Not authorized to regenerate")) (fn () => ()) + | MsgRegenerateTc => + doIt (fn () => + if Acl.query {user = user, class = "priv", value = "regen"} + orelse Acl.query {user = user, class = "priv", value = "all"} then + (if regenerateTc context then + ("Checked all configuration.", + NONE) + else + ("Found a compilation error!", + SOME "Found a compilation error! Consult /var/log/domtool.log.")) + else + ("Unauthorized user asked to regenerate -tc!", + SOME "Not authorized to regenerate -tc")) + (fn () => ()) + | MsgRmuser user' => doIt (fn () => if Acl.query {user = user, class = "priv", value = "all"} then diff --git a/src/msg.sml b/src/msg.sml index 5b1125b..19a84b4 100644 --- a/src/msg.sml +++ b/src/msg.sml @@ -221,6 +221,7 @@ fun send (bio, m) = sendSockPerm (bio, p)) | MsgFirewall ls => (OpenSSL.writeInt (bio, 34); sendList OpenSSL.writeString (bio, ls)) + | MsgRegenerateTc => OpenSSL.writeInt (bio, 35) fun checkIt v = case v of @@ -321,6 +322,7 @@ fun recv bio = | 32 => Option.map MsgQuery (recvQuery bio) | 33 => Option.map MsgSocket (recvSockPerm bio) | 34 => Option.map MsgFirewall (recvList OpenSSL.readString bio) + | 35 => SOME MsgRegenerateTc | _ => NONE) end diff --git a/src/msgTypes.sml b/src/msgTypes.sml index 4827c62..00dc82a 100644 --- a/src/msgTypes.sml +++ b/src/msgTypes.sml @@ -112,5 +112,7 @@ datatype msg = (* Answer to a QSocket query *) | MsgFirewall of string list (* Answer to a QFirewall query *) + | MsgRegenerateTc + (* MsgRegenerate without actual publishing of configuration *) end -- 2.20.1