1 (* HCoop
Domtool (http
://hcoop
.sourceforge
.net
/)
2 * Copyright (c
) 2006-2007, 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
30 fun get_context () = valOf (!ssl_context
)
32 val nodes
= map #
1 Config
.nodeIps
33 val nodeMap
= foldl (fn ((node
, ip
), mp
) => SM
.insert (mp
, node
, ip
))
34 SM
.empty Config
.nodeIps
35 fun nodeIp node
= valOf (SM
.find (nodeMap
, node
))
39 val fakePrivs
= ref
false
40 val isClient
= ref
false
42 val your_doms
= ref SS
.empty
43 fun your_domains () = !your_doms
45 val your_usrs
= ref SS
.empty
46 fun your_users () = !your_usrs
48 val your_grps
= ref SS
.empty
49 fun your_groups () = !your_grps
51 val your_pths
= ref SS
.empty
52 fun your_paths () = !your_pths
54 val your_ipss
= ref SS
.empty
55 fun your_ips () = !your_ipss
57 val world_readable
= SS
.addList (SS
.empty
, Config
.worldReadable
)
58 val readable_pths
= ref world_readable
59 fun readable_paths () = !readable_pths
65 val your_paths
= Acl
.class
{user
= getUser (),
69 your_doms
:= Acl
.class
{user
= getUser (),
71 your_usrs
:= Acl
.class
{user
= getUser (),
73 your_grps
:= Acl
.class
{user
= getUser (),
75 your_pths
:= your_paths
;
76 readable_pths
:= SS
.union (your_paths
, world_readable
);
77 your_ipss
:= Acl
.class
{user
= getUser (),
81 fun declareClient () = isClient
:= true
82 fun fakePrivileges () = if !isClient
then
85 raise Fail
"Tried to fake privileges as non-client"
88 case map
Int.fromString (String.fields (fn ch
=> ch
= #
".") s
) of
89 [SOME n1
, SOME n2
, SOME n3
, SOME n4
] =>
90 n1
>= 0 andalso n1
< 256 andalso n2
>= 0 andalso n2
< 256 andalso n3
>= 0 andalso n3
< 256 andalso n4
>= 0 andalso n4
< 256
93 fun isHexDigit ch
= Char.isDigit ch
orelse (ord ch
>= ord #
"a" andalso ord ch
<= ord #
"f")
97 val fields
= String.fields (fn ch
=> ch
= #
":") s
99 val empties
= foldl (fn ("", n
) => n
+ 1
100 |
(_
, n
) => n
) 0 fields
104 andalso length fields
<= maxLen
106 andalso List.all (fn "" => true
108 andalso CharVector
.all isHexDigit s
) fields
114 val maybeIpv4
= List.last fields
115 val theRest
= List.take (fields
, length fields
- 1)
117 validIp maybeIpv4
andalso noIpv4
6
120 noIpv4
8 orelse hasIpv4 ()
123 fun isIdent ch
= Char.isLower ch
orelse Char.isDigit ch
126 size s
> 0 andalso size s
< 50
127 andalso CharVector
.all (fn ch
=> isIdent ch
orelse ch
= #
"-") s
130 size s
> 0 andalso size s
< 200
131 andalso List.all
validHost (String.fields (fn ch
=> ch
= #
".") s
)
133 fun validNode s
= List.exists (fn s
' => s
= s
') nodes
135 fun yourDomain s
= !fakePrivs
orelse SS
.member (your_domains (), s
)
136 fun yourUser s
= SS
.member (your_users (), s
)
137 fun yourGroup s
= SS
.member (your_groups (), s
)
138 fun checkPath paths path
=
139 (List.all (fn s
=> s
<> "..") (String.fields (fn ch
=> ch
= #
"/") path
)
140 andalso CharVector
.all (fn ch
=> Char.isAlphaNum ch
orelse ch
= #
"." orelse ch
= #
"/"
141 orelse ch
= #
"-" orelse ch
= #
"_") path
142 andalso SS
.exists (fn s
' => path
= s
' orelse String.isPrefix (s
' ^
"/") path
) (paths ()))
143 val yourPath
= checkPath your_paths
144 val readablePath
= checkPath readable_paths
145 fun yourIp s
= !fakePrivs
orelse SS
.member (your_ips (), s
)
147 fun yourDomainHost s
=
151 val (pref
, suf
) = Substring
.splitl (fn ch
=> ch
<> #
".") (Substring
.full s
)
153 Substring
.size suf
> 0
154 andalso validHost (Substring
.string pref
)
155 andalso yourDomain (Substring
.string
156 (Substring
.slice (suf
, 1, NONE
)))
159 val yourDomain
= yourDomainHost
161 fun validUser s
= size s
> 0 andalso size s
< 20
162 andalso CharVector
.all
Char.isAlphaNum s
164 fun validEmailUser s
=
165 size s
> 0 andalso size s
< 50
166 andalso CharVector
.all (fn ch
=> Char.isAlphaNum ch
172 val validGroup
= validUser
174 val _
= Env
.type_one
"no_spaces"
176 (CharVector
.all (fn ch
=> Char.isPrint ch
andalso not (Char.isSpace ch
)
177 andalso ch
<> #
"\"" andalso ch
<> #
"'"))
178 val _
= Env
.type_one
"no_newlines"
180 (CharVector
.all (fn ch
=> Char.isPrint ch
andalso ch
<> #
"\n" andalso ch
<> #
"\r"
181 andalso ch
<> #
"\""))
183 val _
= Env
.type_one
"ip"
187 val _
= Env
.type_one
"ipv6"
191 val _
= Env
.type_one
"host"
195 val _
= Env
.type_one
"domain"
199 val _
= Env
.type_one
"your_domain"
203 val _
= Env
.type_one
"your_domain_host"
207 val _
= Env
.type_one
"user"
211 val _
= Env
.type_one
"group"
215 val _
= Env
.type_one
"your_user"
219 val _
= Env
.type_one
"your_group"
223 val _
= Env
.type_one
"your_path"
227 val _
= Env
.type_one
"readable_path"
231 val _
= Env
.type_one
"your_ip"
235 val _
= Env
.type_one
"node"
239 val _
= Env
.type_one
"mime_type"
241 (CharVector
.exists (fn ch
=> ch
= #
"/"))
243 val _
= Env
.registerFunction ("your_ip_to_ip",
247 val _
= Env
.registerFunction ("dns_node_to_node",
251 val _
= Env
.registerFunction ("mail_node_to_node",
258 val dl
= ErrorMsg
.dummyLoc
260 val _
= Env
.registerFunction ("end_in_slash",
261 fn [(EString
"", _
)] => SOME (EString
"/", dl
)
262 |
[(EString s
, _
)] =>
263 SOME (EString (if String.sub (s
, size s
- 1) = #
"/" then
270 val nsD
= (EString Config
.defaultNs
, dl
)
271 val serialD
= (EVar
"serialAuto", dl
)
272 val refD
= (EInt Config
.defaultRefresh
, dl
)
273 val retD
= (EInt Config
.defaultRetry
, dl
)
274 val expD
= (EInt Config
.defaultExpiry
, dl
)
275 val minD
= (EInt Config
.defaultMinimum
, dl
)
277 val soaD
= multiApp ((EVar
"soa", dl
),
279 [nsD
, serialD
, refD
, retD
, expD
, minD
])
281 val masterD
= (EApp ((EVar
"internalMaster", dl
),
282 (EString Config
.masterNode
, dl
)),
285 val slavesD
= (EList (map (fn s
=> (EString s
, dl
))
286 (List.filter (fn x
=> List.exists (fn y
=> y
= x
) (Config
.dnsNodes_all @ Config
.dnsNodes_admin
)) Config
.slaveNodes
)), dl
)
288 val _
= Defaults
.registerDefault ("Aliases",
289 (TList (TBase
"your_domain", dl
), dl
),
290 (fn () => (EList
[], dl
)))
292 val _
= Defaults
.registerDefault ("Mailbox",
294 (fn () => (EString (getUser ()), dl
)))
296 val _
= Defaults
.registerDefault ("DNS",
297 (TBase
"dnsKind", dl
),
298 (fn () => multiApp ((EVar
"useDns", dl
),
300 [soaD
, masterD
, slavesD
])))
302 val _
= Defaults
.registerDefault ("TTL",
304 (fn () => (EInt Config
.Bind
.defaultTTL
, dl
)))
306 type soa
= {ns
: string,
313 val serial
= fn (EVar
"serialAuto", _
) => SOME NONE
314 |
(EApp ((EVar
"serialConst", _
), n
), _
) => Option
.map
SOME (Env
.int n
)
317 val soa
= fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
318 ((EVar
"soa", _
), ns
), _
),
324 (case (Env
.string ns
, serial sl
, Env
.int rf
,
325 Env
.int ret
, Env
.int exp
, Env
.int min
) of
326 (SOME ns
, SOME sl
, SOME rf
,
327 SOME ret
, SOME exp
, SOME min
) =>
338 ExternalMaster
of string
339 | InternalMaster
of string
343 val _
= Env
.registerFunction ("ip_of_node",
344 fn [(EString node
, _
)] => SOME (EString (nodeIp node
), dl
)
347 val master
= fn (EApp ((EVar
"externalMaster", _
), e
), _
) => Option
.map
ExternalMaster (ip e
)
348 |
(EApp ((EVar
"internalMaster", _
), e
), _
) => Option
.map
InternalMaster (Env
.string e
)
352 UseDns
of {soa
: soa
,
354 slaves
: string list
}
357 val dnsKind
= fn (EApp ((EApp ((EApp
358 ((EVar
"useDns", _
), sa
), _
),
361 (case (soa sa
, master mstr
, Env
.list Env
.string slaves
) of
362 (SOME sa
, SOME mstr
, SOME slaves
) =>
363 SOME (UseDns
{soa
= sa
,
367 |
(EVar
"noDns", _
) => SOME NoDns
370 val befores
= ref (fn (_
: string) => ())
371 val afters
= ref (fn (_
: string) => ())
373 fun registerBefore f
=
377 befores
:= (fn x
=> (old x
; f x
))
380 fun registerAfter f
=
384 afters
:= (fn x
=> (old x
; f x
))
387 val globals
= ref (fn () => ())
388 val locals
= ref (fn () => ())
390 fun registerResetGlobal f
=
394 globals
:= (fn x
=> (old x
; f x
))
397 fun registerResetLocal f
=
401 locals
:= (fn x
=> (old x
; f x
))
404 fun resetGlobal () = (!globals ();
405 ignore (OS
.Process
.system (Config
.rm ^
" -rf " ^ Config
.resultRoot ^
"/*")))
406 fun resetLocal () = !locals ()
409 val currentPath
= ref (fn (_
: string) => "")
410 val currentPathAli
= ref (fn (_
: string, _
: string) => "")
414 fun currentDomain () = !current
416 val currentsAli
= ref ([] : string list
)
418 fun currentAliasDomains () = !currentsAli
419 fun currentDomains () = currentDomain () :: currentAliasDomains ()
421 fun domainFile
{node
, name
} = ((*print ("Opening " ^
!currentPath node ^ name ^
"\n");*)
422 TextIO.openOut (!currentPath node ^ name
))
424 type files
= {write
: string -> unit
,
425 writeDom
: unit
-> unit
,
426 close
: unit
-> unit
}
428 fun domainsFile
{node
, name
} =
430 val doms
= currentDomains ()
431 val files
= map (fn dom
=> (dom
, TextIO.openOut (!currentPathAli (dom
, node
) ^ name
))) doms
433 {write
= fn s
=> app (fn (_
, outf
) => TextIO.output (outf
, s
)) files
,
434 writeDom
= fn () => app (fn (dom
, outf
) => TextIO.output (outf
, dom
)) files
,
435 close
= fn () => app (fn (_
, outf
) => TextIO.closeOut outf
) files
}
440 val toks
= String.fields (fn ch
=> ch
= #
".") domain
442 val elems
= foldr (fn (piece
, elems
) =>
444 val elems
= piece
:: elems
448 val path
= String.concatWith
"/"
449 (Config
.resultRoot
:: node
:: rev elems
)
450 val tmpPath
= String.concatWith
"/"
451 (Config
.tmpDir
:: node
:: rev elems
)
453 (if Posix
.FileSys
.ST
.isDir
454 (Posix
.FileSys
.stat path
) then
457 (OS
.FileSys
.remove path
;
458 OS
.FileSys
.mkDir path
))
459 handle OS
.SysErr _
=> OS
.FileSys
.mkDir path
;
461 (if Posix
.FileSys
.ST
.isDir
462 (Posix
.FileSys
.stat tmpPath
) then
465 (OS
.FileSys
.remove tmpPath
;
466 OS
.FileSys
.mkDir tmpPath
))
467 handle OS
.SysErr _
=> OS
.FileSys
.mkDir tmpPath
474 fn (root
, site
) => String.concatWith
"/" (root
:: site
:: rev ("" :: elems
))
477 datatype file_action
' =
478 Add
' of {src
: string, dst
: string}
480 | Modify
' of {src
: string, dst
: string}
482 fun findDiffs (prefixes
, site
, dom
, acts
) =
485 val realPath
= gp (Config
.resultRoot
, site
)
486 val tmpPath
= gp (Config
.tmpDir
, site
)
488 (*val _
= print ("getDiffs(" ^ site ^
", " ^ dom ^
")... " ^ realPath ^
"; " ^ tmpPath ^
"\n")*)
490 val dir
= Posix
.FileSys
.opendir realPath
493 case Posix
.FileSys
.readdir dir
of
494 NONE
=> (Posix
.FileSys
.closedir dir
;
498 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
500 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
503 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat
real) then
505 else if Posix
.FileSys
.access (tmp
, []) then
506 if Slave
.shell
[Config
.diff
, " ", real, " ", tmp
] then
509 loopReal ((site
, dom
, realPath
, Modify
' {src
= tmp
, dst
= real}) :: acts
)
510 else if List.exists (fn prefix
=> String.isPrefix prefix
real) prefixes
then
511 loopReal ((site
, dom
, realPath
, Delete
' real) :: acts
)
516 val acts
= loopReal acts
518 val dir
= Posix
.FileSys
.opendir tmpPath
521 case Posix
.FileSys
.readdir dir
of
522 NONE
=> (Posix
.FileSys
.closedir dir
;
526 val real = OS
.Path
.joinDirFile
{dir
= realPath
,
528 val tmp
= OS
.Path
.joinDirFile
{dir
= tmpPath
,
531 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat tmp
) then
533 else if Posix
.FileSys
.access (real, []) then
536 loopTmp ((site
, dom
, realPath
, Add
' {src
= tmp
, dst
= real}) :: acts
)
539 val acts
= loopTmp acts
544 fun findAllDiffs prefixes
=
546 val dir
= Posix
.FileSys
.opendir Config
.tmpDir
547 val len
= length (String.fields (fn ch
=> ch
= #
"/") Config
.tmpDir
) + 1
549 fun exploreSites diffs
=
550 case Posix
.FileSys
.readdir dir
of
554 fun explore (dname
, diffs
) =
556 val dir
= Posix
.FileSys
.opendir dname
559 case Posix
.FileSys
.readdir dir
of
563 val fname
= OS
.Path
.joinDirFile
{dir
= dname
,
566 loop (if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat fname
) then
568 val dom
= String.fields (fn ch
=> ch
= #
"/") fname
569 val dom
= List.drop (dom
, len
)
570 val dom
= String.concatWith
"." (rev dom
)
572 val dname
' = OS
.Path
.joinDirFile
{dir
= dname
,
576 findDiffs (prefixes
, site
, dom
, diffs
))
583 before Posix
.FileSys
.closedir dir
586 exploreSites (explore (OS
.Path
.joinDirFile
{dir
= Config
.tmpDir
,
587 file
= site
}, diffs
))
591 before Posix
.FileSys
.closedir dir
594 val masterNode
: string option ref
= ref NONE
595 fun dnsMaster () = !masterNode
597 val seenDomains
: string list ref
= ref
[]
599 val _
= Env
.containerV_one
"domain"
600 ("domain", Env
.string)
603 val () = seenDomains
:= dom
:: !seenDomains
605 val kind
= Env
.env
dnsKind (evs
, "DNS")
606 val ttl
= Env
.env Env
.int (evs
, "TTL")
607 val aliases
= Env
.env (Env
.list Env
.string) (evs
, "Aliases")
609 val path
= getPath dom
611 val () = (current
:= dom
;
612 currentsAli
:= Slave
.remove (Slave
.removeDups aliases
, dom
);
613 currentPath
:= (fn site
=> path (Config
.tmpDir
, site
));
614 currentPathAli
:= (fn (dom
, site
) => getPath
dom (Config
.tmpDir
, site
)))
616 fun saveSoa (kind
, soa
: soa
) node
=
618 val {write
, writeDom
, close
} = domainsFile
{node
= node
, name
= "soa.conf"}
622 write (Int.toString ttl
);
628 | SOME n
=> write (Int.toString n
);
630 write (Int.toString (#ref soa
));
632 write (Int.toString (#ret soa
));
634 write (Int.toString (#exp soa
));
636 write (Int.toString (#min soa
));
641 fun saveNamed (kind
, soa
: soa
, masterIp
, slaveIps
) node
=
642 if dom
= "localhost" then
645 val {write
, writeDom
, close
} = domainsFile
{node
= node
, name
= "named.conf"}
649 write
"\" {\n\ttype ";
651 write
";\n\tfile \"";
652 write Config
.Bind
.zonePath_real
;
657 "master" => (write
"\tallow-transfer {\n";
658 app (fn ip
=> (write
"\t\t";
660 write
";\n")) slaveIps
;
662 | _
=> (write
"\tmasters { ";
665 write
"// Updated: ";
666 write (Time
.toString (Time
.now ()));
673 NoDns
=> masterNode
:= NONE
678 InternalMaster node
=> nodeIp node
679 | ExternalMaster ip
=> ip
681 val slaveIps
= map
nodeIp (#slaves dns
)
683 app (saveSoa ("slave", #soa dns
)) (#slaves dns
);
684 app (saveNamed ("slave", #soa dns
, masterIp
, slaveIps
)) (#slaves dns
);
686 InternalMaster node
=>
687 (masterNode
:= SOME node
;
688 saveSoa ("master", #soa dns
) node
;
689 saveNamed ("master", #soa dns
, masterIp
, slaveIps
) node
)
690 | _
=> masterNode
:= NONE
694 fn () => !afters (!current
))
696 val () = Env
.registerPre (fn () => (seenDomains
:= [];
697 ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, ""],
698 fn cl
=> "Temp file cleanup failed: " ^ cl
));
699 OS
.FileSys
.mkDir Config
.tmpDir
;
700 app (fn node
=> OS
.FileSys
.mkDir
701 (OS
.Path
.joinDirFile
{dir
= Config
.tmpDir
,
704 app (fn node
=> OS
.FileSys
.mkDir
705 (OS
.Path
.joinDirFile
{dir
= Config
.resultRoot
,
707 handle OS
.SysErr _
=> ())
710 fun handleSite (site
, files
) =
714 print ("New configuration for node " ^ site ^
"\n");
715 if site
= Config
.defaultNode
then
716 Slave
.handleChanges files
718 val bio
= OpenSSL
.connect
true (valOf (!ssl_context
),
721 ^
Int.toString Config
.slavePort
)
723 app (fn file
=> Msg
.send (bio
, MsgFile file
)) files
;
724 Msg
.send (bio
, MsgDoFiles
);
726 NONE
=> print
"Slave closed connection unexpectedly\n"
729 MsgOk
=> print ("Slave " ^ site ^
" finished\n")
730 | MsgError s
=> print ("Slave " ^ site
731 ^
" returned error: " ^
733 | _
=> print ("Slave " ^ site
734 ^
" returned unexpected command\n");
739 val () = Env
.registerPost (fn () =>
741 val prefixes
= List.concat
744 val pieces
= String.tokens (fn ch
=> ch
= #
".") dom
745 val path
= String.concatWith
"/" (rev pieces
)
748 Config
.resultRoot ^
"/" ^ node ^
"/" ^ path ^
"/")
752 val diffs
= findAllDiffs prefixes
754 val diffs
= map (fn (site
, dom
, dir
, Add
' {src
, dst
}) =>
755 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
756 fn cl
=> "Copy failed: " ^ cl
);
762 |
(site
, dom
, dir
, Delete
' dst
) =>
763 (OS
.FileSys
.remove dst
764 handle OS
.SysErr _
=>
765 ErrorMsg
.error
NONE ("Delete failed for " ^ dst
);
767 {action
= Slave
.Delete
true,
771 |
(site
, dom
, dir
, Modify
' {src
, dst
}) =>
772 (Slave
.shellF ([Config
.cp
, " ", src
, " ", dst
],
773 fn cl
=> "Copy failed: " ^ cl
);
775 {action
= Slave
.Modify
,
780 if !ErrorMsg
.anyErrors
then
783 val changed
= foldl (fn ((site
, file
), changed
) =>
785 val ls
= case SM
.find (changed
, site
) of
789 SM
.insert (changed
, site
, file
:: ls
)
792 SM
.appi handleSite changed
794 ignore (Slave
.shellF ([Config
.rm
, " -rf ", Config
.tmpDir
, ""],
795 fn cl
=> "Temp file cleanup failed: " ^ cl
))
798 fun hasPriv priv
= Acl
.query
{user
= getUser (), class
= "priv", value
= "all"}
799 orelse Acl
.query
{user
= getUser (), class
= "priv", value
= priv
}
801 val _
= Env
.type_one
"dns_node"
804 List.exists (fn x
=> x
= node
) Config
.dnsNodes_all
805 orelse (hasPriv
"dns"
806 andalso List.exists (fn x
=> x
= node
) Config
.dnsNodes_admin
))
808 val _
= Env
.type_one
"mail_node"
811 List.exists (fn x
=> x
= node
) Config
.mailNodes_all
812 orelse (hasPriv
"mail"
813 andalso List.exists (fn x
=> x
= node
) Config
.mailNodes_admin
))
815 fun rmdom
' delete resultRoot doms
=
817 fun doNode (node
, _
) =
819 val dname
= OS
.Path
.joinDirFile
{dir
= resultRoot
,
822 fun doDom (dom
, actions
) =
824 val domPath
= String.concatWith
"/" (rev (String.fields (fn ch
=> ch
= #
".") dom
))
825 val dname
= OS
.Path
.concat (dname
, domPath
)
827 fun visitDom (dom
, dname
, actions
) =
829 val dir
= Posix
.FileSys
.opendir dname
832 case Posix
.FileSys
.readdir dir
of
836 val fnameFull
= OS
.Path
.joinDirFile
{dir
= dname
,
839 if Posix
.FileSys
.ST
.isDir (Posix
.FileSys
.stat fnameFull
) then
840 loop (visitDom (fname ^
"." ^ dom
,
844 loop ({action
= Slave
.Delete delete
,
847 file
= fnameFull
} :: actions
)
851 before Posix
.FileSys
.closedir dir
853 handle OS
.SysErr (s
, _
) =>
854 (print ("Warning: System error deleting domain " ^ dom ^
" on " ^ node ^
": " ^ s ^
"\n");
857 visitDom (dom
, dname
, actions
)
860 val actions
= foldl doDom
[] doms
862 handleSite (node
, actions
)
864 handle IO
.Io _
=> print ("Warning: IO error deleting domains on " ^ node ^
".\n")
866 fun cleanupNode (node
, _
) =
870 val domPath
= String.concatWith
"/" (rev (String.fields (fn ch
=> ch
= #
".") dom
))
871 val dname
= OS
.Path
.joinDirFile
{dir
= resultRoot
,
873 val dname
= OS
.Path
.concat (dname
, domPath
)
876 ignore (OS
.Process
.system (Config
.rm ^
" -rf " ^ dname
))
884 app doNode Config
.nodeIps
;
885 app cleanupNode Config
.nodeIps
888 val rmdom
= rmdom
' true Config
.resultRoot
889 val rmdom
' = rmdom
' false
891 fun homedirOf uname
=
892 Posix
.SysDB
.Passwd
.home (Posix
.SysDB
.getpwnam uname
)
894 fun homedir () = homedirOf (getUser ())
896 type subject
= {node
: string, domain
: string}
898 val describers
: (subject
-> string) list ref
= ref
[]
900 fun registerDescriber f
= describers
:= f
:: !describers
902 fun describeOne arg
= String.concat (map (fn f
=> f arg
) (rev (!describers
)))
904 val line
= "--------------------------------------------------------------\n"
905 val dline
= "==============================================================\n"
908 String.concat (List.mapPartial
910 case describeOne
{node
= node
, domain
= dom
} of
913 SOME (String.concat
[dline
, "Node ", node
, "\n", dline
, "\n", s
]))
916 datatype description
=
917 Filename
of { filename
: string, heading
: string, showEmpty
: bool }
918 | Extension
of { extension
: string, heading
: string -> string }
920 fun considerAll ds
{node
, domain
} =
922 val ds
= map (fn d
=> (d
, ref
[])) ds
924 val path
= Config
.resultRoot
925 val jdf
= OS
.Path
.joinDirFile
926 val path
= jdf
{dir
= path
, file
= node
}
927 val path
= foldr (fn (more
, path
) => jdf
{dir
= path
, file
= more
})
928 path (String.tokens (fn ch
=> ch
= #
".") domain
)
930 if Posix
.FileSys
.access (path
, []) then
932 val dir
= Posix
.FileSys
.opendir path
935 case Posix
.FileSys
.readdir dir
of
938 (app (fn (d
, entries
) =>
940 fun readFile showEmpty entries
' =
942 val fname
= OS
.Path
.joinDirFile
{dir
= path
,
945 val inf
= TextIO.openIn fname
947 fun loop (seenOne
, entries
') =
948 case TextIO.inputLine inf
of
949 NONE
=> if seenOne
orelse showEmpty
then
953 | SOME line
=> loop (true, line
:: entries
')
955 loop (false, entries
')
956 before TextIO.closeIn inf
960 Filename
{filename
, heading
, showEmpty
} =>
961 if fname
= filename
then
962 entries
:= readFile
showEmpty ("\n" :: line
:: "\n" :: heading
:: line
:: !entries
)
965 | Extension
{extension
, heading
} =>
967 val {base
, ext
} = OS
.Path
.splitBaseExt fname
972 if extension
' = extension
then
973 entries
:= readFile
true ("\n" :: line
:: "\n" :: heading base
:: line
:: !entries
)
981 Posix
.FileSys
.closedir dir
;
982 String.concat (List.concat (map (fn (_
, entries
) => rev (!entries
)) ds
))
988 val () = registerDescriber (considerAll
[Filename
{filename
= "soa.conf",
989 heading
= "DNS SOA:",
992 val () = Env
.registerAction ("domainHost",
993 fn (env
, [(EString host
, _
)]) =>
994 SM
.insert (env
, "Hostname",
995 (EString (host ^
"." ^
currentDomain ()), dl
))
996 |
(_
, args
) => Env
.badArgs ("domainHost", args
))
998 val ouc
= ref (fn () => ())
1000 fun registerOnUsersChange f
=
1004 ouc
:= (fn () => (f
' (); f ()))
1007 fun onUsersChange () = !ouc ()