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
.
21 structure Bind
:> BIND
= struct
25 val namedChanged
= ref
false
26 val zoneChanged
= ref
false
28 val didDomain
= ref
""
30 val () = Slave
.registerPreHandler (fn () => (namedChanged
:= false;
34 val dns
: Domain
.files option ref
= ref NONE
36 val _
= Domain
.registerBefore
37 (fn _
=> dns
:= Option
.map (fn node
=> Domain
.domainsFile
{node
= node
,
39 (Domain
.dnsMaster ()))
41 val _
= Domain
.registerAfter
42 (fn _
=> (Option
.app (fn files
=> #close
files ()) (!dns
);
45 val dl
= ErrorMsg
.dummyLoc
54 | CNAME
of host
* string
57 | AAAA
of host
* string
58 | TXT
of host
* string
60 | SRV
of host
* int * int * int * string
62 fun hostS (Literal s
) = s ^
"."
63 | hostS Wildcard
= "*."
66 val host
= fn (EApp ((EVar
"literal", _
), e
), _
) =>
67 Option
.map
Literal (Env
.string e
)
68 |
(EVar
"wildcard", _
) =>
70 |
(EVar
"default", _
) =>
74 val srv_host
= fn (EApp ((EVar
"srv_literal", _
), e
), _
) =>
75 Option
.map
Literal (Env
.string e
)
76 |
(EVar
"srv_wildcard", _
) =>
78 |
(EVar
"srv_default", _
) =>
82 val record
= fn (EApp ((EApp ((EVar
"dnsA", _
), e1
), _
), e2
), _
) =>
83 (case (host e1
, Domain
.ip e2
) of
84 (SOME v1
, SOME v2
) => SOME (A (v1
, v2
))
86 |
(EApp ((EApp ((EVar
"dnsCNAME", _
), e1
), _
), e2
), _
) =>
87 (case (host e1
, Env
.string e2
) of
88 (SOME v1
, SOME v2
) => SOME (CNAME (v1
, v2
))
90 |
(EApp ((EApp ((EVar
"dnsMX", _
), e1
), _
), e2
), _
) =>
91 (case (Env
.int e1
, Env
.string e2
) of
92 (SOME v1
, SOME v2
) => SOME (MX (v1
, v2
))
94 |
(EApp ((EVar
"dnsNS", _
), e
), _
) =>
95 Option
.map
NS (Env
.string e
)
96 |
(EApp ((EApp ((EVar
"dnsAAAA", _
), e1
), _
), e2
), _
) =>
97 (case (host e1
, Env
.string e2
) of
98 (SOME v1
, SOME v2
) => SOME (AAAA (v1
, v2
))
100 |
(EApp ((EApp ((EVar
"dnsTXT", _
), e1
), _
), e2
), _
) =>
101 (case (srv_host e1
, Env
.string e2
) of
102 (SOME v1
, SOME v2
) => SOME (TXT (v1
, v2
))
104 |
(EApp ((EVar
"dnsAFSDB", _
), e
), _
) =>
105 Option
.map
AFSDB (Env
.string e
)
106 |
(EApp ((EApp ((EApp ((EApp ((EApp ((EVar
"dnsSRV", _
), e1
), _
), e2
), _
), e3
), _
), e4
), _
), e5
), _
) =>
107 (case (srv_host e1
, Env
.int e2
, Env
.int e3
, Env
.int e4
, Env
.string e5
) of
108 (SOME v1
, SOME v2
, SOME v3
, SOME v4
, SOME v5
) => SOME (SRV (v1
, v2
, v3
, v4
, v5
))
112 fun writeRecord (evs
, r
) =
114 NONE
=> () (* print ("Warning: DNS directive for " ^ Domain
.currentDomain ()
115 ^
" ignored because no master DNS server is configured for this domain\n") *)
118 fun write s
= #write files s
119 fun writeDom () = #writeDom
files ()
120 val ttl
= Env
.env Env
.int (evs
, "TTL")
123 A (from
, to
) => (write (hostS from
);
126 write (Int.toString ttl
);
130 |
CNAME (from
, to
) => (write (hostS from
);
133 write (Int.toString ttl
);
134 write
"\tIN\tCNAME\t";
137 |
MX (num
, host
) => (writeDom ();
139 write (Int.toString ttl
);
141 write (Int.toString num
);
145 | NS host
=> (writeDom ();
147 write (Int.toString ttl
);
151 |
AAAA (from
, to
) => (write (hostS from
);
154 write (Int.toString ttl
);
155 write
"\tIN\tAAAA\t";
158 |
TXT (from
, to
) => (write (hostS from
);
161 write (Int.toString ttl
);
162 write
"\tIN\tTXT\t\"";
163 write (String.translate (fn #
"\"" => "\\\"" | ch
=> str ch
) to
);
165 | AFSDB host
=> (writeDom ();
167 write (Int.toString ttl
);
168 write
"\tIN\tAFSDB\t";
173 |
SRV (from
, priority
, weight
, port
, to
) => (write (hostS from
);
176 write (Int.toString ttl
);
178 write (Int.toString priority
);
180 write (Int.toString weight
);
182 write (Int.toString port
);
188 val () = Env
.actionV_one
"dns"
193 case TextIO.inputLine inf
of
194 NONE
=> raise Fail
"Expected a line for BIND"
195 | SOME s
=> String.substring (s
, 0, size s
- 1)
197 fun readILine inf
= valOf (Int.fromString (readLine inf
))
199 val monthToInt
= fn Date
.Jan
=> 1
214 CharVector
.tabulate (amt
- size s
, fn _
=> ch
) ^ s
220 val date
= Date
.fromTimeUniv (Time
.now ())
222 padBy #
"0" 4 (Int.toString (Date
.year date
))
223 ^ padBy #
"0" 2 (Int.toString (monthToInt (Date
.month date
)))
224 ^ padBy #
"0" 2 (Int.toString (Date
.day date
))
227 val () = Slave
.registerFileHandler (fn fs
=>
229 val {dir
, file
} = OS
.Path
.splitDirFile (#file fs
)
232 if #domain fs
= !didDomain
then
234 else if Slave
.isDelete (#action fs
) then
236 val fname
= OS
.Path
.joinBaseExt
{base
= #domain fs
,
238 val fname
= OS
.Path
.joinDirFile
{dir
= Config
.Bind
.zonePath
,
241 Slave
.shellF ([Config
.rm
, " -f ", fname
],
242 fn cl
=> "Error deleting file: " ^ cl
)
246 val inf
= TextIO.openIn (OS
.Path
.joinDirFile
{dir
= #dir fs
,
248 val kind
= readLine inf
249 val ttl
= readILine inf
250 val ns
= readLine inf
251 val serial
= case readLine inf
of
253 | s
=> Int.fromString s
254 val rf
= readILine inf
255 val ret
= readILine inf
256 val exp
= readILine inf
257 val min
= readILine inf
258 val () = TextIO.closeIn inf
260 val serialPath
= OS
.Path
.joinDirFile
{dir
= Config
.Bind
.serialDir
,
264 val inf
= TextIO.openIn serialPath
267 before TextIO.closeIn inf
268 end handle IO
.Io
{name
, ...} => NONE
272 SOME n
=> Int.toString n
275 val prefix
= dateString ()
281 if size old
>= 8 andalso
282 String.substring (old
, 0, 8) = prefix
then
283 case Int.fromString (String.extract (old
, 8, NONE
)) of
285 | SOME old
=> padBy #
"0" 2 (Int.toString (old
+1))
290 val outf
= TextIO.openOut serialPath
291 val _
= TextIO.output (outf
, newSerial
)
292 val _
= TextIO.closeOut outf
294 val dns
= OS
.Path
.joinDirFile
{dir
= #dir fs
,
297 val fname
= OS
.Path
.joinBaseExt
{base
= #domain fs
,
299 val fname
= OS
.Path
.joinDirFile
{dir
= Config
.Bind
.zonePath
,
302 val outf
= TextIO.openOut fname
305 TextIO.output (outf
, "$TTL ");
306 TextIO.output (outf
, Int.toString ttl
);
307 TextIO.output (outf
, "\n\n@\tIN\tSOA\t");
308 TextIO.output (outf
, ns
);
309 TextIO.output (outf
, ".\thostmaster.");
310 TextIO.output (outf
, #domain fs
);
311 TextIO.output (outf
, ". ( ");
312 TextIO.output (outf
, newSerial
);
313 TextIO.output (outf
, " ");
314 TextIO.output (outf
, Int.toString rf
);
315 TextIO.output (outf
, " ");
316 TextIO.output (outf
, Int.toString ret
);
317 TextIO.output (outf
, " ");
318 TextIO.output (outf
, Int.toString exp
);
319 TextIO.output (outf
, " ");
320 TextIO.output (outf
, Int.toString min
);
321 TextIO.output (outf
, " )\n\n");
322 TextIO.closeOut outf
;
323 if Posix
.FileSys
.access (dns
, []) then
324 Slave
.shellF ([Config
.cat
, " ", dns
, " >>", fname
],
325 fn cl
=> "Error concatenating file: " ^ cl
)
328 didDomain
:= #domain fs
332 "soa.conf" => dnsChanged ()
333 |
"dns.conf" => dnsChanged ()
334 |
"named.conf" => namedChanged
:= true
338 val () = Slave
.registerPostHandler
340 (if !namedChanged
then
341 Slave
.concatTo (fn s
=> s
= "named.conf") Config
.Bind
.namedConf
344 if !namedChanged
orelse !zoneChanged
then
345 Slave
.shellF ([Config
.Bind
.reload
],
346 fn cl
=> "Error reloading bind with " ^ cl
)
350 val () = Domain
.registerResetLocal (fn () =>
351 ignore (OS
.Process
.system (Config
.rm ^
" -rf " ^ Config
.Bind
.zonePath ^
"/*")))
353 val () = Domain
.registerDescriber (Domain
.considerAll
354 [Domain
.Filename
{filename
= "named.conf",
355 heading
= "named.conf addition:",
357 Domain
.Filename
{filename
= "dns.conf",
358 heading
= "DNS zonefile contents:",
362 size s
> 0 andalso size s
< 20
363 andalso CharVector
.all (fn ch
=> Domain
.isIdent ch
orelse ch
= #
"-" orelse ch
= #
"_") s
365 fun validSrvDomain s
=
366 size s
> 0 andalso size s
< 100
367 andalso List.all
validSrvHost (String.fields (fn ch
=> ch
= #
".") s
)
369 val _
= Env
.type_one
"srv_host"
373 val _
= Env
.type_one
"srv_domain"