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 ("web_node_to_node",
 157                               fn [e] => SOME e
 158                                | _ => NONE)
 159 open Ast
 160
 161 val dl = ErrorMsg.dummyLoc
 162
 163 val nsD = (EString Config.defaultNs, dl)
 164 val serialD = (EVar "serialAuto", dl)
 165 val refD = (EInt Config.defaultRefresh, dl)
 166 val retD = (EInt Config.defaultRetry, dl)
 167 val expD = (EInt Config.defaultExpiry, dl)
 168 val minD = (EInt Config.defaultMinimum, dl)
 169
 170 val soaD = multiApp ((EVar "soa", dl),
 171                      dl,
 172                      [nsD, serialD, refD, retD, expD, minD])
 173
 174 val masterD = (EApp ((EVar "internalMaster", dl),
 175                      (EString Config.masterNode, dl)),
 176                dl)
 177
 178 val slavesD = (EList (map (fn s => (EString s, dl)) Config.slaveNodes), dl)
 179
 180 val _ = Defaults.registerDefault ("Mailbox",
 181                                   (TBase "email", dl),
 182                                   (fn () => (EString (getUser ()), dl)))
 183
 184 val _ = Defaults.registerDefault ("DNS",
 185                                   (TBase "dnsKind", dl),
 186                                   (fn () => multiApp ((EVar "useDns", dl),
 187                                                       dl,
 188                                                       [soaD, masterD, slavesD])))
 189
 190 val _ = Defaults.registerDefault ("TTL",
 191                                   (TBase "int", dl),
 192                                   (fn () => (EInt Config.Bind.defaultTTL, dl)))
 193
 194 type soa = {ns : string,
 195             serial : int option,
 196             ref : int,
 197             ret : int,
 198             exp : int,
 199             min : int}
 200
 201 val serial = fn (EVar "serialAuto", _) => SOME NONE
 202               | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
 203               | _ => NONE
 204
 205 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
 206                                                      ((EVar "soa", _), ns), _),
 207                                                 sl), _),
 208                                          rf), _),
 209                                   ret), _),
 210                            exp), _),
 211                     min), _) =>
 212              (case (Env.string ns, serial sl, Env.int rf,
 213                     Env.int ret, Env.int exp, Env.int min) of
 214                   (SOME ns, SOME sl, SOME rf,
 215                    SOME ret, SOME exp, SOME min) =>
 216                   SOME {ns = ns,
 217                         serial = sl,
 218                         ref = rf,
 219                         ret = ret,
 220                         exp = exp,
 221                         min = min}
 222                 | _ => NONE)
 223            | _ => NONE
 224
 225 datatype master =
 226          ExternalMaster of string
 227        | InternalMaster of string
 228
 229 val ip = Env.string
 230
 231 val _ = Env.registerFunction ("ip_of_node",
 232                               fn [(EString node, _)] => SOME (EString (nodeIp node), dl)
 233                                | _ => NONE)
 234
 235 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (ip e)
 236               | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
 237               | _ => NONE
 238
 239 datatype dnsKind =
 240          UseDns of {soa : soa,
 241                     master : master,
 242                     slaves : string list}
 243        | NoDns
 244
 245 val dnsKind = fn (EApp ((EApp ((EApp
 246                                     ((EVar "useDns", _), sa), _),
 247                                mstr), _),
 248                         slaves), _) =>
 249                  (case (soa sa, master mstr, Env.list Env.string slaves) of
 250                       (SOME sa, SOME mstr, SOME slaves) =>
 251                       SOME (UseDns {soa = sa,
 252                                     master = mstr,
 253                                     slaves = slaves})
 254                     | _ => NONE)
 255                | (EVar "noDns", _) => SOME NoDns
 256                | _ => NONE
 257
 258 val befores = ref (fn (_ : string) => ())
 259 val afters = ref (fn (_ : string) => ())
 260
 261 fun registerBefore f =
 262     let
 263         val old = !befores
 264     in
 265         befores := (fn x => (old x; f x))
 266     end
 267
 268 fun registerAfter f =
 269     let
 270         val old = !afters
 271     in
 272         afters := (fn x => (old x; f x))
 273     end
 274
 275 val current = ref ""
 276 val currentPath = ref (fn (_ : string) => "")
 277
 278 val scratch = ref ""
 279
 280 fun currentDomain () = !current
 281
 282 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 283                                TextIO.openOut (!currentPath node ^ name))
 284
 285 fun getPath domain =
 286     let
 287         val toks = String.fields (fn ch => ch = #".") domain
 288
 289         val elems = foldr (fn (piece, elems) =>
 290                               let
 291                                   val elems = piece :: elems
 292
 293                                   fun doNode node =
 294                                       let
 295                                           val path = String.concatWith "/"
 296                                                                        (Config.resultRoot :: node :: rev elems)
 297                                           val tmpPath = String.concatWith "/"
 298                                                                           (Config.tmpDir :: node :: rev elems)
 299                                       in
 300                                           (if Posix.FileSys.ST.isDir
 301                                                   (Posix.FileSys.stat path) then
 302                                                ()
 303                                            else
 304                                                (OS.FileSys.remove path;
 305                                                 OS.FileSys.mkDir path))
 306                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 307
 308                                           (if Posix.FileSys.ST.isDir
 309                                                   (Posix.FileSys.stat tmpPath) then
 310                                                ()
 311                                            else
 312                                                (OS.FileSys.remove tmpPath;
 313                                                 OS.FileSys.mkDir tmpPath))
 314                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 315                                       end
 316                               in
 317                                   app doNode nodes;
 318                                   elems
 319                               end) [] toks
 320     in
 321         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 322     end
 323
 324 datatype file_action' =
 325          Add' of {src : string, dst : string}
 326        | Delete' of string
 327        | Modify' of {src : string, dst : string}
 328
 329 fun findDiffs (site, dom, acts) =
 330     let
 331         val gp = getPath dom
 332         val realPath = gp (Config.resultRoot, site)
 333         val tmpPath = gp (Config.tmpDir, site)
 334
 335         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 336
 337         val dir = Posix.FileSys.opendir realPath
 338
 339         fun loopReal acts =
 340             case Posix.FileSys.readdir dir of
 341                 NONE => (Posix.FileSys.closedir dir;
 342                          acts)
 343               | SOME fname =>
 344                 let
 345                     val real = OS.Path.joinDirFile {dir = realPath,
 346                                                     file = fname}
 347                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 348                                                    file = fname}
 349                 in
 350                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 351                         loopReal acts
 352                     else if Posix.FileSys.access (tmp, []) then
 353                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 354                             loopReal acts
 355                         else
 356                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 357                     else
 358                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 359                 end
 360
 361         val acts = loopReal acts
 362
 363         val dir = Posix.FileSys.opendir tmpPath
 364
 365         fun loopTmp acts =
 366             case Posix.FileSys.readdir dir of
 367                 NONE => (Posix.FileSys.closedir dir;
 368                          acts)
 369               | SOME fname =>
 370                 let
 371                     val real = OS.Path.joinDirFile {dir = realPath,
 372                                                     file = fname}
 373                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 374                                                    file = fname}
 375                 in
 376                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 377                         loopTmp acts
 378                     else if Posix.FileSys.access (real, []) then
 379                         loopTmp acts
 380                     else
 381                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 382                 end
 383
 384         val acts = loopTmp acts
 385     in
 386         acts
 387     end
 388
 389 fun findAllDiffs () =
 390     let
 391         val dir = Posix.FileSys.opendir Config.tmpDir
 392         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 393
 394         fun exploreSites diffs =
 395             case Posix.FileSys.readdir dir of
 396                 NONE => diffs
 397               | SOME site =>
 398                 let
 399                     fun explore (dname, diffs) =
 400                         let
 401                             val dir = Posix.FileSys.opendir dname
 402
 403                             fun loop diffs =
 404                                 case Posix.FileSys.readdir dir of
 405                                     NONE => diffs
 406                                   | SOME name =>
 407                                     let
 408                                         val fname = OS.Path.joinDirFile {dir = dname,
 409                                                                          file = name}
 410                                     in
 411                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 412                                                   let
 413                                                       val dom = String.fields (fn ch => ch = #"/") fname
 414                                                       val dom = List.drop (dom, len)
 415                                                       val dom = String.concatWith "." (rev dom)
 416
 417                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 418                                                                                         file = name}
 419                                                   in
 420                                                       explore (dname',
 421                                                                findDiffs (site, dom, diffs))
 422                                                   end
 423                                               else
 424                                                   diffs)
 425                                     end
 426                         in
 427                             loop diffs
 428                             before Posix.FileSys.closedir dir
 429                         end
 430                 in
 431                     exploreSites (explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 432                                                                 file = site}, diffs))
 433                 end
 434     in
 435         exploreSites []
 436         before Posix.FileSys.closedir dir
 437     end
 438
 439 val masterNode : string option ref = ref NONE
 440 fun dnsMaster () = !masterNode
 441
 442 val _ = Env.containerV_one "domain"
 443                            ("domain", Env.string)
 444                            (fn (evs, dom) =>
 445                                let
 446                                    val kind = Env.env dnsKind (evs, "DNS")
 447                                    val ttl = Env.env Env.int (evs, "TTL")
 448
 449                                    val path = getPath dom
 450
 451                                    val () = (current := dom;
 452                                              currentPath := (fn site => path (Config.tmpDir, site)))
 453
 454                                    fun saveSoa (kind, soa : soa) node =
 455                                        let
 456                                            val outf = domainFile {node = node, name = "soa"}
 457                                        in
 458                                            TextIO.output (outf, kind);
 459                                            TextIO.output (outf, "\n");
 460                                            TextIO.output (outf, Int.toString ttl);
 461                                            TextIO.output (outf, "\n");
 462                                            TextIO.output (outf, #ns soa);
 463                                            TextIO.output (outf, "\n");
 464                                            case #serial soa of
 465                                                NONE => ()
 466                                              | SOME n => TextIO.output (outf, Int.toString n);
 467                                            TextIO.output (outf, "\n");
 468                                            TextIO.output (outf, Int.toString (#ref soa));
 469                                            TextIO.output (outf, "\n");
 470                                            TextIO.output (outf, Int.toString (#ret soa));
 471                                            TextIO.output (outf, "\n");
 472                                            TextIO.output (outf, Int.toString (#exp soa));
 473                                            TextIO.output (outf, "\n");
 474                                            TextIO.output (outf, Int.toString (#min soa));
 475                                            TextIO.output (outf, "\n");
 476                                            TextIO.closeOut outf
 477                                        end
 478
 479                                    fun saveNamed (kind, soa : soa, masterIp) node =
 480                                        let
 481                                            val outf = domainFile {node = node, name = "named.conf"}
 482                                        in
 483                                            TextIO.output (outf, "\nzone \"");
 484                                            TextIO.output (outf, dom);
 485                                            TextIO.output (outf, "\" IN {\n\ttype ");
 486                                            TextIO.output (outf, kind);
 487                                            TextIO.output (outf, ";\n\tfile \"");
 488                                            TextIO.output (outf, Config.Bind.zonePath_real);
 489                                            TextIO.output (outf, "/");
 490                                            TextIO.output (outf, dom);
 491                                            TextIO.output (outf, ".zone\";\n");
 492                                            case kind of
 493                                                "master" => TextIO.output (outf, "\tallow-update { none; };\n")
 494                                              | _ => (TextIO.output (outf, "\tmasters { ");
 495                                                      TextIO.output (outf, masterIp);
 496                                                      TextIO.output (outf, "; };\n"));
 497                                            TextIO.output (outf, "};\n");
 498                                            TextIO.closeOut outf
 499                                        end
 500                                in
 501                                    case kind of
 502                                        NoDns => masterNode := NONE
 503                                      | UseDns dns =>
 504                                        let
 505                                            val masterIp =
 506                                                case #master dns of
 507                                                    InternalMaster node => valOf (SM.find (nodeMap, node))
 508                                                  | ExternalMaster ip => ip
 509                                        in
 510                                            app (saveSoa ("slave", #soa dns)) (#slaves dns);
 511                                            app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
 512                                            case #master dns of
 513                                                InternalMaster node =>
 514                                                (masterNode := SOME node;
 515                                                 saveSoa ("master", #soa dns) node;
 516                                                 saveNamed ("master", #soa dns, masterIp) node)
 517                                              | _ => masterNode := NONE;
 518                                            !befores dom
 519                                        end
 520                                end,
 521                             fn () => !afters (!current))
 522
 523 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 524                                                        fn cl => "Temp file cleanup failed: " ^ cl));
 525                                     OS.FileSys.mkDir Config.tmpDir;
 526                                     app (fn node => OS.FileSys.mkDir
 527                                                         (OS.Path.joinDirFile {dir = Config.tmpDir,
 528                                                                               file = node}))
 529                                         nodes;
 530                                     app (fn node => OS.FileSys.mkDir
 531                                                         (OS.Path.joinDirFile {dir = Config.resultRoot,
 532                                                                               file = node})
 533                                             handle OS.SysErr _ => ())
 534                                         nodes))
 535
 536 val () = Env.registerPost (fn () =>
 537                               let
 538                                   val diffs = findAllDiffs ()
 539
 540                                   val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
 541                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 542                                                                   fn cl => "Copy failed: " ^ cl);
 543                                                        (site,
 544                                                         {action = Slave.Add,
 545                                                          domain = dom,
 546                                                          dir = dir,
 547                                                          file = dst}))
 548                                                     | (site, dom, dir, Delete' dst) =>
 549                                                       (OS.FileSys.remove dst
 550                                                        handle OS.SysErr _ =>
 551                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 552                                                        (site,
 553                                                         {action = Slave.Delete,
 554                                                          domain = dom,
 555                                                          dir = dir,
 556                                                          file = dst}))
 557                                                     | (site, dom, dir, Modify' {src, dst}) =>
 558                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 559                                                                   fn cl => "Copy failed: " ^ cl);
 560                                                        (site,
 561                                                         {action = Slave.Modify,
 562                                                          domain = dom,
 563                                                          dir = dir,
 564                                                          file = dst}))) diffs
 565                               in
 566                                   if !ErrorMsg.anyErrors then
 567                                       ()
 568                                   else let
 569                                           val changed = foldl (fn ((site, file), changed) =>
 570                                                                   let
 571                                                                       val ls = case SM.find (changed, site) of
 572                                                                                    NONE => []
 573                                                                                  | SOME ls => ls
 574                                                                   in
 575                                                                       SM.insert (changed, site, file :: ls)
 576                                                                   end) SM.empty diffs
 577
 578                                           fun handleSite (site, files) =
 579                                               let
 580
 581                                               in
 582                                                   print ("New configuration for node " ^ site ^ "\n");
 583                                                   if site = Config.defaultNode then
 584                                                       Slave.handleChanges files
 585                                                   else let
 586                                                           val bio = OpenSSL.connect (valOf (!ssl_context),
 587                                                                                      nodeIp site
 588                                                                                      ^ ":"
 589                                                                                      ^ Int.toString Config.slavePort)
 590                                                       in
 591                                                           app (fn file => Msg.send (bio, MsgFile file)) files;
 592                                                           Msg.send (bio, MsgDoFiles);
 593                                                           case Msg.recv bio of
 594                                                               NONE => print "Slave closed connection unexpectedly\n"
 595                                                             | SOME m =>
 596                                                               case m of
 597                                                                   MsgOk => print ("Slave " ^ site ^ " finished\n")
 598                                                                 | MsgError s => print ("Slave " ^ site
 599                                                                                        ^ " returned error: " ^
 600                                                                                        s ^ "\n")
 601                                                                 | _ => print ("Slave " ^ site
 602                                                                               ^ " returned unexpected command\n");
 603                                                           OpenSSL.close bio
 604                                                       end
 605                                               end
 606                                       in
 607                                           SM.appi handleSite changed
 608                                       end;
 609                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 610                                                      fn cl => "Temp file cleanup failed: " ^ cl))
 611                               end)
 612
 613 fun hasPriv priv = Acl.query {user = getUser (), class = "priv", value = "all"}
 614                    orelse Acl.query {user = getUser (), class = "priv", value = priv}
 615
 616 val _ = Env.type_one "dns_node"
 617         Env.string
 618         (fn node =>
 619             List.exists (fn x => x = node) Config.dnsNodes_all
 620             orelse (hasPriv "dns"
 621                     andalso List.exists (fn x => x = node) Config.dnsNodes_admin))
 622
 623 end