val current = ref ""
val currentPath = ref ""
+val scratch = ref ""
+
fun currentDomain () = !current
fun domainFile name = TextIO.openOut (!currentPath ^ name)
let
val elems = piece :: elems
val path = String.concatWith "/" (Config.resultRoot :: rev elems)
+ val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems)
in
(if Posix.FileSys.ST.isDir
(Posix.FileSys.stat path) then
(OS.FileSys.remove path;
OS.FileSys.mkDir path))
handle OS.SysErr _ => OS.FileSys.mkDir path;
+
+ (if Posix.FileSys.ST.isDir
+ (Posix.FileSys.stat tmpPath) then
+ ()
+ else
+ (OS.FileSys.remove tmpPath;
+ OS.FileSys.mkDir tmpPath))
+ handle OS.SysErr _ => OS.FileSys.mkDir tmpPath;
+
elems
end) [] toks
in
- String.concatWith "/" (Config.resultRoot :: rev ("" :: elems))
+ fn root => String.concatWith "/" (root :: rev ("" :: elems))
+ end
+
+datatype file_action' =
+ Add' of {src : string, dst : string}
+ | Delete' of string
+ | Modify' of {src : string, dst : string}
+
+fun shell ss = OS.Process.isSuccess (OS.Process.system (String.concat ss))
+
+fun shellF (ss, msg) =
+ let
+ val s = String.concat ss
+ in
+ if OS.Process.isSuccess (OS.Process.system s) then
+ ()
+ else
+ ErrorMsg.error NONE (msg s)
+ end
+
+fun findDiffs dom =
+ let
+ val realPath = getPath dom Config.resultRoot
+ val tmpPath = !currentPath
+
+ val dir = Posix.FileSys.opendir realPath
+
+ fun loopReal acts =
+ case Posix.FileSys.readdir dir of
+ NONE => (Posix.FileSys.closedir dir;
+ acts)
+ | SOME fname =>
+ let
+ val real = OS.Path.joinDirFile {dir = realPath,
+ file = fname}
+ val tmp = OS.Path.joinDirFile {dir = tmpPath,
+ file = fname}
+ in
+ if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
+ loopReal acts
+ else if Posix.FileSys.access (tmp, []) then
+ if shell [Config.diff, " ", real, " ", tmp] then
+ loopReal acts
+ else
+ loopReal (Modify' {src = tmp, dst = real} :: acts)
+ else
+ loopReal (Delete' real :: acts)
+ end
+
+ val acts = loopReal []
+
+ val dir = Posix.FileSys.opendir realPath
+
+ fun loopTmp acts =
+ case Posix.FileSys.readdir dir of
+ NONE => (Posix.FileSys.closedir dir;
+ acts)
+ | SOME fname =>
+ let
+ val real = OS.Path.joinDirFile {dir = realPath,
+ file = fname}
+ val tmp = OS.Path.joinDirFile {dir = tmpPath,
+ file = fname}
+ in
+ if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
+ loopTmp acts
+ else if Posix.FileSys.access (real, []) then
+ loopTmp acts
+ else
+ loopTmp (Add' {src = tmp, dst = real} :: acts)
+ end
+
+ val acts = loopTmp acts
+ in
+ acts
end
val _ = Env.container_one "domain"
("domain", Env.string)
- (fn dom => (current := dom;
- currentPath := getPath dom;
- !befores dom),
- fn () => !afters (!current))
+ (fn dom =>
+ let
+ val path = getPath dom Config.tmpDir
+ in
+ current := dom;
+ currentPath := path;
+ !befores dom
+ end,
+ fn () =>
+ let
+ val dom = !current
+ val () = !afters dom
+
+ val diffs = findDiffs dom
+
+ val diffs = map (fn Add' {src, dst} =>
+ (shellF ([Config.cp, " ", src, " ", dst],
+ fn cl => "Copy failed: " ^ cl);
+ {action = Slave.Add,
+ domain = dom,
+ file = dst})
+ | Delete' dst =>
+ (OS.FileSys.remove dst
+ handle OS.SysErr _ =>
+ ErrorMsg.error NONE ("Delete failed for " ^ dst);
+ {action = Slave.Delete,
+ domain = dom,
+ file = dst})
+ | Modify' {src, dst} =>
+ (shellF ([Config.cp, " ", src, " ", dst],
+ fn cl => "Copy failed: " ^ cl);
+ {action = Slave.Modify,
+ domain = dom,
+ file = dst})) diffs
+ in
+ if !ErrorMsg.anyErrors then
+ ()
+ else
+ Slave.handleChanges diffs;
+ ignore (shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
+ fn cl => "Temp file cleanup failed: " ^ cl))
+ end)
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.
+ *)
+
+(* Code for receiving and executing configuration files *)
+
+signature SLAVE = sig
+
+ datatype file_action =
+ Add
+ | Delete
+ | Modify
+
+ type file_status = {action : file_action,
+ domain : string,
+ file : string}
+
+ val registerFileHandler : (file_status -> unit) -> unit
+ (* Register a function to be called when a result configuration file's
+ * status has changed. Registered handlers are called in the reverse order
+ * from registration order. *)
+
+ val registerPreHandler : (unit -> unit) -> unit
+ val registerPostHandler : (unit -> unit) -> unit
+ (* Register code to run before or after making all changes. *)
+
+ val handleChanges : file_status list -> unit
+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.
+ *)
+
+(* Code for receiving and executing configuration files *)
+
+structure Slave :> SLAVE = struct
+
+datatype file_action =
+ Add
+ | Delete
+ | Modify
+
+type file_status = {action : file_action,
+ domain : string,
+ file : string}
+
+val fileHandler = ref (fn _ : file_status => ())
+val preHandler = ref (fn () => ())
+val postHandler = ref (fn () => ())
+
+fun registerFileHandler handler =
+ let
+ val old = !fileHandler
+ in
+ fileHandler := (fn x => (handler x; old x))
+ end
+
+fun registerPreHandler handler =
+ let
+ val old = !preHandler
+ in
+ preHandler := (fn () => (handler (); old ()))
+ end
+
+fun registerPostHandler handler =
+ let
+ val old = !postHandler
+ in
+ postHandler := (fn () => (handler (); old ()))
+ end
+
+fun handleChanges fs = (!preHandler ();
+ app (!fileHandler) fs;
+ !postHandler ())
+
+end
HCoop / hcoop / domtool2.git / commitdiff