src/util.sml

   1 (*
   2 Domtool (http://hcoop.sf.net/)
   3 Copyright (C) 2004  Adam Chlipala
   4
   5 This program is free software; you can redistribute it and/or
   6 modify it under the terms of the GNU General Public License
   7 as published by the Free Software Foundation; either version 2
   8 of the License, or (at your option) any later version.
   9
  10 This program is distributed in the hope that it will be useful,
  11 but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 GNU General Public License for more details.
  14
  15 You should have received a copy of the GNU General Public License
  16 along with this program; if not, write to the Free Software
  17 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
  18 *)
  19
  20 (* Utility functions *)
  21
  22 structure Util :> UTIL =
  23 struct
  24     fun impLoop next stop body init =
  25         let
  26             fun loop state =
  27                 let
  28                     val v = next ()
  29                 in
  30                     if stop v then
  31                         ()
  32                     else
  33                         loop (body (v, state))
  34                 end
  35         in
  36             loop init
  37         end
  38
  39     fun ioOptLoop next body init =
  40         let
  41             fun loop state =
  42                 case next () of
  43                     NONE => ()
  44                   | SOME v => loop (body (v, state))
  45         in
  46             loop init
  47         end
  48
  49     fun ioOptLoopFold next body init =
  50         let
  51             fun loop state =
  52                 case next () of
  53                     NONE => state
  54                   | SOME v => loop (body (v, state))
  55         in
  56             loop init
  57         end
  58
  59     fun isIdent ch = Char.isLower ch orelse Char.isDigit ch
  60
  61     fun isInt s = Int.fromString s <> NONE
  62
  63     fun isNat s =
  64         case Int.fromString s of
  65             NONE => false
  66           | SOME n => n >= 0
  67
  68     fun chop s = String.substring (s, 0, size s - 1)
  69
  70     fun validHost s =
  71         size s > 0 andalso size s < 20 andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
  72
  73     fun validVhostFilename s =
  74         case String.fields (fn ch => ch = #".") s of
  75             [s] => validHost s
  76           | [s, "ssl"] => validHost s
  77           | _ => false
  78
  79     fun validDomain s =
  80         size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s)
  81
  82     fun validDomainId s =
  83         case String.fields (fn ch => ch = #"_") s of
  84             [_] => validDomain s
  85           | [host, rest] =>
  86             (validHost host andalso case String.tokens (fn ch => ch = #".") rest of
  87                  "ssl" :: rest => List.all validHost rest
  88                | _ => false)
  89           | _ => false
  90
  91     fun validUser s =
  92         size s > 0 andalso size s < 50 andalso CharVector.all
  93                                                    (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
  94                                                    s
  95
  96     fun validEmailUser s =
  97         size s > 0 andalso size s < 50 andalso CharVector.all
  98                                                    (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
  99                                                    s
 100     fun validEmail s =
 101         (case String.fields (fn ch => ch = #"@") s of
 102              [user, host] => validEmailUser user andalso validDomain host
 103            | _ => false)
 104
 105     fun isTmp s =
 106         CharVector.exists (fn ch => ch = #"#" orelse ch = #"~") s
 107
 108     fun validIp s =
 109         (case map Int.fromString (String.fields (fn ch => ch = #".") s) of
 110              [SOME n1, SOME n2, SOME n3, SOME n4] =>
 111              n1 >= 0 andalso n1 < 256 andalso n2 >= 0 andalso n2 < 256 andalso n3 >= 0 andalso n3 < 256 andalso n4 >= 0 andalso n4 < 256
 112            | _ => false)
 113
 114     fun trimLast s =
 115         if size s = 0 then
 116             s
 117         else
 118             String.substring (s, 0, size s - 1)
 119
 120     fun toDir s =
 121         foldr (fn (a, s) => s ^ "/" ^ a) "" (String.tokens (fn ch => ch = #".") s)
 122
 123     fun checkPath (paths, path) =
 124         StringSet.exists (fn pref => path = pref orelse (size path >= size pref + 2 andalso substring (path, 0, size pref) = pref
 125                                                     andalso String.sub (path, size pref) = #"/")) paths
 126         andalso List.all (fn s => s <> "..") (String.fields (fn ch => ch = #"/") path)
 127
 128     fun resolveAddr (vars, s) =
 129         if validIp s then
 130             s
 131         else
 132             (case StringMap.find (vars, s) of
 133                  NONE => ""
 134                | SOME v =>
 135                  if validIp v then
 136                      v
 137                  else
 138                      "")
 139
 140     fun resolveDomain (vars, s) =
 141         if validDomain s then
 142             s
 143         else
 144             (case StringMap.find (vars, s) of
 145                  NONE => ""
 146                | SOME v =>
 147                  if validDomain v then
 148                      v
 149                  else
 150                      "")
 151
 152     fun enrichSetFromFile (fname, set) =
 153         let
 154             open TextIO
 155             val uid = Posix.ProcEnv.wordToUid (SysWord.fromInt Config.uid)
 156         in
 157             if Posix.FileSys.access (fname, []) then
 158                 (if Posix.FileSys.ST.uid (Posix.FileSys.stat fname) = uid then
 159                      let
 160                          val vf = openIn fname
 161
 162                          fun loop set =
 163                              let
 164                                  val line = inputLine vf
 165                              in
 166                                  case line of
 167                                      NONE => set
 168                                    | SOME "CLEAR\n" => loop StringSet.empty
 169                                    | SOME line =>
 170                                      (case String.tokens Char.isSpace line of
 171                                           [item] => loop (StringSet.add (set, item))
 172                                         | _ => loop set)
 173                              end
 174                      in
 175                          loop set
 176                          before TextIO.closeIn vf
 177                      end
 178                  else
 179                      (print (fname ^ ": wrong owner to be used");
 180                       set))
 181             else
 182                 set
 183         end
 184
 185     fun enrichMapFromFile (fname, map) =
 186         let
 187             open TextIO
 188             val uid = Posix.ProcEnv.wordToUid (SysWord.fromInt Config.uid)
 189         in
 190             if Posix.FileSys.access (fname, []) then
 191                 (if Posix.FileSys.ST.uid (Posix.FileSys.stat fname) = uid then
 192                      let
 193                          val vf = openIn fname
 194
 195                          fun loop map =
 196                              let
 197                                  val line = inputLine vf
 198                              in
 199                                  case line of
 200                                      NONE => map
 201                                    | SOME "CLEAR\n" => loop StringMap.empty
 202                                    | SOME line =>
 203                                      (case String.tokens Char.isSpace line of
 204                                           [key, value] => loop (StringMap.insert (map, key, value))
 205                                         | [] => loop map
 206                                         | _ => (print (fname ^ ": invalid line: " ^ line);
 207                                                loop map))
 208                              end
 209                      in
 210                          loop map
 211                          before TextIO.closeIn vf
 212                      end
 213                  else
 214                      (print (fname ^ ": wrong owner to be used");
 215                       map))
 216             else
 217                 map
 218         end
 219
 220     fun merge (L1 : ('a * int) list, L2 : ('a * int) list) acc =
 221         case (L1, L2) of
 222             (_, []) => List.revAppend (acc, L1)
 223           | ([], _) => List.revAppend (acc, L2)
 224           | (n1::t1, n2::t2) =>
 225             if #2 n1 > #2 n2 then
 226                 merge (t1, L2) (n1 :: acc)
 227             else
 228                 merge (L1, t2) (n2 :: acc)
 229
 230     fun split n L acc =
 231         if n <= 0 then
 232             (acc, L)
 233         else
 234             case L of
 235                 [] => (acc, [])
 236               | h::t => split (n-1) t (h::acc)
 237
 238     fun mergeSort L =
 239         case L of
 240             [] => L
 241           | [a] => L
 242           | _ =>
 243             let
 244                 val mid = length L div 2
 245                 val (L1, L2) = split mid L []
 246             in
 247                 merge (mergeSort L1, mergeSort L2) []
 248             end
 249 end
 250