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
25 structure SM
= DataStructures
.StringMap
26 structure SS
= DataStructures
.StringSet
28 val ssl_context
= ref (NONE
: OpenSSL
.context option
)
29 fun set_context ctx
= ssl_context
:= SOME ctx
31 val nodes
= map #
1 Config
.nodeIps
32 val nodeMap
= foldl (fn ((node
, ip
), mp
) => SM
.insert (mp
, node
, ip
))
33 SM
.empty Config
.nodeIps
34 fun nodeIp node
= valOf (SM
.find (nodeMap
, node
))
39 val your_doms
= ref SS
.empty
40 fun your_domains () = !your_doms
42 val your_usrs
= ref SS
.empty
43 fun your_users () = !your_usrs
45 val your_grps
= ref SS
.empty
46 fun your_groups () = !your_grps
48 val your_pths
= ref SS
.empty
49 fun your_paths () = !your_pths
53 your_doms
:= Acl
.class
{user
= getUser (),
55 your_usrs
:= Acl
.class
{user
= getUser (),
57 your_grps
:= Acl
.class
{user
= getUser (),
59 your_pths
:= Acl
.class
{user
= getUser (),
63 case map
Int.fromString (String.fields (fn ch
=> ch
= #
".") s
) of
64 [SOME n1
, SOME n2
, SOME n3
, SOME n4
] =>
65 n1
>= 0 andalso n1
< 256 andalso n2
>= 0 andalso n2
< 256 andalso n3
>= 0 andalso n3
< 256 andalso n4
>= 0 andalso n4
< 256
68 fun isIdent ch
= Char.isLower ch
orelse Char.isDigit ch
71 size s
> 0 andalso size s
< 20
72 andalso CharVector
.all (fn ch
=> isIdent ch
orelse ch
= #
"-") s
75 size s
> 0 andalso size s
< 100
76 andalso List.all
validHost (String.fields (fn ch
=> ch
= #
".") s
)
78 fun validNode s
= List.exists (fn s
' => s
= s
') nodes
80 fun yourDomain s
= SS
.member (your_domains (), s
)
81 fun yourUser s
= SS
.member (your_users (), s
)
82 fun yourGroup s
= SS
.member (your_groups (), s
)
84 List.all (fn s
=> s
<> "..") (String.fields (fn ch
=> ch
= #
"/") path
)
85 andalso CharVector
.all (fn ch
=> Char.isAlphaNum ch
orelse ch
= #
"." orelse ch
= #
"/"
86 orelse ch
= #
"-" orelse ch
= #
"_") path
87 andalso SS
.exists (fn s
' => path
= s
' orelse String.isPrefix (s
' ^
"/") path
) (your_paths ())
89 fun yourDomainHost s
=
92 val (pref
, suf
) = Substring
.splitl (fn ch
=> ch
<> #
".") (Substring
.full s
)
94 Substring
.size suf
> 0
95 andalso validHost (Substring
.string pref
)
96 andalso yourDomain (Substring
.string
97 (Substring
.slice (suf
, 1, NONE
)))
100 val yourDomain
= yourDomainHost
102 fun validUser s
= size s
> 0 andalso size s
< 20
103 andalso CharVector
.all
Char.isAlphaNum s
105 fun validEmailUser s
=
106 size s
> 0 andalso size s
< 50
107 andalso CharVector
.all (fn ch
=> Char.isAlphaNum ch
113 val validGroup
= validUser
115 val _
= Env
.type_one
"no_spaces"
117 (CharVector
.all (fn ch
=> not (Char.isSpace ch
)))
118 val _
= Env
.type_one
"no_newlines"
120 (CharVector
.all (fn ch
=> ch
<> #
"\n" andalso ch
<> #
"\r"))
122 val _
= Env
.type_one
"ip"
126 val _
= Env
.type_one
"host"
130 val _
= Env
.type_one
"domain"
134 val _
= Env
.type_one
"your_domain"
138 val _
= Env
.type_one
"your_domain_host"
142 val _
= Env
.type_one
"user"
146 val _
= Env
.type_one
"group"
150 val _
= Env
.type_one
"your_user"
154 val _
= Env
.type_one
"your_group"
158 val _
= Env
.type_one
"your_path"
162 val _
= Env
.type_one
"node"
166 val _
= Env
.registerFunction ("dns_node_to_node",
170 val _
= Env
.registerFunction ("mail_node_to_node",
175 val dl
= ErrorMsg
.dummyLoc
177 val nsD
= (EString Config
.defaultNs
, dl
)
178 val serialD
= (EVar
"serialAuto", dl
)
179 val refD
= (EInt Config
.defaultRefresh
, dl
)
180 val retD
= (EInt Config
.defaultRetry
, dl
)
181 val expD
= (EInt Config
.defaultExpiry
, dl
)
182 val minD
= (EInt Config
.defaultMinimum
, dl
)
184 val soaD
= multiApp ((EVar
"soa", dl
),
186 [nsD
, serialD
, refD
, retD
, expD
, minD
])
188 val masterD
= (EApp ((EVar
"internalMaster", dl
),
189 (EString Config
.masterNode
, dl
)),
192 val slavesD
= (EList (map (fn s
=> (EString s
, dl
)) Config
.slaveNodes
), dl
)
194 val _
= Defaults
.registerDefault ("Mailbox",
196 (fn () => (EString (getUser ()), dl
)))
198 val _
= Defaults
.registerDefault ("DNS",
199 (TBase
"dnsKind", dl
),
200 (fn () => multiApp ((EVar
"useDns", dl
),
202 [soaD
, masterD
, slavesD
])))
204 val _
= Defaults
.registerDefault ("TTL",
206 (fn () => (EInt Config
.Bind
.defaultTTL
, dl
)))
208 type soa
= {ns
: string,
215 val serial
= fn (EVar
"serialAuto", _
) => SOME NONE
216 |
(EApp ((EVar
"serialConst", _
), n
), _
) => Option
.map
SOME (Env
.int n
)
219 val soa
= fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
220 ((EVar
"soa", _
), ns
), _
),
226 (case (Env
.string ns
, serial sl
, Env
.int rf
,
227 Env
.int ret
, Env
.int exp
, Env
.int min
) of
228 (SOME ns
, SOME sl
, SOME rf
,
229 SOME ret
, SOME exp
, SOME min
) =>
240 ExternalMaster
of string
241 | InternalMaster
of string
245 val _
= Env
.registerFunction ("ip_of_node",
246 fn [(EString node
, _
)] => SOME (EString (nodeIp node
), dl
)
249 val master
= fn (EApp ((EVar
"externalMaster", _
), e
), _
) => Option
.map
ExternalMaster (ip e
)
250 |
(EApp ((EVar
"internalMaster", _
), e
), _
) => Option
.map
InternalMaster (Env
.string e
)
254 UseDns
of {soa
: soa
,
256 slaves
: string list
}
259 val dnsKind
= fn (EApp ((EApp ((EApp
260 ((EVar
"useDns", _
), sa
), _
),
263 (case (soa sa
, master mstr
, Env
.list Env
.string slaves
) of
264 (SOME sa
, SOME mstr
, SOME slaves
) =>
265 SOME (UseDns
{soa
= sa
,
269 |
(EVar
"noDns", _
) => SOME NoDns
272 val befores
= ref (fn (_
: string) => ())
273 val afters
= ref (fn (_
: string) => ())
275 fun registerBefore f
=
279 befores
:= (fn x
=> (old x
; f x
))
282 fun registerAfter f
=
286 afters
:= (fn x
=> (old x
; f x
))
289 val globals
= ref (fn () => ())
290 val locals
= ref (fn () => ())
292 fun registerResetGlobal f
=
296 globals
:= (fn x
=> (old x
; f x
))
299 fun registerResetLocal f
=
303 locals
:= (fn x
=> (old x
; f x
))
306 fun resetGlobal () = (!globals ();
307 ignore (OS
.Process
.system (Config
.rm ^
" -rf " ^ Config
.resultRoot ^
"/*")))
308 fun resetLocal () = !locals ()
311 val currentPath
= ref (fn (_
: string) => "")
315 fun currentDomain () = !current
317 fun domainFile
{node
, name
} = ((*print ("Opening " ^
!currentPath node ^ name ^
"\n");*)
318 TextIO.openOut (!currentPath node ^ name
))
322 val toks
= String.fields (fn ch
=> ch
= #
".") domain
324 val elems
= foldr (fn (piece
, elems
) =>
326 val elems
= piece
:: elems
330 val path
= String.concatWith
"/"
331 (Config
.resultRoot
:: node
:: rev elems
)
332 val tmpPath
= String.concatWith
"/"
333 (Config
.tmpDir
:: node
:: rev elems
)
335 (if Posix
.FileSys
.ST
.isDir
336 (Posix
.FileSys
.stat path
) then
339 (OS
.FileSys
.remove path
;
340 OS
.FileSys
.mkDir path
))
341 handle OS
.SysErr _
=> OS
.FileSys
.mkDir path
;
343 (if Posix
.FileSys
.ST
.isDir
344 (Posix
.FileSys
.stat tmpPath
) then
347 (OS
.FileSys
.remove tmpPath
;
348 OS
.FileSys
.mkDir tmpPath
))
349 handle OS
.SysErr _
=> OS
.FileSys
.mkDir tmpPath
356 fn (root
, site
) => String.concatWith
"/" (root
:: site
:: rev ("" :: elems
))
359 datatype file_action
' =
360 Add
' of {src
: string, dst
: string}
362 | Modify
' of {src
: string, dst
: string}
364 fun findDiffs (site
, dom
, acts
) =
367 val realPath
= gp (Config
.resultRoot
, site
)
368 val tmpPath
= gp (Config
.tmpDir
, site
)
370 (*val _
= print ("getDiffs(" ^ site ^
", " ^ dom ^
")... " ^ realPath ^
"; " ^ tmpPath ^
"\n")*)
372 val dir
= Posix
.FileSys
.opendir realPath
375 case Posix
.FileSys
.readdir dir
of
376 NONE
=> (Posix
.FileSys
.closedir dir
;
380 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
382 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
385 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat
real) then
387 else if Posix
.FileSys
.access (tmp
, []) then
388 if Slave
.shell
[Config
.diff
, " ", real, " ", tmp
] then
391 loopReal ((site
, dom
, realPath
, Modify
' {src
= tmp
, dst
= real}) :: acts
)
393 loopReal ((site
, dom
, realPath
, Delete
' real) :: acts
)
396 val acts
= loopReal acts
398 val dir
= Posix
.FileSys
.opendir tmpPath
401 case Posix
.FileSys
.readdir dir
of
402 NONE
=> (Posix
.FileSys
.closedir dir
;
406 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
408 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
411 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat tmp
) then
413 else if Posix
.FileSys
.access (real, []) then
416 loopTmp ((site
, dom
, realPath
, Add
' {src
= tmp
, dst
= real}) :: acts
)
419 val acts
= loopTmp acts
424 fun findAllDiffs () =
426 val dir
= Posix
.FileSys
.opendir Config
.tmpDir
427 val len
= length (String.fields (fn ch
=> ch
= #
"/") Config
.tmpDir
) + 1
429 fun exploreSites diffs
=
430 case Posix
.FileSys
.readdir dir
of
434 fun explore (dname
, diffs
) =
436 val dir
= Posix
.FileSys
.opendir dname
439 case Posix
.FileSys
.readdir dir
of
443 val fname
= OS
.Path
.joinDirFile
{dir
= dname
,
446 loop (if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat fname
) then
448 val dom
= String.fields (fn ch
=> ch
= #
"/") fname
449 val dom
= List.drop (dom
, len
)
450 val dom
= String.concatWith
"." (rev dom
)
452 val dname
' = OS
.Path
.joinDirFile
{dir
= dname
,
456 findDiffs (site
, dom
, diffs
))
463 before Posix
.FileSys
.closedir dir
466 exploreSites (explore (OS
.Path
.joinDirFile
{dir
= Config
.tmpDir
,
467 file
= site
}, diffs
))
471 before Posix
.FileSys
.closedir dir
474 val masterNode
: string option ref
= ref NONE
475 fun dnsMaster () = !masterNode
477 val _
= Env
.containerV_one
"domain"
478 ("domain", Env
.string)
481 val kind
= Env
.env
dnsKind (evs
, "DNS")
482 val ttl
= Env
.env Env
.int (evs
, "TTL")
484 val path
= getPath dom
486 val () = (current
:= dom
;
487 currentPath
:= (fn site
=> path (Config
.tmpDir
, site
)))
489 fun saveSoa (kind
, soa
: soa
) node
=
491 val outf
= domainFile
{node
= node
, name
= "soa"}
493 TextIO.output (outf
, kind
);
494 TextIO.output (outf
, "\n");
495 TextIO.output (outf
, Int.toString ttl
);
496 TextIO.output (outf
, "\n");
497 TextIO.output (outf
, #ns soa
);
498 TextIO.output (outf
, "\n");
501 | SOME n
=> TextIO.output (outf
, Int.toString n
);
502 TextIO.output (outf
, "\n");
503 TextIO.output (outf
, Int.toString (#ref soa
));
504 TextIO.output (outf
, "\n");
505 TextIO.output (outf
, Int.toString (#ret soa
));
506 TextIO.output (outf
, "\n");
507 TextIO.output (outf
, Int.toString (#exp soa
));
508 TextIO.output (outf
, "\n");
509 TextIO.output (outf
, Int.toString (#min soa
));
510 TextIO.output (outf
, "\n");
514 fun saveNamed (kind
, soa
: soa
, masterIp
) node
=
515 if dom
= "localhost" then
518 val outf
= domainFile
{node
= node
, name
= "named.conf"}
520 TextIO.output (outf
, "\nzone \"");
521 TextIO.output (outf
, dom
);
522 TextIO.output (outf
, "\" IN {\n\ttype ");
523 TextIO.output (outf
, kind
);
524 TextIO.output (outf
, ";\n\tfile \"");
525 TextIO.output (outf
, Config
.Bind
.zonePath_real
);
526 TextIO.output (outf
, "/");
527 TextIO.output (outf
, dom
);
528 TextIO.output (outf
, ".zone\";\n");
530 "master" => TextIO.output (outf
, "\tallow-update { none; };\n")
531 | _
=> (TextIO.output (outf
, "\tmasters { ");
532 TextIO.output (outf
, masterIp
);
533 TextIO.output (outf
, "; };\n"));
534 TextIO.output (outf
, "};\n");
539 NoDns
=> masterNode
:= NONE
544 InternalMaster node
=> valOf (SM
.find (nodeMap
, node
))
545 | ExternalMaster ip
=> ip
547 app (saveSoa ("slave", #soa dns
)) (#slaves dns
);
548 app (saveNamed ("slave", #soa dns
, masterIp
)) (#slaves dns
);
550 InternalMaster node
=>
551 (masterNode
:= SOME node
;
552 saveSoa ("master", #soa dns
) node
;
553 saveNamed ("master", #soa dns
, masterIp
) node
)
554 | _
=> masterNode
:= NONE
;
558 fn () => !afters (!current
))
560 val () = Env
.registerPre (fn () => (ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, ""],
561 fn cl
=> "Temp file cleanup failed: " ^ cl
));
562 OS
.FileSys
.mkDir Config
.tmpDir
;
563 app (fn node
=> OS
.FileSys
.mkDir
564 (OS
.Path
.joinDirFile
{dir
= Config
.tmpDir
,
567 app (fn node
=> OS
.FileSys
.mkDir
568 (OS
.Path
.joinDirFile
{dir
= Config
.resultRoot
,
570 handle OS
.SysErr _
=> ())
573 fun handleSite (site
, files
) =
577 print ("New configuration for node " ^ site ^
"\n");
578 if site
= Config
.defaultNode
then
579 Slave
.handleChanges files
581 val bio
= OpenSSL
.connect (valOf (!ssl_context
),
584 ^
Int.toString Config
.slavePort
)
586 app (fn file
=> Msg
.send (bio
, MsgFile file
)) files
;
587 Msg
.send (bio
, MsgDoFiles
);
589 NONE
=> print
"Slave closed connection unexpectedly\n"
592 MsgOk
=> print ("Slave " ^ site ^
" finished\n")
593 | MsgError s
=> print ("Slave " ^ site
594 ^
" returned error: " ^
596 | _
=> print ("Slave " ^ site
597 ^
" returned unexpected command\n");
602 val () = Env
.registerPost (fn () =>
604 val diffs
= findAllDiffs ()
606 val diffs
= map (fn (site
, dom
, dir
, Add
' {src
, dst
}) =>
607 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
608 fn cl
=> "Copy failed: " ^ cl
);
614 |
(site
, dom
, dir
, Delete
' dst
) =>
615 (OS
.FileSys
.remove dst
616 handle OS
.SysErr _
=>
617 ErrorMsg
.error
NONE ("Delete failed for " ^ dst
);
619 {action
= Slave
.Delete
,
623 |
(site
, dom
, dir
, Modify
' {src
, dst
}) =>
624 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
625 fn cl
=> "Copy failed: " ^ cl
);
627 {action
= Slave
.Modify
,
632 if !ErrorMsg
.anyErrors
then
635 val changed
= foldl (fn ((site
, file
), changed
) =>
637 val ls
= case SM
.find (changed
, site
) of
641 SM
.insert (changed
, site
, file
:: ls
)
644 SM
.appi handleSite changed
646 ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, ""],
647 fn cl
=> "Temp file cleanup failed: " ^ cl
))
650 fun hasPriv priv
= Acl
.query
{user
= getUser (), class
= "priv", value
= "all"}
651 orelse Acl
.query
{user
= getUser (), class
= "priv", value
= priv
}
653 val _
= Env
.type_one
"dns_node"
656 List.exists (fn x
=> x
= node
) Config
.dnsNodes_all
657 orelse (hasPriv
"dns"
658 andalso List.exists (fn x
=> x
= node
) Config
.dnsNodes_admin
))
660 val _
= Env
.type_one
"mail_node"
663 List.exists (fn x
=> x
= node
) Config
.mailNodes_all
664 orelse (hasPriv
"mail"
665 andalso List.exists (fn x
=> x
= node
) Config
.mailNodes_admin
))
669 fun doNode (node
, _
) =
671 val dname
= OS
.Path
.joinDirFile
{dir
= Config
.resultRoot
,
674 fun doDom (dom
, actions
) =
676 val domPath
= String.concatWith
"/" (rev (String.fields (fn ch
=> ch
= #
".") dom
))
677 val dname
= OS
.Path
.concat (dname
, domPath
)
679 fun visitDom (dom
, dname
, actions
) =
681 val dir
= Posix
.FileSys
.opendir dname
684 case Posix
.FileSys
.readdir dir
of
688 val fnameFull
= OS
.Path
.joinDirFile
{dir
= dname
,
691 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat fnameFull
) then
692 loop (visitDom (fname ^
"." ^ dom
,
696 loop ({action
= Slave
.Delete
,
699 file
= fnameFull
} :: actions
)
703 before Posix
.FileSys
.closedir dir
705 handle OS
.SysErr _
=>
706 (print ("Warning: System error deleting domain " ^ dom ^
" on " ^ node ^
".\n");
709 visitDom (dom
, dname
, actions
)
712 val actions
= foldl doDom
[] doms
714 handleSite (node
, actions
)
716 handle IO
.Io _
=> print ("Warning: IO error deleting domains on " ^ node ^
".\n")
718 fun cleanupNode (node
, _
) =
722 val domPath
= String.concatWith
"/" (rev (String.fields (fn ch
=> ch
= #
".") dom
))
723 val dname
= OS
.Path
.joinDirFile
{dir
= Config
.resultRoot
,
725 val dname
= OS
.Path
.concat (dname
, domPath
)
727 ignore (OS
.Process
.system (Config
.rm ^
" -rf " ^ dname
))
733 app doNode Config
.nodeIps
;
734 app cleanupNode Config
.nodeIps
737 fun homedirOf uname
=
738 Posix
.SysDB
.Passwd
.home (Posix
.SysDB
.getpwnam uname
)
740 fun homedir () = homedirOf (getUser ())