Better checking of Block arguments

[hcoop/zz_old/domtool.git] / src / util.sml

(*
Domtool (http://hcoop.sf.net/)
Copyright (C) 2004  Adam Chlipala

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
*)

(* Utility functions *)

structure Util :> UTIL =
struct
    fun impLoop next stop body init =
	let
	    fun loop state =
		let
		    val v = next ()
		in
		    if stop v then
			()
		    else
			loop (body (v, state))
		end
	in
	    loop init
	end

    fun ioOptLoop next body init =
	let
	    fun loop state =
		case next () of
		    NONE => ()
		  | SOME v => loop (body (v, state))
	in
	    loop init
	end

    fun ioOptLoopFold next body init =
	let
	    fun loop state =
		case next () of
		    NONE => state
		  | SOME v => loop (body (v, state))
	in
	    loop init
	end

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

    fun isInt s = Int.fromString s <> NONE

    fun isNat s = CharVector.all Char.isDigit s

    fun chop s = String.substring (s, 0, size s - 1)

    fun validHost s =
	size s > 0 andalso size s < 30
	andalso CharVector.all (fn ch => isIdent ch orelse ch = #"-") s
	andalso CharVector.exists (fn ch => not (Char.isDigit ch)) s

    fun validHostUC s =
	size s > 0 andalso size s < 30
	andalso CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"-") s
	andalso CharVector.exists (fn ch => not (Char.isDigit ch)) s

    fun validVhostFilename s =
	case String.fields (fn ch => ch = #".") s of
	    [s] => validHost s
	  | [s, "ssl"] => validHost s
	  | _ => false
		       
    fun validDomain s =
	size s > 0 andalso size s < 100 andalso List.all validHost (String.fields (fn ch => ch = #".") s)

    fun validDomainUC s =
	size s > 0 andalso size s < 100 andalso List.all validHostUC (String.fields (fn ch => ch = #".") s)

    fun validLocation s =
	size s > 0 andalso size s < 1000 andalso CharVector.all
						 (fn ch => Char.isAlphaNum ch
							   orelse ch = #"-"
							   orelse ch = #"_"
							   orelse ch = #"."
							   orelse ch = #"/") s

    fun validDomainId s =
	case String.fields (fn ch => ch = #"_") s of
	    [_] => validDomain s
	  | [host, rest] =>
	    (validHost host andalso case String.tokens (fn ch => ch = #".") rest of
		 "ssl" :: rest => List.all validHost rest
	       | _ => false)
	  | _ => false

    fun validUser s =
	size s > 0 andalso size s < 50 andalso CharVector.all
						   (fn ch => isIdent ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
						   s

    fun validEmailUser s =
	size s > 0 andalso size s < 50 andalso CharVector.all
						   (fn ch => Char.isAlphaNum ch orelse ch = #"." orelse ch = #"_" orelse ch = #"-" orelse ch = #"+")
						   s
    fun validEmail s =
	(case String.fields (fn ch => ch = #"@") s of
	     [user, host] => validEmailUser user andalso validDomain host
	   | _ => false)

    fun isTmp s =
	CharVector.exists (fn ch => ch = #"#" orelse ch = #"~") s

    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 trimLast s =
	if size s = 0 then
	    s
	else
	    String.substring (s, 0, size s - 1)

    fun toDir s =
	foldr (fn (a, s) => s ^ "/" ^ a) "" (String.tokens (fn ch => ch = #".") s)

    fun checkPath (paths, path) =
	StringSet.exists (fn pref => path = pref orelse (size path >= size pref + 2 andalso substring (path, 0, size pref) = pref
						    andalso String.sub (path, size pref) = #"/")) paths
	andalso 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

    fun resolveAddr (vars, s) =
	if validIp s then
	    s
	else
	    (case StringMap.find (vars, s) of
		 NONE => ""
	       | SOME v =>
		 if validIp v then
		     v
		 else
		     "")

    fun resolveDomain (vars, s) =
	if validDomain s then
	    s
	else
	    (case StringMap.find (vars, s) of
		 NONE => ""
	       | SOME v =>
		 if validDomain v then
		     v
		 else
		     "")

    fun enrichSetFromFile (fname, set) =
	let
	    open TextIO
	    val uid = Posix.ProcEnv.wordToUid (SysWord.fromInt Config.uid)
	in
	    if Posix.FileSys.access (fname, []) then
		(if Posix.FileSys.ST.uid (Posix.FileSys.stat fname) = uid then
		     let
			 val vf = openIn fname
				  
			 fun loop set =
			     let
				 val line = inputLine vf
			     in
				 case line of
				     NONE => set
				   | SOME "CLEAR\n" => loop StringSet.empty
				   | SOME line =>
				     (case String.tokens Char.isSpace line of
					  [item] => loop (StringSet.add (set, item))
					| _ => loop set)
			     end
		     in
			 loop set
			 before TextIO.closeIn vf
		     end
		 else
		     (print (fname ^ ": wrong owner to be used\n");
		      set))
	    else
		set
	end

    fun enrichMapFromFile (fname, map) =
	let
	    open TextIO
	    val uid = Posix.ProcEnv.wordToUid (SysWord.fromInt Config.uid)
	in
	    if Posix.FileSys.access (fname, []) then
		(if Posix.FileSys.ST.uid (Posix.FileSys.stat fname) = uid then
		     let
			 val vf = openIn fname
				  
			 fun loop map =
			     let
				 val line = inputLine vf
			     in
				 case line of
				     NONE => map
				   | SOME "CLEAR\n" => loop StringMap.empty
				   | SOME line =>
				     (case String.tokens Char.isSpace line of
					  [key, value] => loop (StringMap.insert (map, key, value))
					| [] => loop map
					| _ => (print (fname ^ ": invalid line: " ^ line);
					       loop map))
			     end
		     in
			 loop map
			 before TextIO.closeIn vf
		     end
		 else
		     (print (fname ^ ": wrong owner to be used");
		      map))
	    else
		map
	end

    fun merge (L1 : ('a * int) list, L2 : ('a * int) list) acc =
	case (L1, L2) of
	    (_, []) => List.revAppend (acc, L1)
	  | ([], _) => List.revAppend (acc, L2)
	  | (n1::t1, n2::t2) =>
	    if #2 n1 > #2 n2 then
		merge (t1, L2) (n1 :: acc)
	    else
		merge (L1, t2) (n2 :: acc)

    fun split n L acc =
	if n <= 0 then
	    (acc, L)
	else
	    case L of
		[] => (acc, [])
	      | h::t => split (n-1) t (h::acc)

    fun mergeSort L =
	case L of
	    [] => L
	  | [a] => L
	  | _ =>
	    let
		val mid = length L div 2
		val (L1, L2) = split mid L []
	    in
		merge (mergeSort L1, mergeSort L2) []
	    end

    fun member (x, L) = List.exists (fn y => y = x) L
end