(*
 * Dynamic web page generation with Standard ML
 * Copyright (C) 2003  Adam Chlipala
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library 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
 * Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)

(* CGI interaction *)

structure Web :> WEB =
struct
    fun for f (r1, r2) =
	if r1 < r2 then
	    let
		fun loop i =
		    if i > r2 then
			()
		    else
			(f i;
			 loop (i+1))
	    in
		loop r1
	    end
	else
	    let
		fun loop i =
		    if i < r2 then
			()
		    else
			(f i;
			 loop (i-1))
	    in
		loop r1
	    end

    val params : string list StringMap.map ref = ref StringMap.empty

    val paramStack : string list StringMap.map list ref = ref []

    fun setParam (n, v) = params := StringMap.insert (!params, n, v)
    fun setSingleParam (n, v) = setParam (n, [v])

    fun getParam v =
	(case StringMap.find (!params, v) of
	     NONE => ""
	   | SOME [] => ""
	   | SOME (s::_) => s)

    fun getMultiParam v =
	(case StringMap.find (!params, v) of
	     NONE => []
	   | SOME l => l)

    fun pushParams nvs =
	(paramStack := (!params) :: (!paramStack);
	 app setParam nvs)

    fun popParams () =
	(case !paramStack of
	     [] => raise Fail "Empty params stack in popParams"
	   | h::t => (params := h;
		      paramStack := t))

    fun withParams f nvs =
	(pushParams nvs;
	 ((f ()) handle ex => (popParams (); raise ex))
	 before popParams ())

    val headers = ref (StringMap.empty : string list StringMap.map)
    fun setHeader (n, v) = headers := StringMap.insert (!headers, n, v)
    fun getHeader n = StringMap.find (!headers, n)
    fun addHeader (n, v) =
	headers := StringMap.insert (!headers, n, case getHeader n of
						      NONE => [v]
						    | SOME vs => vs @ [v])
    fun getSingleHeader n =
	(case StringMap.find (!headers, n) of
	     SOME (v::_) => SOME v
	   | _ => NONE)

    val text = ref ([] : string list)

    fun print x = text := x :: (!text)
    fun clear () = text := []
    fun noOutput () = !text = []
    fun output () =
	(TextIO.print "Status: 200\n";
	 StringMap.appi (fn (n, vs) =>
			    app (fn v => (TextIO.print n;
					  TextIO.print ": ";
					  TextIO.print v;
					  TextIO.print "\n"))
				vs) (!headers);
	 TextIO.print "\n";
	 TextIO.print (String.concat (List.rev (!text))))

    val getCgi = OS.Process.getEnv

    val explode = CharVector.foldr (op::) []

    fun html s =
	let
	    fun xch #"<" = "&lt;"
	      | xch #">" = "&gt;"
	      | xch #"&" = "&amp;"
	      | xch #"\"" = "&quot;"
	      | xch ch = str ch
	in
	    String.concat (map xch (explode s))
	end

    fun htmlNl s =
	let
	    fun xch #"<" = "&lt;"
	      | xch #">" = "&gt;"
	      | xch #"&" = "&amp;"
	      | xch #"\"" = "&quot;"
	      | xch #"\n" = "<br />"
	      | xch ch = str ch
	in
	    String.concat  (map xch (explode s))
	end

    fun pad (n, ch) s =
	if size s < n then
	    pad (n, ch) (ch ^ s)
	else
	    s

    fun urlEncode s =
	let
	    fun xch ch =
		if Char.isAlphaNum ch orelse ch = #"." then
		    str ch
		else if ch = #" " then
		    "+"
		else
		    "%" ^ pad (2, "0") (Int.fmt StringCvt.HEX (ord ch))
	in
	    String.concat (map xch (explode s))
	end

    exception Format of string

    fun stoiOpt s = Int.fromString s
    fun stoi s =
	(case Int.fromString s of
	     NONE => raise Format s
	   | SOME i => i)

    fun storOpt s = Real.fromString s
    fun stor s =
	(case Real.fromString s of
	     NONE => raise Format s
	   | SOME r => r)

    fun summary () =
	StringMap.foldli (fn (n, vs, s) => foldl (fn (v, s) => s ^ " VALUE: " ^ v) (s ^ " NAME: " ^ n) vs)
	"" (!params)

    val exn = ref (NONE : exn option)
    fun setExn ex = exn := SOME ex
    fun getExn () = valOf (!exn)

    type cookie = {name : string, value : string, expires : Date.date option,
		   domain : string option, path : string option, secure : bool}

    fun setCookie {name, value, expires, domain, path, secure} =
	let
	    val s = name ^ "=" ^ value
	    val s =
		case expires of
		    NONE => s
		  | SOME date => s ^ "; expires=" ^ Date.fmt "%a, %d-%b-%Y %H:%M:%S GMT" date
	    val s =
		case domain of
		    NONE => s
		  | SOME dom => s ^ "; domain=" ^ dom
	    val s =
		case path of
		    NONE => s
		  | SOME path => s ^ "; path=" ^ path
	    val s =
		if secure then
		    s ^ "; secure"
		else
		    s
	in
	    addHeader ("Set-Cookie", s)
	end

    fun getCookie n =
	(case getCgi "HTTP_COOKIE" of
	     NONE => NONE
	   | SOME cookies =>
	     let
		 fun search (n'::v::rest) =
		     if n = n' then
			 SOME v
		     else
			 search rest
		   | search _ = NONE
	     in
		 search (String.tokens (fn ch => ch = #"=" orelse ch = #";" orelse ch = #" ") cookies)
	     end)

    fun remoteHost () =
	case getCgi "REMOTE_HOST" of
	    NONE => getCgi "REMOTE_ADDR"
	  | h => h

    fun plusSeconds (t, s) = Time.+ (t, Time.fromSeconds (LargeInt.fromInt s))
    fun minusSeconds (t, s) = Time.- (t, Time.fromSeconds (LargeInt.fromInt s))

    fun split (s, ch) =
	let
	    val len = size s

	    fun find i =
		if i >= len then
		    NONE
		else if String.sub (s, i) = ch then
		    SOME (String.substring (s, 0, i), String.extract (s, i+1, NONE))
		else
		    find (i+1)
	in
	    find 0
	end

    fun replaceUrlVar (url, n, v) =
	case split (url, #"?") of
	    NONE => url
	  | SOME (uri, qs)  =>
	    let
		fun doPair (nv, (L, yn)) =
		    (case split (nv, #"=") of
			 NONE => (nv::L, yn)
		       | SOME (n', v') =>
			 if n = n' then
			     ((n ^ "=" ^ v)::L, true)
			 else
			     (nv::L, yn))
		val (pairs, yn) = foldr doPair ([], false) (String.tokens (fn ch => ch = #"&") qs)
		val pairs =
		    if yn then
			pairs
		    else
			(n ^ "=" ^ v) :: pairs
	    in
		case pairs of
		    [] => url
		  | nv::rest => 
		    String.concat (uri :: "?" :: nv :: foldr (fn (nv, L) => "&"::nv::L) [] rest)
	    end
end