a11c0ff3 |
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. |
ae3a5b8c |
17 | *) |
a11c0ff3 |
18 | |
19 | (* Domain-related primitive actions *) |
20 | |
21 | structure Domain :> DOMAIN = struct |
22 | |
2f68506c |
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 | |
a11c0ff3 |
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 "" |
ae3a5b8c |
61 | val currentPath = ref "" |
62 | |
c12828f2 |
63 | val scratch = ref "" |
64 | |
ae3a5b8c |
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 |
51c32b45 |
76 | val path = String.concatWith "/" (Config.resultRoot :: rev elems) |
c12828f2 |
77 | val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems) |
ae3a5b8c |
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; |
c12828f2 |
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 | |
ae3a5b8c |
95 | elems |
96 | end) [] toks |
97 | in |
c12828f2 |
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 | |
c12828f2 |
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 |
1f53f82b |
127 | if Slave.shell [Config.diff, " ", real, " ", tmp] then |
c12828f2 |
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 | |
1f53f82b |
137 | val dir = Posix.FileSys.opendir tmpPath |
c12828f2 |
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 |
ae3a5b8c |
161 | end |
a11c0ff3 |
162 | |
2f68506c |
163 | val _ = Env.container_one "domain" |
164 | ("domain", Env.string) |
c12828f2 |
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} => |
1f53f82b |
181 | (Slave.shellF ([Config.cp, " ", src, " ", dst], |
c12828f2 |
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} => |
1f53f82b |
194 | (Slave.shellF ([Config.cp, " ", src, " ", dst], |
c12828f2 |
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; |
1f53f82b |
204 | ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"], |
c12828f2 |
205 | fn cl => "Temp file cleanup failed: " ^ cl)) |
206 | end) |
a11c0ff3 |
207 | |
208 | end |