Simple OpenSSL stuff in SML/NJ

[hcoop/domtool2.git] / src / domain.sml

diff --git a/src/domain.sml b/src/domain.sml
index 534e440..27bc806 100644 (file)
--- a/src/domain.sml
+++ b/src/domain.sml
@@ -20,6 +20,36 @@
 
 structure Domain :> DOMAIN = struct
 
 
 structure Domain :> DOMAIN = struct
 

+structure SM = DataStructures.StringMap
+structure SS = DataStructures.StringSet
+
+val nodes = map #1 Config.nodeIps
+val nodeMap = foldl (fn ((node, ip), mp) => SM.insert (mp, node, ip))
+                   SM.empty Config.nodeIps
+fun nodeIp node = valOf (SM.find (nodeMap, node))
+
+val usr = ref ""
+fun setUser ur = usr := ur
+fun getUser () = !usr
+
+val your_doms = ref SS.empty
+fun your_domains () = !your_doms
+
+val your_usrs = ref SS.empty
+fun your_users () = !your_usrs
+
+val your_grps = ref SS.empty
+fun your_groups () = !your_grps
+
+val your_pths = ref SS.empty
+fun your_paths () = !your_pths
+
+fun validIp s =
+    case map Int.fromString (String.fields (fn ch => ch = #".") s) of
+       [SOME n1, SOME n2, SOME n3, SOME n4] =>
+       n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
+      | _ => false
+

 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
 
 fun validHost s =
 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
 
 fun validHost s =


@@ -30,6 +60,44 @@ fun validDomain s =
     size s > 0 andalso size s < 100
     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
 
     size s > 0 andalso size s < 100
     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
 

+fun validNode s = List.exists (fn s' => s = s') nodes
+
+fun yourDomain s = SS.member (your_domains (), s)
+fun yourUser s = SS.member (your_users (), s)
+fun yourGroup s = SS.member (your_groups (), s)
+fun yourPath path =
+    List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
+    andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"/"
+                                    orelse ch = #"-" orelse ch = #"_") path
+    andalso SS.exists (fn s' => path = s' orelse String.isPrefix (s' ^ "/") path) (your_paths ())
+
+fun yourDomainHost s =
+    yourDomain s
+    orelse let
+       val (pref, suf) = Substring.splitl (fn ch => ch <> #".") (Substring.full s)
+    in
+       Substring.size suf > 0
+       andalso validHost (Substring.string pref)
+       andalso yourDomain (Substring.string
+                               (Substring.slice (suf, 1, NONE)))
+    end
+
+fun validUser s = size s > 0 andalso size s < 20
+                 andalso CharVector.all Char.isAlphaNum s
+
+val validGroup = validUser
+
+val _ = Env.type_one "no_spaces"
+                    Env.string
+                    (CharVector.all (fn ch => not (Char.isSpace ch)))
+val _ = Env.type_one "no_newlines"
+                    Env.string
+                    (CharVector.all (fn ch => ch <> #"\n" andalso ch <> #"\r"))
+
+val _ = Env.type_one "ip"
+       Env.string
+       validIp
+

 val _ = Env.type_one "host"
        Env.string
        validHost
 val _ = Env.type_one "host"
        Env.string
        validHost


@@ -38,8 +106,125 @@ val _ = Env.type_one "domain"
        Env.string
        validDomain
 
        Env.string
        validDomain
 

+val _ = Env.type_one "your_domain"
+       Env.string
+       yourDomain
+
+val _ = Env.type_one "your_domain_host"
+       Env.string
+       yourDomainHost
+
+val _ = Env.type_one "user"
+       Env.string
+       validUser
+
+val _ = Env.type_one "group"
+       Env.string
+       validGroup
+
+val _ = Env.type_one "your_user"
+       Env.string
+       yourUser
+
+val _ = Env.type_one "your_group"
+       Env.string
+       yourGroup
+
+val _ = Env.type_one "your_path"
+       Env.string
+       yourPath
+
+val _ = Env.type_one "node"
+       Env.string
+       validNode
+

 open Ast
 
 open Ast
 

+val dl = ErrorMsg.dummyLoc
+
+val nsD = (EString Config.defaultNs, dl)
+val serialD = (EVar "serialAuto", dl)
+val refD = (EInt Config.defaultRefresh, dl)
+val retD = (EInt Config.defaultRetry, dl)
+val expD = (EInt Config.defaultExpiry, dl)
+val minD = (EInt Config.defaultMinimum, dl)
+
+val soaD = multiApp ((EVar "soa", dl),
+                    dl,
+                    [nsD, serialD, refD, retD, expD, minD])
+
+val masterD = (EApp ((EVar "internalMaster", dl),
+                    (EString Config.defaultNode, dl)),
+              dl)
+
+val _ = Main.registerDefault ("DNS",
+                             (TBase "dnsKind", dl),
+                             (fn () => multiApp ((EVar "useDns", dl),
+                                        dl,
+                                        [soaD, masterD, (EList [], dl)])))
+
+val _ = Main.registerDefault ("TTL",
+                             (TBase "int", dl),
+                             (fn () => (EInt Config.Bind.defaultTTL, dl)))
+
+type soa = {ns : string,
+           serial : int option,
+           ref : int,
+           ret : int,
+           exp : int,
+           min : int}
+
+val serial = fn (EVar "serialAuto", _) => SOME NONE
+             | (EApp ((EVar "serialConst", _), n), _) => Option.map SOME (Env.int n)
+             | _ => NONE
+
+val soa = fn (EApp ((EApp ((EApp ((EApp ((EApp ((EApp 
+                                                    ((EVar "soa", _), ns), _),
+                                               sl), _),
+                                        rf), _),
+                                 ret), _),
+                          exp), _),
+                   min), _) =>
+            (case (Env.string ns, serial sl, Env.int rf,
+                   Env.int ret, Env.int exp, Env.int min) of
+                 (SOME ns, SOME sl, SOME rf,
+                  SOME ret, SOME exp, SOME min) =>
+                 SOME {ns = ns,
+                       serial = sl,
+                       ref = rf,
+                       ret = ret,
+                       exp = exp,
+                       min = min}
+               | _ => NONE)
+          | _ => NONE
+
+datatype master =
+        ExternalMaster of string
+       | InternalMaster of string
+
+val master = fn (EApp ((EVar "externalMaster", _), e), _) => Option.map ExternalMaster (Env.string e)
+             | (EApp ((EVar "internalMaster", _), e), _) => Option.map InternalMaster (Env.string e)
+             | _ => NONE
+
+datatype dnsKind =
+        UseDns of {soa : soa,
+                   master : master,
+                   slaves : string list}
+       | NoDns
+
+val dnsKind = fn (EApp ((EApp ((EApp 
+                                   ((EVar "useDns", _), sa), _),
+                              mstr), _),
+                       slaves), _) =>
+                (case (soa sa, master mstr, Env.list Env.string slaves) of
+                     (SOME sa, SOME mstr, SOME slaves) =>
+                     SOME (UseDns {soa = sa,
+                                   master = mstr,
+                                   slaves = slaves})
+                   | _ => NONE)
+              | (EVar "noDns", _) => SOME NoDns
+              | _ => NONE
+

 val befores = ref (fn (_ : string) => ())
 val afters = ref (fn (_ : string) => ())
 
 val befores = ref (fn (_ : string) => ())
 val afters = ref (fn (_ : string) => ())
 


@@ -58,13 +243,14 @@ fun registerAfter f =
     end
 
 val current = ref ""
     end
 
 val current = ref ""

-val currentPath = ref ""
+val currentPath = ref (fn (_ : string) => "")

 
 val scratch = ref ""
 
 fun currentDomain () = !current
 
 
 val scratch = ref ""
 
 fun currentDomain () = !current
 

-fun domainFile name = TextIO.openOut (!currentPath ^ name)
+fun domainFile {node, name} = ((*print ("Opening " ^ !currentPath node ^ name ^ "\n");*)
+                              TextIO.openOut (!currentPath node ^ name))

 
 fun getPath domain =
     let
 
 fun getPath domain =
     let


@@ -73,29 +259,36 @@ fun getPath domain =
        val elems = foldr (fn (piece, elems) =>
                              let
                                  val elems = piece :: elems
        val elems = foldr (fn (piece, elems) =>
                              let
                                  val elems = piece :: elems

-                                 val path = String.concatWith "/" (Config.resultRoot :: rev elems)
-                                 val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems)
-                             in
-                                 (if Posix.FileSys.ST.isDir
-                                         (Posix.FileSys.stat path) then
-                                      ()
-                                  else
-                                      (OS.FileSys.remove path;
-                                       OS.FileSys.mkDir path))
-                                 handle OS.SysErr _ => OS.FileSys.mkDir path;
-
-                                 (if Posix.FileSys.ST.isDir
-                                         (Posix.FileSys.stat tmpPath) then
-                                      ()
-                                  else
-                                      (OS.FileSys.remove tmpPath;
-                                       OS.FileSys.mkDir tmpPath))
-                                 handle OS.SysErr _ => OS.FileSys.mkDir tmpPath;

 
 

+                                 fun doNode node =
+                                     let
+                                         val path = String.concatWith "/"
+                                                                      (Config.resultRoot :: node :: rev elems)
+                                         val tmpPath = String.concatWith "/"
+                                                                         (Config.tmpDir :: node :: rev elems)
+                                     in
+                                         (if Posix.FileSys.ST.isDir
+                                                 (Posix.FileSys.stat path) then
+                                              ()
+                                          else
+                                              (OS.FileSys.remove path;
+                                               OS.FileSys.mkDir path))
+                                         handle OS.SysErr _ => OS.FileSys.mkDir path;
+
+                                         (if Posix.FileSys.ST.isDir
+                                                 (Posix.FileSys.stat tmpPath) then
+                                              ()
+                                          else
+                                              (OS.FileSys.remove tmpPath;
+                                               OS.FileSys.mkDir tmpPath))
+                                         handle OS.SysErr _ => OS.FileSys.mkDir tmpPath
+                                     end
+                             in
+                                 app doNode nodes;

                                  elems
                              end) [] toks
     in
                                  elems
                              end) [] toks
     in

-       fn root => String.concatWith "/" (root :: rev ("" :: elems))
+       fn (root, site) => String.concatWith "/" (root :: site :: rev ("" :: elems))

     end
 
 datatype file_action' =
     end
 
 datatype file_action' =


@@ -103,10 +296,13 @@ datatype file_action' =
        | Delete' of string
        | Modify' of {src : string, dst : string}
 
        | Delete' of string
        | Modify' of {src : string, dst : string}
 

-fun findDiffs dom =
+fun findDiffs (site, dom, acts) =

     let
     let

-       val realPath = getPath dom Config.resultRoot
-       val tmpPath = !currentPath
+       val gp = getPath dom
+       val realPath = gp (Config.resultRoot, site)
+       val tmpPath = gp (Config.tmpDir, site)
+
+       (*val _ = print ("getDiffs(" ^ site ^ ", " ^ dom ^ ")... " ^ realPath ^ "; " ^ tmpPath ^ "\n")*)

 
        val dir = Posix.FileSys.opendir realPath
 
 
        val dir = Posix.FileSys.opendir realPath
 


@@ -127,12 +323,12 @@ fun findDiffs dom =
                        if Slave.shell [Config.diff, " ", real, " ",  tmp] then
                            loopReal acts
                        else
                        if Slave.shell [Config.diff, " ", real, " ",  tmp] then
                            loopReal acts
                        else

-                           loopReal (Modify' {src = tmp, dst = real} :: acts)
+                           loopReal ((site, dom, realPath, Modify' {src = tmp, dst = real}) :: acts)

                    else
                    else

-                       loopReal (Delete' real :: acts)
+                       loopReal ((site, dom, realPath, Delete' real) :: acts)

                end
 
                end
 

-       val acts = loopReal []
+       val acts = loopReal acts

 
        val dir = Posix.FileSys.opendir tmpPath
 
 
        val dir = Posix.FileSys.opendir tmpPath
 


@@ -152,7 +348,7 @@ fun findDiffs dom =
                    else if Posix.FileSys.access (real, []) then
                        loopTmp acts
                    else
                    else if Posix.FileSys.access (real, []) then
                        loopTmp acts
                    else

-                       loopTmp (Add' {src = tmp, dst = real} :: acts)
+                       loopTmp ((site, dom, realPath, Add' {src = tmp, dst = real}) :: acts)

                end
 
        val acts = loopTmp acts
                end
 
        val acts = loopTmp acts


@@ -160,49 +356,202 @@ fun findDiffs dom =
        acts
     end
 
        acts
     end
 

-val _ = Env.container_one "domain"
-                         ("domain", Env.string)
-                         (fn dom =>
-                             let
-                                 val path = getPath dom Config.tmpDir
-                             in
-                                 current := dom;
-                                 currentPath := path;
-                                 !befores dom
-                             end,
-                          fn () =>
-                             let
-                                 val dom = !current
-                                 val () = !afters dom
+fun findAllDiffs () =
+    let
+       val dir = Posix.FileSys.opendir Config.tmpDir
+       val len = length (String.fields (fn ch => ch = #"/") Config.tmpDir) + 1

 
 

-                                 val diffs = findDiffs dom
+       fun exploreSites diffs =
+           case Posix.FileSys.readdir dir of
+               NONE => diffs
+             | SOME site =>
+               let
+                   fun explore (dname, diffs) =
+                       let
+                           val dir = Posix.FileSys.opendir dname

 
 

-                                 val diffs = map (fn Add' {src, dst} =>
+                           fun loop diffs =
+                               case Posix.FileSys.readdir dir of
+                                   NONE => diffs
+                                 | SOME name =>
+                                   let
+                                       val fname = OS.Path.joinDirFile {dir = dname,
+                                                                        file = name}
+                                   in
+                                       loop (if Posix.FileSys.ST.isDir (Posix.FileSys.stat fname) then
+                                                 let
+                                                     val dom = String.fields (fn ch => ch = #"/") fname
+                                                     val dom = List.drop (dom, len)
+                                                     val dom = String.concatWith "." (rev dom)
+
+                                                     val dname' = OS.Path.joinDirFile {dir = dname,
+                                                                                       file = name}
+                                                 in
+                                                     explore (dname',
+                                                              findDiffs (site, dom, diffs))
+                                                 end
+                                             else
+                                                 diffs)
+                                   end
+                       in
+                           loop diffs
+                           before Posix.FileSys.closedir dir
+                       end
+               in
+                   explore (OS.Path.joinDirFile {dir = Config.tmpDir,
+                                                 file = site}, diffs)
+               end
+    in
+       exploreSites []
+       before Posix.FileSys.closedir dir
+    end
+
+val masterNode : string option ref = ref NONE
+fun dnsMaster () = !masterNode
+
+val _ = Env.containerV_one "domain"
+                          ("domain", Env.string)
+                          (fn (evs, dom) =>
+                              let
+                                  val kind = Env.env dnsKind (evs, "DNS")
+                                  val ttl = Env.env Env.int (evs, "TTL")
+
+                                  val path = getPath dom
+
+                                  val () = (current := dom;
+                                            currentPath := (fn site => path (Config.tmpDir, site)))
+
+                                  fun saveSoa (kind, soa : soa) node =
+                                      let
+                                          val outf = domainFile {node = node, name = "soa"}
+                                      in
+                                          TextIO.output (outf, kind);
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString ttl);
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, #ns soa);
+                                          TextIO.output (outf, "\n");
+                                          case #serial soa of
+                                              NONE => ()
+                                            | SOME n => TextIO.output (outf, Int.toString n);
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#ref soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#ret soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#exp soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.output (outf, Int.toString (#min soa));
+                                          TextIO.output (outf, "\n");
+                                          TextIO.closeOut outf
+                                      end
+
+                                  fun saveNamed (kind, soa : soa, masterIp) node =
+                                      let
+                                          val outf = domainFile {node = node, name = "named.conf"}
+                                      in
+                                          TextIO.output (outf, "\nzone \"");
+                                          TextIO.output (outf, dom);
+                                          TextIO.output (outf, "\" IN {\n\ttype ");
+                                          TextIO.output (outf, kind);
+                                          TextIO.output (outf, ";\n\tfile \"");
+                                          TextIO.output (outf, Config.Bind.zonePath);
+                                          TextIO.output (outf, "/");
+                                          TextIO.output (outf, dom);
+                                          TextIO.output (outf, ".zone\";\n");
+                                          case kind of
+                                              "master" => TextIO.output (outf, "\tallow-update { none; };\n")
+                                            | _ => (TextIO.output (outf, "\tmasters { ");
+                                                    TextIO.output (outf, masterIp);
+                                                    TextIO.output (outf, " };\n"));
+                                          TextIO.output (outf, "};\n");
+                                          TextIO.closeOut outf
+                                      end
+                              in
+                                  case kind of
+                                      NoDns => masterNode := NONE
+                                    | UseDns dns =>
+                                      let
+                                          val masterIp =
+                                              case #master dns of
+                                                  InternalMaster node => valOf (SM.find (nodeMap, node))
+                                                | ExternalMaster ip => ip
+                                      in
+                                          app (saveSoa ("slave", #soa dns)) (#slaves dns);
+                                          app (saveNamed ("slave", #soa dns, masterIp)) (#slaves dns);
+                                          case #master dns of
+                                              InternalMaster node =>
+                                              (masterNode := SOME node;
+                                               saveSoa ("master", #soa dns) node;
+                                               saveNamed ("master", #soa dns, masterIp) node)
+                                            | _ => masterNode := NONE;
+                                          !befores dom
+                                      end
+                              end,
+                           fn () => !afters (!current))
+
+val () = Env.registerPreTycheck (fn () => (setUser Config.testUser;
+                                          Acl.read Config.aclFile;
+                                          your_doms := Acl.class {user = getUser (),
+                                                                  class = "domain"};
+                                          your_usrs := Acl.class {user = getUser (),
+                                                                  class = "user"};
+                                          your_grps := Acl.class {user = getUser (),
+                                                                  class = "group"};
+                                          your_pths := Acl.class {user = getUser (),
+                                                                  class = "path"}))
+
+val () = Env.registerPre (fn () => (ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
+                                                      fn cl => "Temp file cleanup failed: " ^ cl));
+                                   OS.FileSys.mkDir Config.tmpDir;
+                                   app (fn node => OS.FileSys.mkDir
+                                                       (OS.Path.joinDirFile {dir = Config.tmpDir,
+                                                                             file = node}))
+                                       nodes;
+                                   app (fn node => OS.FileSys.mkDir
+                                                       (OS.Path.joinDirFile {dir = Config.resultRoot,
+                                                                             file = node})
+                                           handle OS.SysErr _ => ())
+                                       nodes))
+
+val () = Env.registerPost (fn () =>
+                             let
+                                 val diffs = findAllDiffs ()
+
+                                 val diffs = map (fn (site, dom, dir, Add' {src, dst}) =>

                                                      (Slave.shellF ([Config.cp, " ", src, " ", dst],
                                                      (Slave.shellF ([Config.cp, " ", src, " ", dst],

-                                                             fn cl => "Copy failed: " ^ cl);
-                                                      {action = Slave.Add,
-                                                       domain = dom,
-                                                       file = dst})
-                                                   | Delete' dst =>
+                                                                 fn cl => "Copy failed: " ^ cl);
+                                                      (site,
+                                                       {action = Slave.Add,
+                                                        domain = dom,
+                                                        dir = dir,
+                                                        file = dst}))
+                                                   | (site, dom, dir, Delete' dst) =>

                                                      (OS.FileSys.remove dst
                                                       handle OS.SysErr _ =>
                                                              ErrorMsg.error NONE ("Delete failed for " ^ dst);
                                                      (OS.FileSys.remove dst
                                                       handle OS.SysErr _ =>
                                                              ErrorMsg.error NONE ("Delete failed for " ^ dst);

-                                                      {action = Slave.Delete,
-                                                       domain = dom,
-                                                       file = dst})
-                                                   | Modify' {src, dst} =>
+                                                      (site,
+                                                       {action = Slave.Delete,
+                                                        domain = dom,
+                                                        dir = dir,
+                                                        file = dst}))
+                                                   | (site, dom, dir, Modify' {src, dst}) =>

                                                      (Slave.shellF ([Config.cp, " ", src, " ", dst],
                                                      (Slave.shellF ([Config.cp, " ", src, " ", dst],

-                                                          fn cl => "Copy failed: " ^ cl);
-                                                      {action = Slave.Modify,
-                                                       domain = dom,
-                                                       file = dst})) diffs
+                                                                 fn cl => "Copy failed: " ^ cl);
+                                                      (site,
+                                                       {action = Slave.Modify,
+                                                        domain = dom,
+                                                        dir = dir,
+                                                        file = dst}))) diffs

                              in
                                  if !ErrorMsg.anyErrors then
                                      ()
                                  else
                              in
                                  if !ErrorMsg.anyErrors then
                                      ()
                                  else

-                                     Slave.handleChanges diffs;
-                                 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
-                                                 fn cl => "Temp file cleanup failed: " ^ cl))
+                                     Slave.handleChanges (map #2 diffs);
+                                 ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, ""],
+                                                    fn cl => "Temp file cleanup failed: " ^ cl))

                              end)
 
                              end)
 

+
+

 end
 end