From: Adam Chlipala Date: Sun, 30 Jul 2006 21:17:35 +0000 (+0000) Subject: Refactoring plugins X-Git-Tag: release_2010-11-19~377 X-Git-Url: https://git.hcoop.net/hcoop/domtool2.git/commitdiff_plain/d612d62cd04b713bb1057fd2e666365704aaf3d6?hp=d189ec0eee8569e5811335e7fc93a921e14c2b1f Refactoring plugins --- diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 79fab00..aed3b0b 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -1,2 +1,7 @@ val libRoot = "/home/adamc/cvs/domtool2/lib" val resultRoot = "/home/adamc/domtool" +val tmpDir = "/tmp" + +val cp = "/bin/cp" +val diff = "/usr/bin/diff" +val rm = "/bin/rm" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index f8a2aec..90be237 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -5,3 +5,10 @@ val resultRoot : string (* Root directory for a directory hierarchy corresponding to domain structure, * where each node contains Domtool-generated result files for that domain. *) +val tmpDir : string +(* Filesystem location for creating temporary directories *) + +(* Paths to standard UNIX utilities *) +val cp : string +val diff : string +val rm : string diff --git a/src/domain.sml b/src/domain.sml index 4ec6f55..394bf80 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -60,6 +60,8 @@ fun registerAfter f = val current = ref "" val currentPath = ref "" +val scratch = ref "" + fun currentDomain () = !current fun domainFile name = TextIO.openOut (!currentPath ^ name) @@ -72,6 +74,7 @@ fun getPath domain = 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 @@ -80,17 +83,138 @@ fun getPath domain = (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 diff --git a/src/domtool.cm b/src/domtool.cm index c3b66d7..bdc790b 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -41,11 +41,13 @@ eval.sml baseTypes.sig baseTypes.sml +slave.sig +slave.sml + domain.sig domain.sml -alias.sig -alias.sml +plugins/plugins.cm order.sig order.sml diff --git a/src/main.sml b/src/main.sml index 86da95f..415d9c2 100644 --- a/src/main.sml +++ b/src/main.sml @@ -48,10 +48,12 @@ fun basis () = fun loop files = case Posix.FileSys.readdir dir of - NONE => files + NONE => (Posix.FileSys.closedir dir; + files) | SOME fname => if String.isSuffix ".dtl" fname then - loop (String.concatWith "/" [Config.libRoot, fname] + loop (OS.Path.joinDirFile {dir = Config.libRoot, + file = fname} :: files) else loop files diff --git a/src/plugins/.cvsignore b/src/plugins/.cvsignore new file mode 100644 index 0000000..6dc8e1a --- /dev/null +++ b/src/plugins/.cvsignore @@ -0,0 +1 @@ +.cm diff --git a/src/alias.sig b/src/plugins/alias.sig similarity index 100% rename from src/alias.sig rename to src/plugins/alias.sig diff --git a/src/alias.sml b/src/plugins/alias.sml similarity index 100% rename from src/alias.sml rename to src/plugins/alias.sml diff --git a/src/plugins/plugins.cm b/src/plugins/plugins.cm new file mode 100644 index 0000000..2f3be08 --- /dev/null +++ b/src/plugins/plugins.cm @@ -0,0 +1,9 @@ +Library + +signature ALIAS +structure Alias + +is + +alias.sig +alias.sml diff --git a/src/slave.sig b/src/slave.sig new file mode 100644 index 0000000..24082d4 --- /dev/null +++ b/src/slave.sig @@ -0,0 +1,42 @@ +(* 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 diff --git a/src/slave.sml b/src/slave.sml new file mode 100644 index 0000000..b08d41d --- /dev/null +++ b/src/slave.sml @@ -0,0 +1,61 @@ +(* 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