src/djbdns/djbdns.sml

   1 (*
   2 Domtool (http://hcoop.sf.net/)
   3 Copyright (C) 2004  Adam Chlipala
   4
   5 This program is free software; you can redistribute it and/or
   6 modify it under the terms of the GNU General Public License
   7 as published by the Free Software Foundation; either version 2
   8 of the License, or (at your option) any later version.
   9
  10 This program is distributed in the hope that it will be useful,
  11 but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 GNU General Public License for more details.
  14
  15 You should have received a copy of the GNU General Public License
  16 along with this program; if not, write to the Free Software
  17 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
  18 *)
  19
  20 (* Djbdns DNS mapping config *)
  21
  22 structure Djbdns :> DJBDNS =
  23 struct
  24     open Config DjbdnsConfig Util
  25
  26     val ldHandler = ref (fn _ : string => ())
  27     fun setLocalDomainHandler f = ldHandler := f
  28
  29     val relayingHandler = ref (fn _ : string => ())
  30     fun setRelayingDomainHandler f = relayingHandler := f
  31
  32     val dns = ref (NONE : TextIO.outstream option)
  33
  34     fun init () =
  35         (dns := SOME (TextIO.openOut (scratchDir ^ "/data.shared"));
  36          ignore (OS.Process.system ("cd /tmp; " ^ rm ^ " -rf " ^ scratchDir ^ "/slaves/*"));
  37          ignore (OS.Process.system ("cd /tmp; " ^ rm ^ " -rf " ^ afxrSlavesTemp));
  38          ignore (OS.Process.system (mkdir ^ " " ^ afxrSlavesTemp)))
  39     fun finish () = (TextIO.closeOut (valOf (!dns));
  40                      dns := NONE)
  41
  42     fun handler (data : Domtool.handlerData) =
  43         let
  44             val path = #path data
  45             val domain = String.extract (#domain data, 5, NONE)
  46             val parent = #parent data
  47             val vars = #vars data
  48             val mxs = #mxs data
  49             val slaves = #slaves data
  50             val nses = #nses data
  51
  52             val _ = Domtool.dprint ("Reading dns " ^ path ^ " for " ^ parent ^ "....")
  53
  54             val dns = valOf (!dns)
  55
  56             val al = TextIO.openIn path
  57
  58             val hasNs = ref false
  59             val hasEmail = ref false
  60             val hasRelaying = ref false
  61             val isSlave = ref false
  62
  63             fun loop (line, (slaveDirs, mxnum, chans, ttl)) =
  64                 let
  65                     fun writeDns s =
  66                         if !isSlave then
  67                             ()
  68                         else
  69                             app (fn ch => TextIO.output (ch, s)) chans
  70
  71                     fun err () = (Domtool.error (path, "Invalid entry: " ^ trimLast line);
  72                                   (slaveDirs, mxnum, chans, ttl))
  73                 in
  74                     case String.tokens Char.isSpace line of
  75                         [] => (slaveDirs, mxnum, chans, ttl)
  76                       | ["Master", addr] =>
  77                         (case resolveAddr (vars, addr) of
  78                              "" => err ()
  79                            | addr =>
  80                              (isSlave := true;
  81                               app (fn slaveDir =>
  82                                       ignore (OS.Process.system (echo ^ " " ^ addr ^ " >> " ^ slaveDir ^ "/slaves/" ^ parent)))
  83                                   slaveDirs;
  84                               TextIO.output (dns, "# Master for " ^ parent ^ ": " ^ addr ^ "\n");
  85                               ignore (OS.Process.system (echo ^ " " ^ addr ^ " >> " ^ afxrSlavesTemp ^ "/" ^ parent));
  86                               (slaveDirs, mxnum, chans, ttl)))
  87                       | ["TTL", "default"] => (slaveDirs, mxnum, chans, "")
  88                       | ["TTL", n] =>
  89                         (case Int.fromString n of
  90                              NONE => err ()
  91                            | SOME n' =>
  92                              if n' >= minTTL then
  93                                  (slaveDirs, mxnum, chans, ":" ^ n)
  94                              else
  95                                  err ())
  96                       | ["Default", addr] =>
  97                         (case resolveAddr (vars, addr) of
  98                              "" => err ()
  99                            | addr => (writeDns ("=" ^ parent ^ ":" ^ addr ^ ttl ^ "\n");
 100                                       (slaveDirs, mxnum, chans, ttl)))
 101                       | ["Mail", host] =>
 102                         (if validDomainUC host then
 103                              (writeDns ("@" ^ parent ^ "::" ^ host ^ ":" ^ Int.toString mxnum ^ ttl ^ "\n");
 104                               (slaveDirs, mxnum+1, chans, ttl))
 105                          else
 106                              err ())
 107                       | ["BackupMail", host, addr] =>
 108                         (case resolveAddr (vars, addr) of
 109                              "" => err ()
 110                            | addr =>
 111                              (if not (!hasRelaying) andalso member (addr, localMailIps) then
 112                                   (hasRelaying := true;
 113                                    !relayingHandler parent)
 114                               else
 115                                   ();
 116                               if validHost host then
 117                                   (writeDns ("@" ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ ":" ^ Int.toString mxnum ^ ttl ^ "\n");
 118                                    (slaveDirs, mxnum+1, chans, ttl))
 119                               else
 120                                   err ()))
 121                       | ["Slave", slave] =>
 122                         (case StringMap.find (slaves, slave) of
 123                              NONE => (Domtool.error ("Unknown slave " ^ slave ^ " in", path);
 124                                       (slaveDirs, mxnum, chans, ttl))
 125                            | SOME addrs =>
 126                                  case String.fields (fn ch => ch = #";") addrs of
 127                                      [addr, saddr] =>
 128                                      let
 129                                          val slaveDir = scratchDir ^ "/slaves/" ^ slave
 130
 131                                          val _ = if Posix.FileSys.access (slaveDir, []) then
 132                                                      ()
 133                                                  else
 134                                                      (Posix.FileSys.mkdir (slaveDir, Posix.FileSys.S.irwxu);
 135                                                       Posix.FileSys.mkdir (slaveDir ^ "/slaves", Posix.FileSys.S.irwxu))
 136
 137                                          val domFile = slaveDir ^ "/" ^ domain ^ ".dns"
 138
 139                                          val dest = TextIO.openOut (slaveDir ^ "/destination")
 140                                          val _ = TextIO.output (dest, addr)
 141                                          val _ = TextIO.closeOut dest
 142
 143                                          val dest = TextIO.openOut (slaveDir ^ "/slaves_destination")
 144                                          val _ = TextIO.output (dest, saddr)
 145                                          val _ = TextIO.closeOut dest
 146
 147                                          val chan = TextIO.openOut domFile
 148                                      in
 149                                          writeDns ("# " ^ domain ^ " Slave " ^ slave ^ "\n");
 150                                          (slaveDir :: slaveDirs, mxnum, chan :: chans, ttl)
 151                                      end
 152                                    | _ => (Domtool.error ("Bad slave format", path);
 153                                            (slaveDirs, mxnum, chans, ttl)))
 154                       | ["Primary", host] =>
 155                         (case StringMap.find (nses, host) of
 156                              NONE => (Domtool.error ("Unknown outside name server: " ^ host, path);
 157                                       (slaveDirs, mxnum, chans, ttl))
 158                            | SOME addr => (hasNs := true;
 159                                            writeDns ("." ^ parent ^ ":" ^ addr ^ ":" ^ host ^ ttl ^ "\n");
 160                                            (slaveDirs, mxnum, chans, ttl)))
 161                       | ["Secondary", host] =>
 162                         (case StringMap.find (nses, host) of
 163                              NONE => (Domtool.error ("Unknown outside name server: " ^ host, path);
 164                                       (slaveDirs, mxnum, chans, ttl))
 165                            | SOME addr => (hasNs := true;
 166                                            writeDns ("&" ^ parent ^ ":" ^ addr ^ ":" ^ host ^ ttl ^ "\n");
 167                                            (slaveDirs, mxnum, chans, ttl)))
 168                       | [ty, host, addr] =>
 169                         let
 170                             val pre =
 171                                 (case ty of
 172                                      "Primary" => (hasNs := true; ".")
 173                                    | "Secondary" => (hasNs := true; "&")
 174                                    | "Host" => "="
 175                                    | "Alias" => "+"
 176                                    | "Mail" => "@"
 177                                    | "Redir" => "C"
 178                                    | _ => "")
 179                         in
 180                             if pre = "C" then
 181                                 (case resolveDomain (vars, addr) of
 182                                      "" =>  err ()
 183                                    | host' =>
 184                                      if validHost host then
 185                                          (writeDns (pre ^ host ^ "." ^ parent ^ ":" ^ host' ^ ttl ^ "\n");
 186                                           (slaveDirs, mxnum, chans, ttl))
 187                                      else
 188                                          err ())
 189                             else case (resolveAddr (vars, addr), pre) of
 190                                      ("", _) => err ()
 191                                    | (addr, ".") =>
 192                                      if validHost host then
 193                                          (writeDns (pre ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ ttl ^ "\n");
 194                                           (slaveDirs, mxnum, chans, ttl))
 195                                      else
 196                                          err ()
 197                                    | (addr, "&") =>
 198                                      if validHost host then
 199                                          (writeDns (pre ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ ttl ^ "\n");
 200                                           (slaveDirs, mxnum, chans, ttl))
 201                                      else
 202                                          err ()
 203                                    | (addr, "@") =>
 204                                      (if not (!hasEmail) andalso member (addr, localMailIps) then
 205                                           (hasEmail := true;
 206                                            !ldHandler parent)
 207                                       else
 208                                           ();
 209                                       if validHost host then
 210                                           (writeDns (pre ^ parent ^ ":" ^ addr ^ ":" ^ host ^ "." ^ parent ^ ":" ^ Int.toString mxnum ^ ttl ^ "\n");
 211                                            (slaveDirs, mxnum+1, chans, ttl))
 212                                       else
 213                                           err ())
 214                                    | (addr, "=") =>
 215                                      if validHost host then
 216                                          (writeDns (pre ^ host ^ "." ^ parent ^ ":" ^ addr ^ ttl ^ "\n");
 217                                           (slaveDirs, mxnum, chans, ttl))
 218                                      else
 219                                          err ()
 220                                    | (addr, "+") =>
 221                                      if validHost host then
 222                                          (writeDns (pre ^ host ^ "." ^ parent ^ ":" ^ addr ^ ttl ^ "\n");
 223                                           (slaveDirs, mxnum, chans, ttl))
 224                                      else
 225                                          err ()
 226                                    | _ => err ()
 227                         end
 228                       | _ => err ()
 229                 end
 230
 231             fun closeChans chans =
 232                 case chans of
 233                     [] => raise Fail "closeChans should never reach an empty list!"
 234                   | [_] => ()
 235                   | chan::chans =>
 236                     (TextIO.closeOut chan;
 237                      closeChans chans)
 238
 239             val (slaveDirs, _, chans, ttl) = ioOptLoopFold (fn () => Domtool.inputLine al) loop ([], 0, [dns], "")
 240
 241             fun writeDns s =
 242                 if !isSlave then
 243                     ()
 244                 else
 245                     app (fn ch => TextIO.output (ch, s)) chans
 246         in
 247             if !hasNs then
 248                 ()
 249             else
 250                 (writeDns ("." ^ parent ^ "::ns.hcoop.net" ^ ttl ^ "\n");
 251                  writeDns ("&" ^ parent ^ "::ns2.hcoop.net" ^ ttl ^ "\n"));
 252             closeChans chans;
 253             TextIO.closeIn al
 254         end handle ex => Domtool.handleException (#path data, ex)
 255
 256     fun publish () =
 257         if OS.Process.isSuccess (OS.Process.system
 258                                      (diff ^ " " ^ scratchDir ^ "/data.shared " ^ dataFile)) then
 259             OS.Process.success
 260         else if not (OS.Process.isSuccess (OS.Process.system
 261                                                (rm ^ " -rf " ^ afxrSlaves ^ "; " ^ mv ^ " -f " ^ afxrSlavesTemp ^ " " ^ afxrSlaves))) then
 262             (print "Error copying AFXR slaves\n";
 263              OS.Process.failure)
 264         else if not (OS.Process.isSuccess (OS.Process.system
 265                                                (chown ^ " -R root.root " ^ afxrSlaves))) then
 266             (print "Error chown'ing AFXR slaves\n";
 267              OS.Process.failure)
 268         else if not (OS.Process.isSuccess (OS.Process.system
 269                                                (cp ^ " " ^ scratchDir ^ "/data.shared " ^ dataFile))) then
 270             (print "Error copying data.shared\n";
 271              OS.Process.failure)
 272         else if not (OS.Process.isSuccess (OS.Process.system pubCommand)) then
 273             (print "Error publishing data.shared\n";
 274              OS.Process.failure)
 275         else
 276             let
 277                 val slaveDir = scratchDir ^ "/slaves"
 278                 val dir = Posix.FileSys.opendir slaveDir
 279
 280                 fun doEntry (name, ()) =
 281                     let
 282                         val fullName = slaveDir ^ "/" ^ name
 283                         val st = Posix.FileSys.stat fullName
 284                     in
 285                         if Posix.FileSys.ST.isDir st then
 286                             ()
 287                             (*if OS.Process.isSuccess (OS.Process.system (rsync ^ " -az --delete " ^ fullName ^ "/*.dns `" ^ cat ^ " " ^ fullName ^ "/destination`")) then
 288                                 if OS.Process.isSuccess (OS.Process.system (rsync ^ " -az --delete " ^ fullName ^ "/slaves/* `" ^ cat ^ " " ^ fullName ^ "/slaves_destination`")) then
 289                                     ()
 290                                 else
 291                                     print ("Error sending sub-slaves to slave " ^ name ^ "\n")
 292                             else
 293                                 print ("Error sending to slave " ^ name ^ "\n")*)
 294                         else
 295                             ()
 296                     end
 297             in
 298                 ioOptLoop (fn () => Posix.FileSys.readdir dir) doEntry ();
 299                 Posix.FileSys.closedir dir;
 300                 OS.Process.success
 301             end
 302
 303     fun mkdom {path, ...} = OS.Process.system (cp ^ " " ^ defaultFile ^ " " ^ path ^ "/.dns")
 304
 305     val _ = Domtool.setHandler (".dns", {init = init,
 306                                          file = handler,
 307                                          finish = finish,
 308                                          publish = publish,
 309                                          mkdom = mkdom})
 310 end