Commit | Line | Data |
---|---|---|
a3698041 AC |
1 | (* HCoop Domtool (http://hcoop.sourceforge.net/) |
2 | * Copyright (c) 2006, Adam Chlipala | |
3 | * | |
4 | * This program is free software; you can redistribute it and/or | |
5 | * modify it under the terms of the GNU General Public License | |
6 | * as published by the Free Software Foundation; either version 2 | |
7 | * of the License, or (at your option) any later version. | |
8 | * | |
9 | * This program is distributed in the hope that it will be useful, | |
10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | * GNU General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU General Public License | |
15 | * along with this program; if not, write to the Free Software | |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. | |
dac62e84 | 17 | *) |
a3698041 AC |
18 | |
19 | (* Domain-related primitive actions *) | |
20 | ||
21 | structure Domain :> DOMAIN = struct | |
22 | ||
629a34f6 AC |
23 | fun isIdent ch = Char.isLower ch orelse Char.isDigit ch |
24 | ||
25 | fun validHost s = | |
26 | size s > 0 andalso size s < 20 | |
27 | andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s | |
28 | ||
29 | fun validDomain s = | |
30 | size s > 0 andalso size s < 100 | |
31 | andalso List.all validHost (String.fields (fn ch => ch = #".") s) | |
32 | ||
33 | val _ = Env.type_one "host" | |
34 | Env.string | |
35 | validHost | |
36 | ||
37 | val _ = Env.type_one "domain" | |
38 | Env.string | |
39 | validDomain | |
40 | ||
a3698041 AC |
41 | open Ast |
42 | ||
43 | val befores = ref (fn (_ : string) => ()) | |
44 | val afters = ref (fn (_ : string) => ()) | |
45 | ||
46 | fun registerBefore f = | |
47 | let | |
48 | val old = !befores | |
49 | in | |
50 | befores := (fn x => (old x; f x)) | |
51 | end | |
52 | ||
53 | fun registerAfter f = | |
54 | let | |
55 | val old = !afters | |
56 | in | |
57 | afters := (fn x => (old x; f x)) | |
58 | end | |
59 | ||
60 | val current = ref "" | |
dac62e84 AC |
61 | val currentPath = ref "" |
62 | ||
d612d62c AC |
63 | val scratch = ref "" |
64 | ||
dac62e84 AC |
65 | fun currentDomain () = !current |
66 | ||
67 | fun domainFile name = TextIO.openOut (!currentPath ^ name) | |
68 | ||
69 | fun getPath domain = | |
70 | let | |
71 | val toks = String.fields (fn ch => ch = #".") domain | |
72 | ||
73 | val elems = foldr (fn (piece, elems) => | |
74 | let | |
75 | val elems = piece :: elems | |
095de39e | 76 | val path = String.concatWith "/" (Config.resultRoot :: rev elems) |
d612d62c | 77 | val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems) |
dac62e84 AC |
78 | in |
79 | (if Posix.FileSys.ST.isDir | |
80 | (Posix.FileSys.stat path) then | |
81 | () | |
82 | else | |
83 | (OS.FileSys.remove path; | |
84 | OS.FileSys.mkDir path)) | |
85 | handle OS.SysErr _ => OS.FileSys.mkDir path; | |
d612d62c AC |
86 | |
87 | (if Posix.FileSys.ST.isDir | |
88 | (Posix.FileSys.stat tmpPath) then | |
89 | () | |
90 | else | |
91 | (OS.FileSys.remove tmpPath; | |
92 | OS.FileSys.mkDir tmpPath)) | |
93 | handle OS.SysErr _ => OS.FileSys.mkDir tmpPath; | |
94 | ||
dac62e84 AC |
95 | elems |
96 | end) [] toks | |
97 | in | |
d612d62c AC |
98 | fn root => String.concatWith "/" (root :: rev ("" :: elems)) |
99 | end | |
100 | ||
101 | datatype file_action' = | |
102 | Add' of {src : string, dst : string} | |
103 | | Delete' of string | |
104 | | Modify' of {src : string, dst : string} | |
105 | ||
106 | fun shell ss = OS.Process.isSuccess (OS.Process.system (String.concat ss)) | |
107 | ||
108 | fun shellF (ss, msg) = | |
109 | let | |
110 | val s = String.concat ss | |
111 | in | |
112 | if OS.Process.isSuccess (OS.Process.system s) then | |
113 | () | |
114 | else | |
115 | ErrorMsg.error NONE (msg s) | |
116 | end | |
117 | ||
118 | fun findDiffs dom = | |
119 | let | |
120 | val realPath = getPath dom Config.resultRoot | |
121 | val tmpPath = !currentPath | |
122 | ||
123 | val dir = Posix.FileSys.opendir realPath | |
124 | ||
125 | fun loopReal acts = | |
126 | case Posix.FileSys.readdir dir of | |
127 | NONE => (Posix.FileSys.closedir dir; | |
128 | acts) | |
129 | | SOME fname => | |
130 | let | |
131 | val real = OS.Path.joinDirFile {dir = realPath, | |
132 | file = fname} | |
133 | val tmp = OS.Path.joinDirFile {dir = tmpPath, | |
134 | file = fname} | |
135 | in | |
136 | if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then | |
137 | loopReal acts | |
138 | else if Posix.FileSys.access (tmp, []) then | |
139 | if shell [Config.diff, " ", real, " ", tmp] then | |
140 | loopReal acts | |
141 | else | |
142 | loopReal (Modify' {src = tmp, dst = real} :: acts) | |
143 | else | |
144 | loopReal (Delete' real :: acts) | |
145 | end | |
146 | ||
147 | val acts = loopReal [] | |
148 | ||
149 | val dir = Posix.FileSys.opendir realPath | |
150 | ||
151 | fun loopTmp acts = | |
152 | case Posix.FileSys.readdir dir of | |
153 | NONE => (Posix.FileSys.closedir dir; | |
154 | acts) | |
155 | | SOME fname => | |
156 | let | |
157 | val real = OS.Path.joinDirFile {dir = realPath, | |
158 | file = fname} | |
159 | val tmp = OS.Path.joinDirFile {dir = tmpPath, | |
160 | file = fname} | |
161 | in | |
162 | if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then | |
163 | loopTmp acts | |
164 | else if Posix.FileSys.access (real, []) then | |
165 | loopTmp acts | |
166 | else | |
167 | loopTmp (Add' {src = tmp, dst = real} :: acts) | |
168 | end | |
169 | ||
170 | val acts = loopTmp acts | |
171 | in | |
172 | acts | |
dac62e84 | 173 | end |
a3698041 | 174 | |
629a34f6 AC |
175 | val _ = Env.container_one "domain" |
176 | ("domain", Env.string) | |
d612d62c AC |
177 | (fn dom => |
178 | let | |
179 | val path = getPath dom Config.tmpDir | |
180 | in | |
181 | current := dom; | |
182 | currentPath := path; | |
183 | !befores dom | |
184 | end, | |
185 | fn () => | |
186 | let | |
187 | val dom = !current | |
188 | val () = !afters dom | |
189 | ||
190 | val diffs = findDiffs dom | |
191 | ||
192 | val diffs = map (fn Add' {src, dst} => | |
193 | (shellF ([Config.cp, " ", src, " ", dst], | |
194 | fn cl => "Copy failed: " ^ cl); | |
195 | {action = Slave.Add, | |
196 | domain = dom, | |
197 | file = dst}) | |
198 | | Delete' dst => | |
199 | (OS.FileSys.remove dst | |
200 | handle OS.SysErr _ => | |
201 | ErrorMsg.error NONE ("Delete failed for " ^ dst); | |
202 | {action = Slave.Delete, | |
203 | domain = dom, | |
204 | file = dst}) | |
205 | | Modify' {src, dst} => | |
206 | (shellF ([Config.cp, " ", src, " ", dst], | |
207 | fn cl => "Copy failed: " ^ cl); | |
208 | {action = Slave.Modify, | |
209 | domain = dom, | |
210 | file = dst})) diffs | |
211 | in | |
212 | if !ErrorMsg.anyErrors then | |
213 | () | |
214 | else | |
215 | Slave.handleChanges diffs; | |
216 | ignore (shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"], | |
217 | fn cl => "Temp file cleanup failed: " ^ cl)) | |
218 | end) | |
a3698041 AC |
219 | |
220 | end |