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 | ||
d612d62c AC |
106 | fun findDiffs dom = |
107 | let | |
108 | val realPath = getPath dom Config.resultRoot | |
109 | val tmpPath = !currentPath | |
110 | ||
111 | val dir = Posix.FileSys.opendir realPath | |
112 | ||
113 | fun loopReal acts = | |
114 | case Posix.FileSys.readdir dir of | |
115 | NONE => (Posix.FileSys.closedir dir; | |
116 | acts) | |
117 | | SOME fname => | |
118 | let | |
119 | val real = OS.Path.joinDirFile {dir = realPath, | |
120 | file = fname} | |
121 | val tmp = OS.Path.joinDirFile {dir = tmpPath, | |
122 | file = fname} | |
123 | in | |
124 | if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then | |
125 | loopReal acts | |
126 | else if Posix.FileSys.access (tmp, []) then | |
8df2e702 | 127 | if Slave.shell [Config.diff, " ", real, " ", tmp] then |
d612d62c AC |
128 | loopReal acts |
129 | else | |
130 | loopReal (Modify' {src = tmp, dst = real} :: acts) | |
131 | else | |
132 | loopReal (Delete' real :: acts) | |
133 | end | |
134 | ||
135 | val acts = loopReal [] | |
136 | ||
8df2e702 | 137 | val dir = Posix.FileSys.opendir tmpPath |
d612d62c AC |
138 | |
139 | fun loopTmp acts = | |
140 | case Posix.FileSys.readdir dir of | |
141 | NONE => (Posix.FileSys.closedir dir; | |
142 | acts) | |
143 | | SOME fname => | |
144 | let | |
145 | val real = OS.Path.joinDirFile {dir = realPath, | |
146 | file = fname} | |
147 | val tmp = OS.Path.joinDirFile {dir = tmpPath, | |
148 | file = fname} | |
149 | in | |
150 | if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then | |
151 | loopTmp acts | |
152 | else if Posix.FileSys.access (real, []) then | |
153 | loopTmp acts | |
154 | else | |
155 | loopTmp (Add' {src = tmp, dst = real} :: acts) | |
156 | end | |
157 | ||
158 | val acts = loopTmp acts | |
159 | in | |
160 | acts | |
dac62e84 | 161 | end |
a3698041 | 162 | |
629a34f6 AC |
163 | val _ = Env.container_one "domain" |
164 | ("domain", Env.string) | |
d612d62c AC |
165 | (fn dom => |
166 | let | |
167 | val path = getPath dom Config.tmpDir | |
168 | in | |
169 | current := dom; | |
170 | currentPath := path; | |
171 | !befores dom | |
172 | end, | |
173 | fn () => | |
174 | let | |
175 | val dom = !current | |
176 | val () = !afters dom | |
177 | ||
178 | val diffs = findDiffs dom | |
179 | ||
180 | val diffs = map (fn Add' {src, dst} => | |
8df2e702 | 181 | (Slave.shellF ([Config.cp, " ", src, " ", dst], |
d612d62c AC |
182 | fn cl => "Copy failed: " ^ cl); |
183 | {action = Slave.Add, | |
184 | domain = dom, | |
185 | file = dst}) | |
186 | | Delete' dst => | |
187 | (OS.FileSys.remove dst | |
188 | handle OS.SysErr _ => | |
189 | ErrorMsg.error NONE ("Delete failed for " ^ dst); | |
190 | {action = Slave.Delete, | |
191 | domain = dom, | |
192 | file = dst}) | |
193 | | Modify' {src, dst} => | |
8df2e702 | 194 | (Slave.shellF ([Config.cp, " ", src, " ", dst], |
d612d62c AC |
195 | fn cl => "Copy failed: " ^ cl); |
196 | {action = Slave.Modify, | |
197 | domain = dom, | |
198 | file = dst})) diffs | |
199 | in | |
200 | if !ErrorMsg.anyErrors then | |
201 | () | |
202 | else | |
203 | Slave.handleChanges diffs; | |
8df2e702 | 204 | ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"], |
d612d62c AC |
205 | fn cl => "Temp file cleanup failed: " ^ cl)) |
206 | end) | |
a3698041 AC |
207 | |
208 | end |