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 fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
  24
  25 fun validHost s =
  26     size s > 0 andalso size s < 20
  27     andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
  28
  29 fun validDomain s =
  30     size s > 0 andalso size s < 100
  31     andalso List.all validHost (String.fields (fn ch => ch = #".") s)
  32
  33 val _ = Env.type_one "host"
  34         Env.string
  35         validHost
  36
  37 val _ = Env.type_one "domain"
  38         Env.string
  39         validDomain
  40
  41 open Ast
  42
  43 val befores = ref (fn (_ : string) => ())
  44 val afters = ref (fn (_ : string) => ())
  45
  46 fun registerBefore f =
  47     let
  48         val old = !befores
  49     in
  50         befores := (fn x => (old x; f x))
  51     end
  52
  53 fun registerAfter f =
  54     let
  55         val old = !afters
  56     in
  57         afters := (fn x => (old x; f x))
  58     end
  59
  60 val current = ref ""
  61 val currentPath = ref ""
  62
  63 val scratch = ref ""
  64
  65 fun currentDomain () = !current
  66
  67 fun domainFile name = TextIO.openOut (!currentPath ^ name)
  68
  69 fun getPath domain =
  70     let
  71         val toks = String.fields (fn ch => ch = #".") domain
  72
  73         val elems = foldr (fn (piece, elems) =>
  74                               let
  75                                   val elems = piece :: elems
  76                                   val path = String.concatWith "/" (Config.resultRoot :: rev elems)
  77                                   val tmpPath = String.concatWith "/" (Config.tmpDir :: rev elems)
  78                               in
  79                                   (if Posix.FileSys.ST.isDir
  80                                           (Posix.FileSys.stat path) then
  81                                        ()
  82                                    else
  83                                        (OS.FileSys.remove path;
  84                                         OS.FileSys.mkDir path))
  85                                   handle OS.SysErr _ => OS.FileSys.mkDir path;
  86
  87                                   (if Posix.FileSys.ST.isDir
  88                                           (Posix.FileSys.stat tmpPath) then
  89                                        ()
  90                                    else
  91                                        (OS.FileSys.remove tmpPath;
  92                                         OS.FileSys.mkDir tmpPath))
  93                                   handle OS.SysErr _ => OS.FileSys.mkDir tmpPath;
  94
  95                                   elems
  96                               end) [] toks
  97     in
  98         fn root => String.concatWith "/" (root :: rev ("" :: elems))
  99     end
 100
 101 datatype file_action' =
 102          Add' of {src : string, dst : string}
 103        | Delete' of string
 104        | Modify' of {src : string, dst : string}
 105
 106 fun findDiffs dom =
 107     let
 108         val realPath = getPath dom Config.resultRoot
 109         val tmpPath = !currentPath
 110
 111         val dir = Posix.FileSys.opendir realPath
 112
 113         fun loopReal acts =
 114             case Posix.FileSys.readdir dir of
 115                 NONE => (Posix.FileSys.closedir dir;
 116                          acts)
 117               | SOME fname =>
 118                 let
 119                     val real = OS.Path.joinDirFile {dir = realPath,
 120                                                     file = fname}
 121                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 122                                                    file = fname}
 123                 in
 124                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat real) then
 125                         loopReal acts
 126                     else if Posix.FileSys.access (tmp, []) then
 127                         if Slave.shell [Config.diff, " ", real, " ",  tmp] then
 128                             loopReal acts
 129                         else
 130                             loopReal (Modify' {src = tmp, dst = real} :: acts)
 131                     else
 132                         loopReal (Delete' real :: acts)
 133                 end
 134
 135         val acts = loopReal []
 136
 137         val dir = Posix.FileSys.opendir tmpPath
 138
 139         fun loopTmp acts =
 140             case Posix.FileSys.readdir dir of
 141                 NONE => (Posix.FileSys.closedir dir;
 142                          acts)
 143               | SOME fname =>
 144                 let
 145                     val real = OS.Path.joinDirFile {dir = realPath,
 146                                                     file = fname}
 147                     val tmp = OS.Path.joinDirFile {dir = tmpPath,
 148                                                    file = fname}
 149                 in
 150                     if Posix.FileSys.ST.isDir (Posix.FileSys.stat tmp) then
 151                         loopTmp acts
 152                     else if Posix.FileSys.access (real, []) then
 153                         loopTmp acts
 154                     else
 155                         loopTmp (Add' {src = tmp, dst = real} :: acts)
 156                 end
 157
 158         val acts = loopTmp acts
 159     in
 160         acts
 161     end
 162
 163 val _ = Env.container_one "domain"
 164                           ("domain", Env.string)
 165                           (fn dom =>
 166                               let
 167                                   val path = getPath dom Config.tmpDir
 168                               in
 169                                   current := dom;
 170                                   currentPath := path;
 171                                   !befores dom
 172                               end,
 173                            fn () =>
 174                               let
 175                                   val dom = !current
 176                                   val () = !afters dom
 177
 178                                   val diffs = findDiffs dom
 179
 180                                   val diffs = map (fn Add' {src, dst} =>
 181                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 182                                                               fn cl => "Copy failed: " ^ cl);
 183                                                        {action = Slave.Add,
 184                                                         domain = dom,
 185                                                         file = dst})
 186                                                     | Delete' dst =>
 187                                                       (OS.FileSys.remove dst
 188                                                        handle OS.SysErr _ =>
 189                                                               ErrorMsg.error NONE ("Delete failed for " ^ dst);
 190                                                        {action = Slave.Delete,
 191                                                         domain = dom,
 192                                                         file = dst})
 193                                                     | Modify' {src, dst} =>
 194                                                       (Slave.shellF ([Config.cp, " ", src, " ", dst],
 195                                                            fn cl => "Copy failed: " ^ cl);
 196                                                        {action = Slave.Modify,
 197                                                         domain = dom,
 198                                                         file = dst})) diffs
 199                               in
 200                                   if !ErrorMsg.anyErrors then
 201                                       ()
 202                                   else
 203                                       Slave.handleChanges diffs;
 204                                   ignore (Slave.shellF ([Config.rm, " -rf ", Config.tmpDir, "/*"],
 205                                                   fn cl => "Temp file cleanup failed: " ^ cl))
 206                               end)
 207
 208 end