src/domain.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 (* Domain-related primitive actions *)
  20
  21 structure Domain :> DOMAIN = struct
  22
  23 open MsgTypes
  24
  25 structure SM = DataStructures.StringMap
  26 structure SS = DataStructures.StringSet
  27
  28 val ssl_context = ref (NONE : OpenSSL.context option)
  29 fun set_context ctx = ssl_context := SOME ctx
  30
  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))
  35
  36 val usr = ref ""
  37 fun getUser () = !usr
  38
  39 val your_doms = ref SS.empty
  40 fun your_domains () = !your_doms
  41
  42 val your_usrs = ref SS.empty
  43 fun your_users () = !your_usrs
  44
  45 val your_grps = ref SS.empty
  46 fun your_groups () = !your_grps
  47
  48 val your_pths = ref SS.empty
  49 fun your_paths () = !your_pths
  50
  51 fun setUser user =
  52     (usr := user;
  53      your_doms := Acl.class {user = getUser (),
  54                              class = "domain"};
  55      your_usrs := Acl.class {user = getUser (),
  56                              class = "user"};
  57      your_grps := Acl.class {user = getUser (),
  58                              class = "group"};
  59      your_pths := Acl.class {user = getUser (),
  60                              class = "path"})
  61
  62 fun validIp s =
  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
  66       | _ => false
  67
  68 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
  69
  70 fun validHost s =
  71     size s > 0 andalso size s < 20
  72     andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
  73
  74 fun validDomain s =
  75     size s > 0 andalso size s < 100
  76     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
  77
  78 fun validNode s = List.exists (fn s' => s = s') nodes
  79
  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)
  83 fun yourPath path =
  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 ())
  88
  89 fun yourDomainHost s =
  90     yourDomain s
  91     orelse let
  92         val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
  93     in
  94         Substring.size suf > 0
  95         andalso validHost (Substring.string pref)
  96         andalso yourDomain (Substring.string
  97                                 (Substring.slice (suf, 1, NONE)))
  98     end
  99
 100 fun validUser s = size s > 0 andalso size s < 20
 101                   andalso CharVector.all Char.isAlphaNum s
 102
 103 val validGroup = validUser
 104
 105 val _ = Env.type_one "no_spaces"
 106                      Env.string
 107                      (CharVector.all (fn ch => not (Char.isSpace ch)))
 108 val _ = Env.type_one "no_newlines"
 109                      Env.string
 110                      (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
 111
 112 val _ = Env.type_one "ip"
 113         Env.string
 114         validIp
 115
 116 val _ = Env.type_one "host"
 117         Env.string
 118         validHost
 119
 120 val _ = Env.type_one "domain"
 121         Env.string
 122         validDomain
 123
 124 val _ = Env.type_one "your_domain"
 125         Env.string
 126         yourDomain
 127
 128 val _ = Env.type_one "your_domain_host"
 129         Env.string
 130         yourDomainHost
 131
 132 val _ = Env.type_one "user"
 133         Env.string
 134         validUser
 135
 136 val _ = Env.type_one "group"
 137         Env.string
 138         validGroup
 139
 140 val _ = Env.type_one "your_user"
 141         Env.string
 142         yourUser
 143
 144 val _ = Env.type_one "your_group"
 145         Env.string
 146         yourGroup
 147
 148 val _ = Env.type_one "your_path"
 149         Env.string
 150         yourPath
 151
 152 val _ = Env.type_one "node"
 153         Env.string
 154         validNode
 155
 156 val _ = Env.registerFunction ("dns_node_to_node",
 157                               fn [e] => SOME e
 158                                | _ => NONE)
 159
 160 val _ = Env.registerFunction ("mail_node_to_node",
 161                               fn [e] => SOME e
 162                                | _ => NONE)
 163 open Ast
 164
 165 val dl = ErrorMsg.dummyLoc
 166
 167 val nsD = (EString Config.defaultNs, dl)
 168 val serialD = (EVar "serialAuto", dl)
 169 val refD = (EInt Config.defaultRefresh, dl)
 170 val retD = (EInt Config.defaultRetry, dl)
 171 val expD = (EInt Config.defaultExpiry, dl)
 172 val minD = (EInt Config.defaultMinimum, dl)
 173
 174 val soaD = multiApp ((EVar "soa", dl),
 175                      dl,
 176                      [nsD, serialD, refD, retD, expD, minD])
 177
 178 val masterD = (EApp ((EVar "internalMaster", dl),
 179                      (EString Config.masterNode, dl)),
 180                dl)
 181
 182 val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
 183
 184 val _ = Defaults.registerDefault ("Mailbox",
 185                                   (TBase "email", dl),
 186                                   (fn () => (EString (getUser ()), dl)))
 187
 188 val _ = Defaults.registerDefault ("DNS",
 189                                   (TBase "dnsKind", dl),
 190                                   (fn () => multiApp ((EVar "useDns", dl),
 191                                                       dl,
 192                                                       [soaD, masterD, slavesD])))
 193
 194 val _ = Defaults.registerDefault ("TTL",
 195                                   (TBase "int", dl),
 196                                   (fn () => (EInt Config.Bind.defaultTTL, dl)))
 197
 198 type soa = {ns : string,
 199             serial : int option,
 200             ref : int,
 201             ret : int,
 202             exp : int,
 203             min : int}
 204
 205 val serial = fn (EVar "serialAuto", _) => SOME NONE
 206               | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
 207               | _ => NONE
 208
 209 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
 210                                                      ((EVar "soa", _), ns), _),
 211                                                 sl), _),
 212                                          rf), _),
 213                                   ret), _),
 214                            exp), _),
 215                     min), _) =>
 216              (case (Env.string ns, serial sl, Env.int rf,
 217                     Env.int ret, Env.int exp, Env.int min) of
 218                   (SOME ns, SOME sl, SOME rf,
 219                    SOME ret, SOME exp, SOME min) =>
 220                   SOME {ns = ns,
 221                         serial = sl,
 222                         ref = rf,
 223                         ret = ret,
 224                         exp = exp,
 225                         min = min}
 226                 | _ => NONE)
 227            | _ => NONE
 228
 229 datatype master =
 230          ExternalMaster of string
 231        | InternalMaster of string
 232
 233 val ip = Env.string
 234
 235 val _ = Env.registerFunction ("ip_of_node",
 236                               fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
 237                                | _ => NONE)
 238
 239 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
 240               | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
 241               | _ => NONE
 242
 243 datatype dnsKind =
 244          UseDns of {soa : soa,
 245                     master : master,
 246                     slaves : string list}
 247        | NoDns
 248
 249 val dnsKind = fn (EApp ((EApp ((EApp
 250                                     ((EVar "useDns", _), sa), _),
 251                                mstr), _),
 252                         slaves), _) =>
 253                  (case (soa sa, master mstr, Env.list Env.string slaves) of
 254                       (SOME sa, SOME mstr, SOME slaves) =>
 255                       SOME (UseDns {soa = sa,
 256                                     master = mstr,
 257                                     slaves = slaves})
 258                     | _ => NONE)
 259                | (EVar "noDns", _) => SOME NoDns
 260                | _ => NONE
 261
 262 val befores = ref (fn (_ : string) => ())
 263 val afters = ref (fn (_ : string) => ())
 264
 265 fun registerBefore f =
 266     let
 267         val old = !befores
 268     in
 269         befores := (fn x => (old x; f x))
 270     end
 271
 272 fun registerAfter f =
 273     let
 274         val old = !afters
 275     in
 276         afters := (fn x => (old x; f x))
 277     end
 278
 279 val current = ref ""
 280 val currentPath = ref (fn (_ : string) => "")
 281
 282 val scratch = ref ""
 283
 284 fun currentDomain () = !current
 285
 286 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 287                                TextIO.openOut (!currentPath node ^ name))
 288
 289 fun getPath domain =
 290     let
 291         val toks = String.fields (fn ch => ch = #".") domain
 292
 293         val elems = foldr (fn (piece, elems) =>
 294                               let
 295                                   val elems = piece :: elems
 296
 297                                   fun doNode node =
 298                                       let
 299                                           val path = String.concatWith "/"
 300                                                                        (Config.resultRoot :: node :: rev elems)
 301                                           val tmpPath = String.concatWith "/"
 302                                                                           (Config.tmpDir :: node :: rev elems)
 303                                       in
 304                                           (if Posix.FileSys.ST.isDir
 305                                                   (Posix.FileSys.stat path) then
 306                                                ()
 307                                            else
 308                                                (OS.FileSys.remove path;
 309                                                 OS.FileSys.mkDir path))
 310                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 311
 312                                           (if Posix.FileSys.ST.isDir
 313                                                   (Posix.FileSys.stat tmpPath) then
 314                                                ()
 315                                            else
 316                                                (OS.FileSys.remove tmpPath;
 317                                                 OS.FileSys.mkDir tmpPath))
 318                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 319                                       end
 320                               in
 321                                   app doNode nodes;
 322                                   elems
 323                               end) [] toks
 324     in
 325         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 326     end
 327
 328 datatype file_action' =
 329          Add' of {src : string, dst : string}
 330        | Delete' of string
 331        | Modify' of {src : string, dst : string}
 332
 333 fun findDiffs (site, dom, acts) =
 334     let
 335         val gp = getPath dom
 336         val realPath = gp (Config.resultRoot, site)
 337         val tmpPath = gp (Config.tmpDir, site)
 338
 339         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 340
 341         val dir = Posix.FileSys.opendir realPath
 342
 343         fun loopReal acts =
 344             case Posix.FileSys.readdir dir of
 345                 NONE => (Posix.FileSys.closedir dir;
 346                          acts)
 347               | SOME fname =>
 348                 let
 349                     val real = OS.Path.joinDirFile {dir = realPath,
 350                                                     file = fname}
 351                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 352                                                    file = fname}
 353                 in
 354                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 355                         loopReal acts
 356                     else if Posix.FileSys.access (tmp, []) then
 357                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 358                             loopReal acts
 359                         else
 360                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 361                     else
 362                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 363                 end
 364
 365         val acts = loopReal acts
 366
 367         val dir = Posix.FileSys.opendir tmpPath
 368
 369         fun loopTmp acts =
 370             case Posix.FileSys.readdir dir of
 371                 NONE => (Posix.FileSys.closedir dir;
 372                          acts)
 373               | SOME fname =>
 374                 let
 375                     val real = OS.Path.joinDirFile {dir = realPath,
 376                                                     file = fname}
 377                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 378                                                    file = fname}
 379                 in
 380                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 381                         loopTmp acts
 382                     else if Posix.FileSys.access (real, []) then
 383                         loopTmp acts
 384                     else
 385                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 386                 end
 387
 388         val acts = loopTmp acts
 389     in
 390         acts
 391     end
 392
 393 fun findAllDiffs () =
 394     let
 395         val dir = Posix.FileSys.opendir Config.tmpDir
 396         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 397
 398         fun exploreSites diffs =
 399             case Posix.FileSys.readdir dir of
 400                 NONE => diffs
 401               | SOME site =>
 402                 let
 403                     fun explore (dname, diffs) =
 404                         let
 405                             val dir = Posix.FileSys.opendir dname
 406
 407                             fun loop diffs =
 408                                 case Posix.FileSys.readdir dir of
 409                                     NONE => diffs
 410                                   | SOME name =>
 411                                     let
 412                                         val fname = OS.Path.joinDirFile {dir = dname,
 413                                                                          file = name}
 414                                     in
 415                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 416                                                   let
 417                                                       val dom = String.fields (fn ch => ch = #"/") fname
 418                                                       val dom = List.drop (dom, len)
 419                                                       val dom = String.concatWith "." (rev dom)
 420
 421                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 422                                                                                         file = name}
 423                                                   in
 424                                                       explore (dname',
 425                                                                findDiffs (site, dom, diffs))
 426                                                   end
 427                                               else
 428                                                   diffs)
 429                                     end
 430                         in
 431                             loop diffs
 432                             before Posix.FileSys.closedir dir
 433                         end
 434                 in
 435                     exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 436                                                                 file = site}, diffs))
 437                 end
 438     in
 439         exploreSites []
 440         before Posix.FileSys.closedir dir
 441     end
 442
 443 val masterNode : string option ref = ref NONE
 444 fun dnsMaster () = !masterNode
 445
 446 val _ = Env.containerV_one "domain"
 447                            ("domain", Env.string)
 448                            (fn (evs, dom) =>
 449                                let
 450                                    val kind = Env.env dnsKind (evs, "DNS")
 451                                    val ttl = Env.env Env.int (evs, "TTL")
 452
 453                                    val path = getPath dom
 454
 455                                    val () = (current := dom;
 456                                              currentPath := (fn site => path (Config.tmpDir, site)))
 457
 458                                    fun saveSoa (kind, soa : soa) node =
 459                                        let
 460                                            val outf = domainFile {node = node, name = "soa"}
 461                                        in
 462                                            TextIO.output (outf, kind);
 463                                            TextIO.output (outf, "\n");
 464                                            TextIO.output (outf, Int.toString ttl);
 465                                            TextIO.output (outf, "\n");
 466                                            TextIO.output (outf, #ns soa);
 467                                            TextIO.output (outf, "\n");
 468                                            case #serial soa of
 469                                                NONE => ()
 470                                              | SOME n => TextIO.output (outf, Int.toString n);
 471                                            TextIO.output (outf, "\n");
 472                                            TextIO.output (outf, Int.toString (#ref soa));
 473                                            TextIO.output (outf, "\n");
 474                                            TextIO.output (outf, Int.toString (#ret soa));
 475                                            TextIO.output (outf, "\n");
 476                                            TextIO.output (outf, Int.toString (#exp soa));
 477                                            TextIO.output (outf, "\n");
 478                                            TextIO.output (outf, Int.toString (#min soa));
 479                                            TextIO.output (outf, "\n");
 480                                            TextIO.closeOut outf
 481                                        end
 482
 483                                    fun saveNamed (kind, soa : soa, masterIp) node =
 484                                        let
 485                                            val outf = domainFile {node = node, name = "named.conf"}
 486                                        in
 487                                            TextIO.output (outf, "\nzone \"");
 488                                            TextIO.output (outf, dom);
 489                                            TextIO.output (outf, "\" IN {\n\ttype ");
 490                                            TextIO.output (outf, kind);
 491                                            TextIO.output (outf, ";\n\tfile \"");
 492                                            TextIO.output (outf, Config.Bind.zonePath_real);
 493                                            TextIO.output (outf, "/");
 494                                            TextIO.output (outf, dom);
 495                                            TextIO.output (outf, ".zone\";\n");
 496                                            case kind of
 497                                                "master" => TextIO.output (outf, "\tallow-update { none; };\n")
 498                                              | _ => (TextIO.output (outf, "\tmasters { ");
 499                                                      TextIO.output (outf, masterIp);
 500                                                      TextIO.output (outf, "; };\n"));
 501                                            TextIO.output (outf, "};\n");
 502                                            TextIO.closeOut outf
 503                                        end
 504                                in
 505                                    case kind of
 506                                        NoDns => masterNode := NONE
 507                                      | UseDns dns =>
 508                                        let
 509                                            val masterIp =
 510                                                case #master dns of
 511                                                    InternalMaster node => valOf (SM.find (nodeMap, node))
 512                                                  | ExternalMaster ip => ip
 513                                        in
 514                                            app (saveSoa ("slave", #soa dns)) (#slaves dns);
 515                                            app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
 516                                            case #master dns of
 517                                                InternalMaster node =>
 518                                                (masterNode := SOME node;
 519                                                 saveSoa ("master", #soa dns) node;
 520                                                 saveNamed ("master", #soa dns, masterIp) node)
 521                                              | _ => masterNode := NONE;
 522                                            !befores dom
 523                                        end
 524                                end,
 525                             fn () => !afters (!current))
 526
 527 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 528                                                        fn cl => "Temp file cleanup failed: " ^ cl));
 529                                     OS.FileSys.mkDir Config.tmpDir;
 530                                     app (fn node => OS.FileSys.mkDir
 531                                                         (OS.Path.joinDirFile {dir = Config.tmpDir,
 532                                                                               file = node}))
 533                                         nodes;
 534                                     app (fn node => OS.FileSys.mkDir
 535                                                         (OS.Path.joinDirFile {dir = Config.resultRoot,
 536                                                                               file = node})
 537                                             handle OS.SysErr _ => ())
 538                                         nodes))
 539
 540 val () = Env.registerPost (fn () =>
 541                               let
 542                                   val diffs = findAllDiffs ()
 543
 544                                   val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
 545                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 546                                                                   fn cl => "Copy failed: " ^ cl);
 547                                                        (site,
 548                                                         {action = Slave.Add,
 549                                                          domain = dom,
 550                                                          dir = dir,
 551                                                          file = dst}))
 552                                                     | (site, dom, dir, Delete' dst) =>
 553                                                       (OS.FileSys.remove dst
 554                                                        handle OS.SysErr _ =>
 555                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 556                                                        (site,
 557                                                         {action = Slave.Delete,
 558                                                          domain = dom,
 559                                                          dir = dir,
 560                                                          file = dst}))
 561                                                     | (site, dom, dir, Modify' {src, dst}) =>
 562                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 563                                                                   fn cl => "Copy failed: " ^ cl);
 564                                                        (site,
 565                                                         {action = Slave.Modify,
 566                                                          domain = dom,
 567                                                          dir = dir,
 568                                                          file = dst}))) diffs
 569                               in
 570                                   if !ErrorMsg.anyErrors then
 571                                       ()
 572                                   else let
 573                                           val changed = foldl (fn ((site, file), changed) =>
 574                                                                   let
 575                                                                       val ls = case SM.find (changed, site) of
 576                                                                                    NONE => []
 577                                                                                  | SOME ls => ls
 578                                                                   in
 579                                                                       SM.insert (changed, site, file :: ls)
 580                                                                   end) SM.empty diffs
 581
 582                                           fun handleSite (site, files) =
 583                                               let
 584
 585                                               in
 586                                                   print ("New configuration for node " ^ site ^ "\n");
 587                                                   if site = Config.defaultNode then
 588                                                       Slave.handleChanges files
 589                                                   else let
 590                                                           val bio = OpenSSL.connect (valOf (!ssl_context),
 591                                                                                      nodeIp site
 592                                                                                      ^ ":"
 593                                                                                      ^ Int.toString Config.slavePort)
 594                                                       in
 595                                                           app (fn file => Msg.send (bio, MsgFile file)) files;
 596                                                           Msg.send (bio, MsgDoFiles);
 597                                                           case Msg.recv bio of
 598                                                               NONE => print "Slave closed connection unexpectedly\n"
 599                                                             | SOME m =>
 600                                                               case m of
 601                                                                   MsgOk => print ("Slave " ^ site ^ " finished\n")
 602                                                                 | MsgError s => print ("Slave " ^ site
 603                                                                                        ^ " returned error: " ^
 604                                                                                        s ^ "\n")
 605                                                                 | _ => print ("Slave " ^ site
 606                                                                               ^ " returned unexpected command\n");
 607                                                           OpenSSL.close bio
 608                                                       end
 609                                               end
 610                                       in
 611                                           SM.appi handleSite changed
 612                                       end;
 613                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 614                                                      fn cl => "Temp file cleanup failed: " ^ cl))
 615                               end)
 616
 617 fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
 618                    orelse Acl.query {user = getUser (), class = "priv", value = priv}
 619
 620 val _ = Env.type_one "dns_node"
 621         Env.string
 622         (fn node =>
 623             List.exists (fn x => x = node) Config.dnsNodes_all
 624             orelse (hasPriv "dns"
 625                     andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
 626
 627 val _ = Env.type_one "mail_node"
 628         Env.string
 629         (fn node =>
 630             List.exists (fn x => x = node) Config.mailNodes_all
 631             orelse (hasPriv "mail"
 632                     andalso List.exists (fn x => x = node) Config.mailNodes_admin))
 633
 634 end