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