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 structure SM = DataStructures.StringMap
  24 structure SS = DataStructures.StringSet
  25
  26 val nodes = map #1 Config.nodeIps
  27 val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
  28                     SM.empty Config.nodeIps
  29 fun nodeIp node = valOf (SM.find (nodeMap, node))
  30
  31 val usr = ref ""
  32 fun setUser ur = usr := ur
  33 fun getUser () = !usr
  34
  35 val your_doms = ref SS.empty
  36 fun your_domains () = !your_doms
  37
  38 val your_usrs = ref SS.empty
  39 fun your_users () = !your_usrs
  40
  41 val your_grps = ref SS.empty
  42 fun your_groups () = !your_grps
  43
  44 val your_pths = ref SS.empty
  45 fun your_paths () = !your_pths
  46
  47 fun validIp s =
  48     case map Int.fromString (String.fields (fn ch => ch = #".") s) of
  49         [SOME n1, SOME n2, SOME n3, SOME n4] =>
  50         n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
  51       | _ => false
  52
  53 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
  54
  55 fun validHost s =
  56     size s > 0 andalso size s < 20
  57     andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
  58
  59 fun validDomain s =
  60     size s > 0 andalso size s < 100
  61     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
  62
  63 fun validNode s = List.exists (fn s' => s = s') nodes
  64
  65 fun yourDomain s = SS.member (your_domains (), s)
  66 fun yourUser s = SS.member (your_users (), s)
  67 fun yourGroup s = SS.member (your_groups (), s)
  68 fun yourPath path =
  69     List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
  70     andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
  71                                      orelse ch = #"-" orelse ch = #"_") path
  72     andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
  73
  74 val _ = Env.type_one "ip"
  75         Env.string
  76         validIp
  77
  78 val _ = Env.type_one "host"
  79         Env.string
  80         validHost
  81
  82 val _ = Env.type_one "domain"
  83         Env.string
  84         validDomain
  85
  86 val _ = Env.type_one "your_domain"
  87         Env.string
  88         yourDomain
  89
  90 val _ = Env.type_one "your_user"
  91         Env.string
  92         yourUser
  93
  94 val _ = Env.type_one "your_group"
  95         Env.string
  96         yourGroup
  97
  98 val _ = Env.type_one "your_path"
  99         Env.string
 100         yourPath
 101
 102 val _ = Env.type_one "node"
 103         Env.string
 104         validNode
 105
 106 open Ast
 107
 108 val dl = ErrorMsg.dummyLoc
 109
 110 val nsD = (EString Config.defaultNs, dl)
 111 val serialD = (EVar "serialAuto", dl)
 112 val refD = (EInt Config.defaultRefresh, dl)
 113 val retD = (EInt Config.defaultRetry, dl)
 114 val expD = (EInt Config.defaultExpiry, dl)
 115 val minD = (EInt Config.defaultMinimum, dl)
 116
 117 val soaD = multiApp ((EVar "soa", dl),
 118                      dl,
 119                      [nsD, serialD, refD, retD, expD, minD])
 120
 121 val masterD = (EApp ((EVar "internalMaster", dl),
 122                      (EString Config.defaultNode, dl)),
 123                dl)
 124
 125 val _ = Main.registerDefault ("DNS",
 126                               (TBase "dnsKind", dl),
 127                               (fn () => multiApp ((EVar "useDns", dl),
 128                                          dl,
 129                                          [soaD, masterD, (EList [], dl)])))
 130
 131 val _ = Main.registerDefault ("TTL",
 132                               (TBase "int", dl),
 133                               (fn () => (EInt Config.Bind.defaultTTL, dl)))
 134
 135 type soa = {ns : string,
 136             serial : int option,
 137             ref : int,
 138             ret : int,
 139             exp : int,
 140             min : int}
 141
 142 val serial = fn (EVar "serialAuto", _) => SOME NONE
 143               | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
 144               | _ => NONE
 145
 146 val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp
 147                                                      ((EVar "soa", _), ns), _),
 148                                                 sl), _),
 149                                          rf), _),
 150                                   ret), _),
 151                            exp), _),
 152                     min), _) =>
 153              (case (Env.string ns, serial sl, Env.int rf,
 154                     Env.int ret, Env.int exp, Env.int min) of
 155                   (SOME ns, SOME sl, SOME rf,
 156                    SOME ret, SOME exp, SOME min) =>
 157                   SOME {ns = ns,
 158                         serial = sl,
 159                         ref = rf,
 160                         ret = ret,
 161                         exp = exp,
 162                         min = min}
 163                 | _ => NONE)
 164            | _ => NONE
 165
 166 datatype master =
 167          ExternalMaster of string
 168        | InternalMaster of string
 169
 170 val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e)
 171               | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
 172               | _ => NONE
 173
 174 datatype dnsKind =
 175          UseDns of {soa : soa,
 176                     master : master,
 177                     slaves : string list}
 178        | NoDns
 179
 180 val dnsKind = fn (EApp ((EApp ((EApp
 181                                     ((EVar "useDns", _), sa), _),
 182                                mstr), _),
 183                         slaves), _) =>
 184                  (case (soa sa, master mstr, Env.list Env.string slaves) of
 185                       (SOME sa, SOME mstr, SOME slaves) =>
 186                       SOME (UseDns {soa = sa,
 187                                     master = mstr,
 188                                     slaves = slaves})
 189                     | _ => NONE)
 190                | _ => NONE
 191
 192 val befores = ref (fn (_ : string) => ())
 193 val afters = ref (fn (_ : string) => ())
 194
 195 fun registerBefore f =
 196     let
 197         val old = !befores
 198     in
 199         befores := (fn x => (old x; f x))
 200     end
 201
 202 fun registerAfter f =
 203     let
 204         val old = !afters
 205     in
 206         afters := (fn x => (old x; f x))
 207     end
 208
 209 val current = ref ""
 210 val currentPath = ref (fn (_ : string) => "")
 211
 212 val scratch = ref ""
 213
 214 fun currentDomain () = !current
 215
 216 fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
 217                                TextIO.openOut (!currentPath node ^ name))
 218
 219 fun getPath domain =
 220     let
 221         val toks = String.fields (fn ch => ch = #".") domain
 222
 223         val elems = foldr (fn (piece, elems) =>
 224                               let
 225                                   val elems = piece :: elems
 226
 227                                   fun doNode node =
 228                                       let
 229                                           val path = String.concatWith "/"
 230                                                                        (Config.resultRoot :: node :: rev elems)
 231                                           val tmpPath = String.concatWith "/"
 232                                                                           (Config.tmpDir :: node :: rev elems)
 233                                       in
 234                                           (if Posix.FileSys.ST.isDir
 235                                                   (Posix.FileSys.stat path) then
 236                                                ()
 237                                            else
 238                                                (OS.FileSys.remove path;
 239                                                 OS.FileSys.mkDir path))
 240                                           handle OS.SysErr _ => OS.FileSys.mkDir path;
 241
 242                                           (if Posix.FileSys.ST.isDir
 243                                                   (Posix.FileSys.stat tmpPath) then
 244                                                ()
 245                                            else
 246                                                (OS.FileSys.remove tmpPath;
 247                                                 OS.FileSys.mkDir tmpPath))
 248                                           handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
 249                                       end
 250                               in
 251                                   app doNode nodes;
 252                                   elems
 253                               end) [] toks
 254     in
 255         fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))
 256     end
 257
 258 datatype file_action' =
 259          Add' of {src : string, dst : string}
 260        | Delete' of string
 261        | Modify' of {src : string, dst : string}
 262
 263 fun findDiffs (site, dom, acts) =
 264     let
 265         val gp = getPath dom
 266         val realPath = gp (Config.resultRoot, site)
 267         val tmpPath = gp (Config.tmpDir, site)
 268
 269         (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)
 270
 271         val dir = Posix.FileSys.opendir realPath
 272
 273         fun loopReal acts =
 274             case Posix.FileSys.readdir dir of
 275                 NONE => (Posix.FileSys.closedir dir;
 276                          acts)
 277               | SOME fname =>
 278                 let
 279                     val real = OS.Path.joinDirFile {dir = realPath,
 280                                                     file = fname}
 281                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 282                                                    file = fname}
 283                 in
 284                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 285                         loopReal acts
 286                     else if Posix.FileSys.access (tmp, []) then
 287                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 288                             loopReal acts
 289                         else
 290                             loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)
 291                     else
 292                         loopReal ((site, dom, realPath, Delete' real) :: acts)
 293                 end
 294
 295         val acts = loopReal acts
 296
 297         val dir = Posix.FileSys.opendir tmpPath
 298
 299         fun loopTmp acts =
 300             case Posix.FileSys.readdir dir of
 301                 NONE => (Posix.FileSys.closedir dir;
 302                          acts)
 303               | SOME fname =>
 304                 let
 305                     val real = OS.Path.joinDirFile {dir = realPath,
 306                                                     file = fname}
 307                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 308                                                    file = fname}
 309                 in
 310                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 311                         loopTmp acts
 312                     else if Posix.FileSys.access (real, []) then
 313                         loopTmp acts
 314                     else
 315                         loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)
 316                 end
 317
 318         val acts = loopTmp acts
 319     in
 320         acts
 321     end
 322
 323 fun findAllDiffs () =
 324     let
 325         val dir = Posix.FileSys.opendir Config.tmpDir
 326         val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1
 327
 328         fun exploreSites diffs =
 329             case Posix.FileSys.readdir dir of
 330                 NONE => diffs
 331               | SOME site =>
 332                 let
 333                     fun explore (dname, diffs) =
 334                         let
 335                             val dir = Posix.FileSys.opendir dname
 336
 337                             fun loop diffs =
 338                                 case Posix.FileSys.readdir dir of
 339                                     NONE => diffs
 340                                   | SOME name =>
 341                                     let
 342                                         val fname = OS.Path.joinDirFile {dir = dname,
 343                                                                          file = name}
 344                                     in
 345                                         loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
 346                                                   let
 347                                                       val dom = String.fields (fn ch => ch = #"/") fname
 348                                                       val dom = List.drop (dom, len)
 349                                                       val dom = String.concatWith "." (rev dom)
 350
 351                                                       val dname' = OS.Path.joinDirFile {dir = dname,
 352                                                                                         file = name}
 353                                                   in
 354                                                       explore (dname',
 355                                                                findDiffs (site, dom, diffs))
 356                                                   end
 357                                               else
 358                                                   diffs)
 359                                     end
 360                         in
 361                             loop diffs
 362                             before Posix.FileSys.closedir dir
 363                         end
 364                 in
 365                     explore (OS.Path.joinDirFile {dir = Config.tmpDir,
 366                                                   file = site}, diffs)
 367                 end
 368     in
 369         exploreSites []
 370         before Posix.FileSys.closedir dir
 371     end
 372
 373 val masterNode : string option ref = ref NONE
 374 fun dnsMaster () = !masterNode
 375
 376 val _ = Env.containerV_one "domain"
 377                            ("domain", Env.string)
 378                            (fn (evs, dom) =>
 379                                let
 380                                    val kind = Env.env dnsKind (evs, "DNS")
 381                                    val ttl = Env.env Env.int (evs, "TTL")
 382
 383                                    val path = getPath dom
 384
 385                                    val () = (current := dom;
 386                                              currentPath := (fn site => path (Config.tmpDir, site)))
 387
 388                                    fun saveSoa (kind, soa : soa) node =
 389                                        let
 390                                            val outf = domainFile {node = node, name = "soa"}
 391                                        in
 392                                            TextIO.output (outf, kind);
 393                                            TextIO.output (outf, "\n");
 394                                            TextIO.output (outf, Int.toString ttl);
 395                                            TextIO.output (outf, "\n");
 396                                            TextIO.output (outf, #ns soa);
 397                                            TextIO.output (outf, "\n");
 398                                            case #serial soa of
 399                                                NONE => ()
 400                                              | SOME n => TextIO.output (outf, Int.toString n);
 401                                            TextIO.output (outf, "\n");
 402                                            TextIO.output (outf, Int.toString (#ref soa));
 403                                            TextIO.output (outf, "\n");
 404                                            TextIO.output (outf, Int.toString (#ret soa));
 405                                            TextIO.output (outf, "\n");
 406                                            TextIO.output (outf, Int.toString (#exp soa));
 407                                            TextIO.output (outf, "\n");
 408                                            TextIO.output (outf, Int.toString (#min soa));
 409                                            TextIO.output (outf, "\n");
 410                                            TextIO.closeOut outf
 411                                        end
 412
 413                                    fun saveNamed (kind, soa : soa, masterIp) node =
 414                                        let
 415                                            val outf = domainFile {node = node, name = "named.conf"}
 416                                        in
 417                                            TextIO.output (outf, "\nzone \"");
 418                                            TextIO.output (outf, dom);
 419                                            TextIO.output (outf, "\" IN {\n\ttype ");
 420                                            TextIO.output (outf, kind);
 421                                            TextIO.output (outf, ";\n\tfile \"");
 422                                            TextIO.output (outf, Config.Bind.zonePath);
 423                                            TextIO.output (outf, "/");
 424                                            TextIO.output (outf, dom);
 425                                            TextIO.output (outf, ".zone\";\n");
 426                                            case kind of
 427                                                "master" => TextIO.output (outf, "\tallow-update { none; };\n")
 428                                              | _ => (TextIO.output (outf, "\tmasters { ");
 429                                                      TextIO.output (outf, masterIp);
 430                                                      TextIO.output (outf, " };\n"));
 431                                            TextIO.output (outf, "};\n");
 432                                            TextIO.closeOut outf
 433                                        end
 434                                in
 435                                    case kind of
 436                                        NoDns => masterNode := NONE
 437                                      | UseDns dns =>
 438                                        let
 439                                            val masterIp =
 440                                                case #master dns of
 441                                                    InternalMaster node => valOf (SM.find (nodeMap, node))
 442                                                  | ExternalMaster ip => ip
 443                                        in
 444                                            app (saveSoa ("slave", #soa dns)) (#slaves dns);
 445                                            app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
 446                                            case #master dns of
 447                                                InternalMaster node =>
 448                                                (masterNode := SOME node;
 449                                                 saveSoa ("master", #soa dns) node;
 450                                                 saveNamed ("master", #soa dns, masterIp) node)
 451                                              | _ => masterNode := NONE;
 452                                            !befores dom
 453                                        end
 454                                end,
 455                             fn () => !afters (!current))
 456
 457 val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
 458                                            Acl.read Config.aclFile;
 459                                            your_doms := Acl.class {user = getUser (),
 460                                                                    class = "domain"};
 461                                            your_usrs := Acl.class {user = getUser (),
 462                                                                    class = "user"};
 463                                            your_grps := Acl.class {user = getUser (),
 464                                                                    class = "group"};
 465                                            your_pths := Acl.class {user = getUser (),
 466                                                                    class = "path"}))
 467
 468 val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 469                                                        fn cl => "Temp file cleanup failed: " ^ cl));
 470                                     OS.FileSys.mkDir Config.tmpDir;
 471                                     app (fn node => OS.FileSys.mkDir
 472                                                         (OS.Path.joinDirFile {dir = Config.tmpDir,
 473                                                                               file = node}))
 474                                         nodes;
 475                                     app (fn node => OS.FileSys.mkDir
 476                                                         (OS.Path.joinDirFile {dir = Config.resultRoot,
 477                                                                               file = node})
 478                                             handle OS.SysErr _ => ())
 479                                         nodes))
 480
 481 val () = Env.registerPost (fn () =>
 482                               let
 483                                   val diffs = findAllDiffs ()
 484
 485                                   val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>
 486                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 487                                                                   fn cl => "Copy failed: " ^ cl);
 488                                                        (site,
 489                                                         {action = Slave.Add,
 490                                                          domain = dom,
 491                                                          dir = dir,
 492                                                          file = dst}))
 493                                                     | (site, dom, dir, Delete' dst) =>
 494                                                       (OS.FileSys.remove dst
 495                                                        handle OS.SysErr _ =>
 496                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 497                                                        (site,
 498                                                         {action = Slave.Delete,
 499                                                          domain = dom,
 500                                                          dir = dir,
 501                                                          file = dst}))
 502                                                     | (site, dom, dir, Modify' {src, dst}) =>
 503                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 504                                                                   fn cl => "Copy failed: " ^ cl);
 505                                                        (site,
 506                                                         {action = Slave.Modify,
 507                                                          domain = dom,
 508                                                          dir = dir,
 509                                                          file = dst}))) diffs
 510                               in
 511                                   if !ErrorMsg.anyErrors then
 512                                       ()
 513                                   else
 514                                       Slave.handleChanges (map #2 diffs)(*;
 515                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
 516                                                      fn cl => "Temp file cleanup failed: " ^ cl))*)
 517                               end)
 518
 519
 520
 521 end