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
23 structure SM
= DataStructures
.StringMap
24 structure SS
= DataStructures
.StringSet
26 val nodes
= map #
1 Config
.nodeIps
27 val nodeMap
= foldl (fn ((node
, ip
), mp
) => SM
.insert (mp
, node
, ip
))
28 SM
.empty Config
.nodeIps
29 fun nodeIp node
= valOf (SM
.find (nodeMap
, node
))
32 fun setUser ur
= usr
:= ur
35 val your_doms
= ref SS
.empty
36 fun your_domains () = !your_doms
38 val your_usrs
= ref SS
.empty
39 fun your_users () = !your_usrs
41 val your_grps
= ref SS
.empty
42 fun your_groups () = !your_grps
44 val your_pths
= ref SS
.empty
45 fun your_paths () = !your_pths
48 case map
Int.fromString (String.fields (fn ch
=> ch
= #
".") s
) of
49 [SOME n1
, SOME n2
, SOME n3
, SOME n4
] =>
50 n1
>= 0 andalso n1
< 256 andalso n2
>= 0 andalso n2
< 256 andalso n3
>= 0 andalso n3
< 256 andalso n4
>= 0 andalso n4
< 256
53 fun isIdent ch
= Char.isLower ch
orelse Char.isDigit ch
56 size s
> 0 andalso size s
< 20
57 andalso CharVector
.all (fn ch
=> isIdent ch
orelse ch
= #
"-") s
60 size s
> 0 andalso size s
< 100
61 andalso List.all
validHost (String.fields (fn ch
=> ch
= #
".") s
)
63 fun validNode s
= List.exists (fn s
' => s
= s
') nodes
65 fun yourDomain s
= SS
.member (your_domains (), s
)
66 fun yourUser s
= SS
.member (your_users (), s
)
67 fun yourGroup s
= SS
.member (your_groups (), s
)
69 List.all (fn s
=> s
<> "..") (String.fields (fn ch
=> ch
= #
"/") path
)
70 andalso CharVector
.all (fn ch
=> Char.isAlphaNum ch
orelse ch
= #
"." orelse ch
= #
"/"
71 orelse ch
= #
"-" orelse ch
= #
"_") path
72 andalso SS
.exists (fn s
' => path
= s
' orelse String.isPrefix (s
' ^
"/") path
) (your_paths ())
74 fun yourDomainHost s
=
77 val (pref
, suf
) = Substring
.splitl (fn ch
=> ch
<> #
".") (Substring
.full s
)
79 Substring
.size suf
> 0
80 andalso validHost (Substring
.string pref
)
81 andalso yourDomain (Substring
.string
82 (Substring
.slice (suf
, 1, NONE
)))
85 fun validUser s
= size s
> 0 andalso size s
< 20
86 andalso CharVector
.all
Char.isAlphaNum s
88 val validGroup
= validUser
90 val _
= Env
.type_one
"no_spaces"
92 (CharVector
.all (fn ch
=> not (Char.isSpace ch
)))
93 val _
= Env
.type_one
"no_newlines"
95 (CharVector
.all (fn ch
=> ch
<> #
"\n" andalso ch
<> #
"\r"))
97 val _
= Env
.type_one
"ip"
101 val _
= Env
.type_one
"host"
105 val _
= Env
.type_one
"domain"
109 val _
= Env
.type_one
"your_domain"
113 val _
= Env
.type_one
"your_domain_host"
117 val _
= Env
.type_one
"user"
121 val _
= Env
.type_one
"group"
125 val _
= Env
.type_one
"your_user"
129 val _
= Env
.type_one
"your_group"
133 val _
= Env
.type_one
"your_path"
137 val _
= Env
.type_one
"node"
143 val dl
= ErrorMsg
.dummyLoc
145 val nsD
= (EString Config
.defaultNs
, dl
)
146 val serialD
= (EVar
"serialAuto", dl
)
147 val refD
= (EInt Config
.defaultRefresh
, dl
)
148 val retD
= (EInt Config
.defaultRetry
, dl
)
149 val expD
= (EInt Config
.defaultExpiry
, dl
)
150 val minD
= (EInt Config
.defaultMinimum
, dl
)
152 val soaD
= multiApp ((EVar
"soa", dl
),
154 [nsD
, serialD
, refD
, retD
, expD
, minD
])
156 val masterD
= (EApp ((EVar
"internalMaster", dl
),
157 (EString Config
.defaultNode
, dl
)),
160 val _
= Main
.registerDefault ("DNS",
161 (TBase
"dnsKind", dl
),
162 (fn () => multiApp ((EVar
"useDns", dl
),
164 [soaD
, masterD
, (EList
[], dl
)])))
166 val _
= Main
.registerDefault ("TTL",
168 (fn () => (EInt Config
.Bind
.defaultTTL
, dl
)))
170 type soa
= {ns
: string,
177 val serial
= fn (EVar
"serialAuto", _
) => SOME NONE
178 |
(EApp ((EVar
"serialConst", _
), n
), _
) => Option
.map
SOME (Env
.int n
)
181 val soa
= fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
182 ((EVar
"soa", _
), ns
), _
),
188 (case (Env
.string ns
, serial sl
, Env
.int rf
,
189 Env
.int ret
, Env
.int exp
, Env
.int min
) of
190 (SOME ns
, SOME sl
, SOME rf
,
191 SOME ret
, SOME exp
, SOME min
) =>
202 ExternalMaster
of string
203 | InternalMaster
of string
205 val master
= fn (EApp ((EVar
"externalMaster", _
), e
), _
) => Option
.map
ExternalMaster (Env
.string e
)
206 |
(EApp ((EVar
"internalMaster", _
), e
), _
) => Option
.map
InternalMaster (Env
.string e
)
210 UseDns
of {soa
: soa
,
212 slaves
: string list
}
215 val dnsKind
= fn (EApp ((EApp ((EApp
216 ((EVar
"useDns", _
), sa
), _
),
219 (case (soa sa
, master mstr
, Env
.list Env
.string slaves
) of
220 (SOME sa
, SOME mstr
, SOME slaves
) =>
221 SOME (UseDns
{soa
= sa
,
225 |
(EVar
"noDns", _
) => SOME NoDns
228 val befores
= ref (fn (_
: string) => ())
229 val afters
= ref (fn (_
: string) => ())
231 fun registerBefore f
=
235 befores
:= (fn x
=> (old x
; f x
))
238 fun registerAfter f
=
242 afters
:= (fn x
=> (old x
; f x
))
246 val currentPath
= ref (fn (_
: string) => "")
250 fun currentDomain () = !current
252 fun domainFile
{node
, name
} = ((*print ("Opening " ^
!currentPath node ^ name ^
"\n");*)
253 TextIO.openOut (!currentPath node ^ name
))
257 val toks
= String.fields (fn ch
=> ch
= #
".") domain
259 val elems
= foldr (fn (piece
, elems
) =>
261 val elems
= piece
:: elems
265 val path
= String.concatWith
"/"
266 (Config
.resultRoot
:: node
:: rev elems
)
267 val tmpPath
= String.concatWith
"/"
268 (Config
.tmpDir
:: node
:: rev elems
)
270 (if Posix
.FileSys
.ST
.isDir
271 (Posix
.FileSys
.stat path
) then
274 (OS
.FileSys
.remove path
;
275 OS
.FileSys
.mkDir path
))
276 handle OS
.SysErr _
=> OS
.FileSys
.mkDir path
;
278 (if Posix
.FileSys
.ST
.isDir
279 (Posix
.FileSys
.stat tmpPath
) then
282 (OS
.FileSys
.remove tmpPath
;
283 OS
.FileSys
.mkDir tmpPath
))
284 handle OS
.SysErr _
=> OS
.FileSys
.mkDir tmpPath
291 fn (root
, site
) => String.concatWith
"/" (root
:: site
:: rev ("" :: elems
))
294 datatype file_action
' =
295 Add
' of {src
: string, dst
: string}
297 | Modify
' of {src
: string, dst
: string}
299 fun findDiffs (site
, dom
, acts
) =
302 val realPath
= gp (Config
.resultRoot
, site
)
303 val tmpPath
= gp (Config
.tmpDir
, site
)
305 (*val _
= print ("getDiffs(" ^ site ^
", " ^ dom ^
")... " ^ realPath ^
"; " ^ tmpPath ^
"\n")*)
307 val dir
= Posix
.FileSys
.opendir realPath
310 case Posix
.FileSys
.readdir dir
of
311 NONE
=> (Posix
.FileSys
.closedir dir
;
315 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
317 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
320 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat
real) then
322 else if Posix
.FileSys
.access (tmp
, []) then
323 if Slave
.shell
[Config
.diff
, " ", real, " ", tmp
] then
326 loopReal ((site
, dom
, realPath
, Modify
' {src
= tmp
, dst
= real}) :: acts
)
328 loopReal ((site
, dom
, realPath
, Delete
' real) :: acts
)
331 val acts
= loopReal acts
333 val dir
= Posix
.FileSys
.opendir tmpPath
336 case Posix
.FileSys
.readdir dir
of
337 NONE
=> (Posix
.FileSys
.closedir dir
;
341 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
343 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
346 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat tmp
) then
348 else if Posix
.FileSys
.access (real, []) then
351 loopTmp ((site
, dom
, realPath
, Add
' {src
= tmp
, dst
= real}) :: acts
)
354 val acts
= loopTmp acts
359 fun findAllDiffs () =
361 val dir
= Posix
.FileSys
.opendir Config
.tmpDir
362 val len
= length (String.fields (fn ch
=> ch
= #
"/") Config
.tmpDir
) + 1
364 fun exploreSites diffs
=
365 case Posix
.FileSys
.readdir dir
of
369 fun explore (dname
, diffs
) =
371 val dir
= Posix
.FileSys
.opendir dname
374 case Posix
.FileSys
.readdir dir
of
378 val fname
= OS
.Path
.joinDirFile
{dir
= dname
,
381 loop (if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat fname
) then
383 val dom
= String.fields (fn ch
=> ch
= #
"/") fname
384 val dom
= List.drop (dom
, len
)
385 val dom
= String.concatWith
"." (rev dom
)
387 val dname
' = OS
.Path
.joinDirFile
{dir
= dname
,
391 findDiffs (site
, dom
, diffs
))
398 before Posix
.FileSys
.closedir dir
401 explore (OS
.Path
.joinDirFile
{dir
= Config
.tmpDir
,
406 before Posix
.FileSys
.closedir dir
409 val masterNode
: string option ref
= ref NONE
410 fun dnsMaster () = !masterNode
412 val _
= Env
.containerV_one
"domain"
413 ("domain", Env
.string)
416 val kind
= Env
.env
dnsKind (evs
, "DNS")
417 val ttl
= Env
.env Env
.int (evs
, "TTL")
419 val path
= getPath dom
421 val () = (current
:= dom
;
422 currentPath
:= (fn site
=> path (Config
.tmpDir
, site
)))
424 fun saveSoa (kind
, soa
: soa
) node
=
426 val outf
= domainFile
{node
= node
, name
= "soa"}
428 TextIO.output (outf
, kind
);
429 TextIO.output (outf
, "\n");
430 TextIO.output (outf
, Int.toString ttl
);
431 TextIO.output (outf
, "\n");
432 TextIO.output (outf
, #ns soa
);
433 TextIO.output (outf
, "\n");
436 | SOME n
=> TextIO.output (outf
, Int.toString n
);
437 TextIO.output (outf
, "\n");
438 TextIO.output (outf
, Int.toString (#ref soa
));
439 TextIO.output (outf
, "\n");
440 TextIO.output (outf
, Int.toString (#ret soa
));
441 TextIO.output (outf
, "\n");
442 TextIO.output (outf
, Int.toString (#exp soa
));
443 TextIO.output (outf
, "\n");
444 TextIO.output (outf
, Int.toString (#min soa
));
445 TextIO.output (outf
, "\n");
449 fun saveNamed (kind
, soa
: soa
, masterIp
) node
=
451 val outf
= domainFile
{node
= node
, name
= "named.conf"}
453 TextIO.output (outf
, "\nzone \"");
454 TextIO.output (outf
, dom
);
455 TextIO.output (outf
, "\" IN {\n\ttype ");
456 TextIO.output (outf
, kind
);
457 TextIO.output (outf
, ";\n\tfile \"");
458 TextIO.output (outf
, Config
.Bind
.zonePath
);
459 TextIO.output (outf
, "/");
460 TextIO.output (outf
, dom
);
461 TextIO.output (outf
, ".zone\";\n");
463 "master" => TextIO.output (outf
, "\tallow-update { none; };\n")
464 | _
=> (TextIO.output (outf
, "\tmasters { ");
465 TextIO.output (outf
, masterIp
);
466 TextIO.output (outf
, " };\n"));
467 TextIO.output (outf
, "};\n");
472 NoDns
=> masterNode
:= NONE
477 InternalMaster node
=> valOf (SM
.find (nodeMap
, node
))
478 | ExternalMaster ip
=> ip
480 app (saveSoa ("slave", #soa dns
)) (#slaves dns
);
481 app (saveNamed ("slave", #soa dns
, masterIp
)) (#slaves dns
);
483 InternalMaster node
=>
484 (masterNode
:= SOME node
;
485 saveSoa ("master", #soa dns
) node
;
486 saveNamed ("master", #soa dns
, masterIp
) node
)
487 | _
=> masterNode
:= NONE
;
491 fn () => !afters (!current
))
493 val () = Env
.registerPreTycheck (fn () => (setUser Config
.testUser
;
494 Acl
.read Config
.aclFile
;
495 your_doms
:= Acl
.class
{user
= getUser (),
497 your_usrs
:= Acl
.class
{user
= getUser (),
499 your_grps
:= Acl
.class
{user
= getUser (),
501 your_pths
:= Acl
.class
{user
= getUser (),
504 val () = Env
.registerPre (fn () => (ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, ""],
505 fn cl
=> "Temp file cleanup failed: " ^ cl
));
506 OS
.FileSys
.mkDir Config
.tmpDir
;
507 app (fn node
=> OS
.FileSys
.mkDir
508 (OS
.Path
.joinDirFile
{dir
= Config
.tmpDir
,
511 app (fn node
=> OS
.FileSys
.mkDir
512 (OS
.Path
.joinDirFile
{dir
= Config
.resultRoot
,
514 handle OS
.SysErr _
=> ())
517 val () = Env
.registerPost (fn () =>
519 val diffs
= findAllDiffs ()
521 val diffs
= map (fn (site
, dom
, dir
, Add
' {src
, dst
}) =>
522 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
523 fn cl
=> "Copy failed: " ^ cl
);
529 |
(site
, dom
, dir
, Delete
' dst
) =>
530 (OS
.FileSys
.remove dst
531 handle OS
.SysErr _
=>
532 ErrorMsg
.error
NONE ("Delete failed for " ^ dst
);
534 {action
= Slave
.Delete
,
538 |
(site
, dom
, dir
, Modify
' {src
, dst
}) =>
539 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
540 fn cl
=> "Copy failed: " ^ cl
);
542 {action
= Slave
.Modify
,
547 if !ErrorMsg
.anyErrors
then
550 Slave
.handleChanges (map #
2 diffs
);
551 ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, ""],
552 fn cl
=> "Temp file cleanup failed: " ^ cl
))