Various improvements made while working on relwiki

[bpt/mlt.git] / src / lib / web.sml

diff --git a/src/lib/web.sml b/src/lib/web.sml
index a446e62..ebd49fb 100644 (file)
--- a/src/lib/web.sml
+++ b/src/lib/web.sml
@@ -78,17 +78,28 @@ struct
         ((f ()) handle ex => (popParams (); raise ex))
         before popParams ())
 
+    val headers = ref (StringMap.empty : string StringMap.map)
+    fun setHeader (n, v) = headers := StringMap.insert (!headers, n, v)
+    fun getHeader n = StringMap.find (!headers, n)
+
     val text = ref ([] : string list)
 
     fun print x = text := x :: (!text)
     fun clear () = text := []
     fun noOutput () = !text = []
     fun output () =
-       (TextIO.print "Status: 200\nContent-type: text/html\n\n";
+       (TextIO.print "Status: 200\n";
+        StringMap.appi (fn (n, v) => (TextIO.print n;
+                                      TextIO.print ": ";
+                                      TextIO.print v;
+                                      TextIO.print "\n")) (!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;"
@@ -97,7 +108,7 @@ struct
              | xch #"\"" = "&quot;"
              | xch ch = str ch
        in
-           foldr op^ "" (map xch (String.explode s))
+           String.concat (map xch (explode s))
        end
 
     fun htmlNl s =
@@ -109,7 +120,26 @@ struct
              | xch #"\n" = "<br />"
              | xch ch = str ch
        in
-           foldr op^ "" (map xch (String.explode s))
+           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
@@ -133,4 +163,94 @@ struct
     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
+           setHeader ("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 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
\ No newline at end of file