1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006, Adam Chlipala
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
.
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
.
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
.
19 (* Domain
-related primitive actions
*)
21 structure Domain
:> DOMAIN
= struct
24 case map
Int.fromString (String.fields (fn ch
=> ch
= #
".") s
) of
25 [SOME n1
, SOME n2
, SOME n3
, SOME n4
] =>
26 n1
>= 0 andalso n1
< 256 andalso n2
>= 0 andalso n2
< 256 andalso n3
>= 0 andalso n3
< 256 andalso n4
>= 0 andalso n4
< 256
29 fun isIdent ch
= Char.isLower ch
orelse Char.isDigit ch
32 size s
> 0 andalso size s
< 20
33 andalso CharVector
.all (fn ch
=> isIdent ch
orelse ch
= #
"-") s
36 size s
> 0 andalso size s
< 100
37 andalso List.all
validHost (String.fields (fn ch
=> ch
= #
".") s
)
39 val _
= Env
.type_one
"ip"
43 val _
= Env
.type_one
"host"
47 val _
= Env
.type_one
"domain"
53 val dl
= ErrorMsg
.dummyLoc
55 val nsD
= (EString Config
.defaultNs
, dl
)
56 val serialD
= (EVar
"serialAuto", dl
)
57 val refD
= (EInt Config
.defaultRefresh
, dl
)
58 val retD
= (EInt Config
.defaultRetry
, dl
)
59 val expD
= (EInt Config
.defaultExpiry
, dl
)
60 val minD
= (EInt Config
.defaultMinimum
, dl
)
62 val soaD
= multiApp ((EVar
"soa", dl
),
64 [nsD
, serialD
, refD
, retD
, expD
, minD
])
66 val _
= Main
.registerDefault ("DNS",
67 (TBase
"dnsKind", dl
),
68 (EApp ((EVar
"master", dl
),
71 val _
= Main
.registerDefault ("TTL",
73 (EInt Config
.Bind
.defaultTTL
, dl
))
75 type soa
= {ns
: string,
82 val serial
= fn (EVar
"serialAuto", _
) => SOME NONE
83 |
(EApp ((EVar
"serialConst", _
), n
), _
) => Option
.map
SOME (Env
.int n
)
86 val soa
= fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
87 ((EVar
"soa", _
), ns
), _
),
93 (case (Env
.string ns
, serial sl
, Env
.int rf
,
94 Env
.int ret
, Env
.int exp
, Env
.int min
) of
95 (SOME ns
, SOME sl
, SOME rf
,
96 SOME ret
, SOME exp
, SOME min
) =>
111 val dnsKind
= fn (EApp ((EVar
"master", _
), e
), _
) => Option
.map
Master (soa e
)
112 |
(EApp ((EVar
"slave", _
), e
), _
) => Option
.map
Slave (soa e
)
113 |
(EVar
"noDns", _
) => SOME NoDns
116 val befores
= ref (fn (_
: string) => ())
117 val afters
= ref (fn (_
: string) => ())
119 fun registerBefore f
=
123 befores
:= (fn x
=> (old x
; f x
))
126 fun registerAfter f
=
130 afters
:= (fn x
=> (old x
; f x
))
134 val currentPath
= ref
""
138 fun currentDomain () = !current
140 fun domainFile name
= TextIO.openOut (!currentPath ^ name
)
144 val toks
= String.fields (fn ch
=> ch
= #
".") domain
146 val elems
= foldr (fn (piece
, elems
) =>
148 val elems
= piece
:: elems
149 val path
= String.concatWith
"/" (Config
.resultRoot
:: rev elems
)
150 val tmpPath
= String.concatWith
"/" (Config
.tmpDir
:: rev elems
)
152 (if Posix
.FileSys
.ST
.isDir
153 (Posix
.FileSys
.stat path
) then
156 (OS
.FileSys
.remove path
;
157 OS
.FileSys
.mkDir path
))
158 handle OS
.SysErr _
=> OS
.FileSys
.mkDir path
;
160 (if Posix
.FileSys
.ST
.isDir
161 (Posix
.FileSys
.stat tmpPath
) then
164 (OS
.FileSys
.remove tmpPath
;
165 OS
.FileSys
.mkDir tmpPath
))
166 handle OS
.SysErr _
=> OS
.FileSys
.mkDir tmpPath
;
171 fn root
=> String.concatWith
"/" (root
:: rev ("" :: elems
))
174 datatype file_action
' =
175 Add
' of {src
: string, dst
: string}
177 | Modify
' of {src
: string, dst
: string}
181 val realPath
= getPath dom Config
.resultRoot
182 val tmpPath
= !currentPath
184 val dir
= Posix
.FileSys
.opendir realPath
187 case Posix
.FileSys
.readdir dir
of
188 NONE
=> (Posix
.FileSys
.closedir dir
;
192 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
194 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
197 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat
real) then
199 else if Posix
.FileSys
.access (tmp
, []) then
200 if Slave
.shell
[Config
.diff
, " ", real, " ", tmp
] then
203 loopReal (Modify
' {src
= tmp
, dst
= real} :: acts
)
205 loopReal (Delete
' real :: acts
)
208 val acts
= loopReal
[]
210 val dir
= Posix
.FileSys
.opendir tmpPath
213 case Posix
.FileSys
.readdir dir
of
214 NONE
=> (Posix
.FileSys
.closedir dir
;
218 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
220 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
223 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat tmp
) then
225 else if Posix
.FileSys
.access (real, []) then
228 loopTmp (Add
' {src
= tmp
, dst
= real} :: acts
)
231 val acts
= loopTmp acts
236 val _
= Env
.containerV_one
"domain"
237 ("domain", Env
.string)
240 val kind
= Env
.env
dnsKind (evs
, "DNS")
241 val ttl
= Env
.env Env
.int (evs
, "TTL")
243 val path
= getPath dom Config
.tmpDir
245 val () = (current
:= dom
;
249 fun saveSoa (kind
, soa
: soa
) =
251 val outf
= domainFile
"soa"
253 TextIO.output (outf
, kind
);
254 TextIO.output (outf
, "\n");
255 TextIO.output (outf
, Int.toString ttl
);
256 TextIO.output (outf
, "\n");
257 TextIO.output (outf
, #ns soa
);
258 TextIO.output (outf
, "\n");
261 | SOME n
=> TextIO.output (outf
, Int.toString n
);
262 TextIO.output (outf
, "\n");
263 TextIO.output (outf
, Int.toString (#ref soa
));
264 TextIO.output (outf
, "\n");
265 TextIO.output (outf
, Int.toString (#ret soa
));
266 TextIO.output (outf
, "\n");
267 TextIO.output (outf
, Int.toString (#exp soa
));
268 TextIO.output (outf
, "\n");
269 TextIO.output (outf
, Int.toString (#min soa
));
270 TextIO.output (outf
, "\n");
274 fun saveNamed (kind
, soa
: soa
) =
276 val outf
= domainFile
"named.conf"
278 TextIO.output (outf
, "\nzone \"");
279 TextIO.output (outf
, dom
);
280 TextIO.output (outf
, "\" IN {\n\ttype ");
281 TextIO.output (outf
, kind
);
282 TextIO.output (outf
, ";\n\tfile \"");
283 TextIO.output (outf
, Config
.Bind
.zonePath
);
284 TextIO.output (outf
, "/");
285 TextIO.output (outf
, dom
);
286 TextIO.output (outf
, ".zone\";\n");
288 "master" => TextIO.output (outf
, "\tallow-update { none; };\n")
289 | _
=> TextIO.output (outf
, "\tmasters { 1.2.3.4; };\n");
290 TextIO.output (outf
, "}\n");
294 fun saveBoth ks
= (saveSoa ks
; saveNamed ks
)
298 | Master soa
=> saveBoth ("master", soa
)
299 | Slave soa
=> saveBoth ("slave", soa
)
306 val diffs
= findDiffs dom
308 val dir
= getPath dom Config
.resultRoot
310 val diffs
= map (fn Add
' {src
, dst
} =>
311 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
312 fn cl
=> "Copy failed: " ^ cl
);
318 (OS
.FileSys
.remove dst
319 handle OS
.SysErr _
=>
320 ErrorMsg
.error
NONE ("Delete failed for " ^ dst
);
321 {action
= Slave
.Delete
,
325 | Modify
' {src
, dst
} =>
326 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
327 fn cl
=> "Copy failed: " ^ cl
);
328 {action
= Slave
.Modify
,
333 if !ErrorMsg
.anyErrors
then
336 Slave
.handleChanges diffs
;
337 ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, "/*"],
338 fn cl
=> "Temp file cleanup failed: " ^ cl
))