src/plugins/bind.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   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.
   8  *
   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.
  13  *
  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.
  17  *)
  18
  19 (* BIND DNS *)
  20
  21 structure Bind :> BIND = struct
  22
  23 open Ast
  24
  25 val namedChanged = ref false
  26 val zoneChanged = ref false
  27
  28 val didDomain = ref ""
  29
  30 val () = Slave.registerPreHandler (fn () => (namedChanged := false;
  31                                              zoneChanged := false;
  32                                              didDomain := ""))
  33
  34 val dns : Domain.files option ref = ref NONE
  35
  36 val _ = Domain.registerBefore
  37             (fn _ => dns := Option.map (fn node => Domain.domainsFile {node = node,
  38                                                                        name = "dns.conf"})
  39                                        (Domain.dnsMaster ()))
  40
  41 val _ = Domain.registerAfter
  42             (fn _ => (Option.app (fn files => #close files ()) (!dns);
  43                       dns := NONE))
  44
  45 val dl = ErrorMsg.dummyLoc
  46
  47 datatype host =
  48          Literal of string
  49        | Wildcard
  50        | Default
  51
  52 datatype dns_record =
  53          A of host * string
  54        | CNAME of host * string
  55        | MX of int * string
  56        | NS of string
  57        | AAAA of host * string
  58        | TXT of host * string
  59        | AFSDB of string
  60        | SRV of host * int * int * int * string
  61
  62 fun hostS (Literal s) = s ^ "."
  63   | hostS Wildcard = "*."
  64   | hostS Default = ""
  65
  66 val host = fn (EApp ((EVar "literal", _), e), _) =>
  67               Option.map Literal (Env.string e)
  68             | (EVar "wildcard", _) =>
  69               SOME Wildcard
  70             | (EVar "default", _) =>
  71               SOME Default
  72             | _ => NONE
  73
  74 val srv_host = fn (EApp ((EVar "srv_literal", _), e), _) =>
  75                   Option.map Literal (Env.string e)
  76                 | (EVar "srv_wildcard", _) =>
  77                   SOME Wildcard
  78                 | (EVar "srv_default", _) =>
  79                   SOME Default
  80                 | _ => NONE
  81
  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))
  85                    | _ => NONE)
  86               | (EApp ((EApp ((EVar "dnsCNAME", _), e1), _), e2), _) =>
  87                 (case (host e1, Env.string e2) of
  88                      (SOME v1, SOME v2) => SOME (CNAME (v1, v2))
  89                    | _ => NONE)
  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))
  93                    | _ => NONE)
  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))
  99                    | _ => NONE)
 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))
 103                    | _ => NONE)
 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))
 109                    | _ => NONE)
 110               | _ => NONE
 111
 112 fun writeRecord (evs, r) =
 113     case !dns of
 114         NONE => () (* print ("Warning: DNS directive for " ^ Domain.currentDomain ()
 115                        ^ " ignored because no master DNS server is configured for this domain\n") *)
 116       | SOME files =>
 117         let
 118             fun write s = #write files s
 119             fun writeDom () = #writeDom files ()
 120             val ttl = Env.env Env.int (evs, "TTL")
 121         in
 122             case r of
 123                 A (from, to) => (write (hostS from);
 124                                  writeDom ();
 125                                  write ".\t";
 126                                  write (Int.toString ttl);
 127                                  write "\tIN\tA\t";
 128                                  write to;
 129                                  write "\n")
 130               | CNAME (from, to) => (write (hostS from);
 131                                      writeDom ();
 132                                      write ".\t";
 133                                      write (Int.toString ttl);
 134                                      write "\tIN\tCNAME\t";
 135                                      write to;
 136                                      write ".\n")
 137               | MX (num, host) => (writeDom ();
 138                                    write ".\t";
 139                                    write (Int.toString ttl);
 140                                    write "\tIN\tMX\t";
 141                                    write (Int.toString num);
 142                                    write "\t";
 143                                    write host;
 144                                    write ".\n")
 145               | NS host => (writeDom ();
 146                             write ".\t";
 147                             write (Int.toString ttl);
 148                             write "\tIN\tNS\t";
 149                             write host;
 150                             write ".\n")
 151               | AAAA (from, to) => (write (hostS from);
 152                                     writeDom ();
 153                                     write ".\t";
 154                                     write (Int.toString ttl);
 155                                     write "\tIN\tAAAA\t";
 156                                     write to;
 157                                     write "\n")
 158               | TXT (from, to) => (write (hostS from);
 159                                    writeDom ();
 160                                    write ".\t";
 161                                    write (Int.toString ttl);
 162                                    write "\tIN\tTXT\t\"";
 163                                    write (String.translate (fn #"\"" => "\\\"" | ch => str ch) to);
 164                                    write "\"\n")
 165               | AFSDB host => (writeDom ();
 166                                write ".\t";
 167                                write (Int.toString ttl);
 168                                write "\tIN\tAFSDB\t";
 169                                write "1";
 170                                write "\t";
 171                                write host;
 172                                write ".\n")
 173               | SRV (from, priority, weight, port, to) => (write (hostS from);
 174                                                            writeDom ();
 175                                                            write ".\t";
 176                                                            write (Int.toString ttl);
 177                                                            write "\tIN\tSRV\t";
 178                                                            write (Int.toString priority);
 179                                                            write "\t";
 180                                                            write (Int.toString weight);
 181                                                            write "\t";
 182                                                            write (Int.toString port);
 183                                                            write "\t";
 184                                                            write to;
 185                                                            write ".\n")
 186         end
 187
 188 val () = Env.actionV_one "dns"
 189                          ("record", record)
 190                          writeRecord
 191
 192 fun readLine inf =
 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)
 196
 197 fun readILine inf = valOf (Int.fromString (readLine inf))
 198
 199 val monthToInt = fn Date.Jan => 1
 200                   | Date.Feb => 2
 201                   | Date.Mar => 3
 202                   | Date.Apr => 4
 203                   | Date.May => 5
 204                   | Date.Jun => 6
 205                   | Date.Jul => 7
 206                   | Date.Aug => 8
 207                   | Date.Sep => 9
 208                   | Date.Oct => 10
 209                   | Date.Nov => 11
 210                   | Date.Dec => 12
 211
 212 fun padBy ch amt s =
 213     if size s < amt then
 214         CharVector.tabulate (amt - size s, fn _ => ch) ^ s
 215     else
 216         s
 217
 218 fun dateString () =
 219     let
 220         val date = Date.fromTimeUniv (Time.now ())
 221     in
 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))
 225     end
 226
 227 val () = Slave.registerFileHandler (fn fs =>
 228                                        let
 229                                            val {dir, file} = OS.Path.splitDirFile (#file fs)
 230
 231                                            fun dnsChanged () =
 232                                                if #domain fs = !didDomain orelse Slave.hostname () <> Config.Bind.masterNode then
 233                                                    ()
 234                                                else if Slave.isDelete (#action fs) then
 235                                                    let
 236                                                        val fname = OS.Path.joinBaseExt {base = #domain fs,
 237                                                                                         ext = SOME "zone"}
 238                                                        val fname = OS.Path.joinDirFile {dir = Config.Bind.zonePath,
 239                                                                                         file = fname}
 240                                                    in
 241                                                        Slave.shellF ([Config.rm, " -f ", fname],
 242                                                                   fn cl => "Error deleting file: " ^ cl)
 243                                                    end
 244                                                else
 245                                                    let
 246                                                        val inf = TextIO.openIn (OS.Path.joinDirFile {dir = #dir fs,
 247                                                                                                      file = "soa.conf"})
 248                                                        val kind = readLine inf
 249                                                        val ttl = readILine inf
 250                                                        val ns = readLine inf
 251                                                        val serial = case readLine inf of
 252                                                                         "" => NONE
 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
 259
 260                                                        val serialPath = OS.Path.joinDirFile {dir = Config.serialDir,
 261                                                                                              file = #domain fs}
 262
 263                                                        val oldSerial = let
 264                                                            val inf = TextIO.openIn serialPath
 265                                                        in
 266                                                            SOME (readLine inf)
 267                                                            before TextIO.closeIn inf
 268                                                        end handle IO.Io {name, ...} => NONE
 269
 270                                                        val newSerial =
 271                                                            case serial of
 272                                                                SOME n => Int.toString n
 273                                                              | NONE =>
 274                                                                let
 275                                                                    val prefix = dateString ()
 276                                                                in
 277                                                                    prefix
 278                                                                    ^ (case oldSerial of
 279                                                                           NONE => "00"
 280                                                                         | SOME old =>
 281                                                                           if size old >= 8 andalso
 282                                                                              String.substring (old, 0, 8) = prefix then
 283                                                                               case Int.fromString (String.extract (old, 8, NONE)) of
 284                                                                                   NONE => "00"
 285                                                                                 | SOME old => padBy #"0" 2 (Int.toString (old+1))
 286                                                                           else
 287                                                                               "00")
 288                                                                end
 289
 290                                                        val outf = TextIO.openOut serialPath
 291                                                        val _ = TextIO.output (outf, newSerial)
 292                                                        val _ = TextIO.closeOut outf
 293
 294                                                        val dns = OS.Path.joinDirFile {dir = #dir fs,
 295                                                                                       file = "dns.conf"}
 296
 297                                                        val fname = OS.Path.joinBaseExt {base = #domain fs,
 298                                                                                         ext = SOME "zone"}
 299                                                        val fname = OS.Path.joinDirFile {dir = Config.Bind.zonePath,
 300                                                                                         file = fname}
 301
 302                                                        val outf = TextIO.openOut fname
 303                                                    in
 304                                                        zoneChanged := true;
 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)
 326                                                        else
 327                                                            ();
 328                                                        didDomain := #domain fs
 329                                                    end
 330                                        in
 331                                            case file of
 332                                                "soa.conf" => dnsChanged ()
 333                                              | "dns.conf" => dnsChanged ()
 334                                              | "named.conf" => namedChanged := true
 335                                              | _ => ()
 336                                        end)
 337
 338 val () = Slave.registerPostHandler
 339              (fn () =>
 340                  (if !namedChanged then
 341                       Slave.concatTo (fn s => s = "named.conf") Config.Bind.namedConf
 342                   else
 343                      ();
 344                   if !namedChanged orelse !zoneChanged then
 345                       Slave.shellF ([Config.Bind.reload],
 346                                  fn cl => "Error reloading bind with " ^ cl)
 347                   else
 348                       ()))
 349
 350 val () = Domain.registerResetLocal (fn () =>
 351                                        ignore (OS.Process.system (Config.rm ^ " -rf /var/domtool/zones/*")))
 352
 353 val () = Domain.registerDescriber (Domain.considerAll
 354                                    [Domain.Filename {filename = "named.conf",
 355                                                      heading = "named.conf addition:",
 356                                                      showEmpty = false},
 357                                     Domain.Filename {filename = "dns.conf",
 358                                                      heading = "DNS zonefile contents:",
 359                                                      showEmpty = false}])
 360
 361 fun validSrvHost s =
 362     size s > 0 andalso size s < 20
 363     andalso CharVector.all (fn ch => Domain.isIdent ch orelse ch = #"-" orelse ch = #"_") s
 364
 365 fun validSrvDomain s =
 366     size s > 0 andalso size s < 100
 367     andalso List.all validSrvHost (String.fields (fn ch => ch = #".") s)
 368
 369 val _ = Env.type_one "srv_host"
 370         Env.string
 371         validSrvHost
 372
 373 val _ = Env.type_one "srv_domain"
 374         Env.string
 375         validSrvDomain
 376
 377 end