src/lib/web.sml

   1 (*
   2  * Dynamic web page generation with Standard ML
   3  * Copyright (C) 2003  Adam Chlipala
   4  *
   5  * This library is free software; you can redistribute it and/or
   6  * modify it under the terms of the GNU Lesser General Public
   7  * License as published by the Free Software Foundation; either
   8  * version 2.1 of the License, or (at your option) any later version.
   9  *
  10  * This library 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 GNU
  13  * Lesser General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU Lesser General Public
  16  * License along with this library; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  18  *)
  19
  20 (* CGI interaction *)
  21
  22 structure Web :> WEB =
  23 struct
  24     fun for f (r1, r2) =
  25         if r1 < r2 then
  26             let
  27                 fun loop i =
  28                     if i > r2 then
  29                         ()
  30                     else
  31                         (f i;
  32                          loop (i+1))
  33             in
  34                 loop r1
  35             end
  36         else
  37             let
  38                 fun loop i =
  39                     if i < r2 then
  40                         ()
  41                     else
  42                         (f i;
  43                          loop (i-1))
  44             in
  45                 loop r1
  46             end
  47
  48     val params : string list StringMap.map ref = ref StringMap.empty
  49
  50     val paramStack : string list StringMap.map list ref = ref []
  51
  52     fun setParam (n, v) = params := StringMap.insert (!params, n, v)
  53     fun setSingleParam (n, v) = setParam (n, [v])
  54
  55     fun getParam v =
  56         (case StringMap.find (!params, v) of
  57              NONE => ""
  58            | SOME [] => ""
  59            | SOME (s::_) => s)
  60
  61     fun getMultiParam v =
  62         (case StringMap.find (!params, v) of
  63              NONE => []
  64            | SOME l => l)
  65
  66     fun pushParams nvs =
  67         (paramStack := (!params) :: (!paramStack);
  68          app setParam nvs)
  69
  70     fun popParams () =
  71         (case !paramStack of
  72              [] => raise Fail "Empty params stack in popParams"
  73            | h::t => (params := h;
  74                       paramStack := t))
  75
  76     fun withParams f nvs =
  77         (pushParams nvs;
  78          ((f ()) handle ex => (popParams (); raise ex))
  79          before popParams ())
  80
  81     val headers = ref (StringMap.empty : string list StringMap.map)
  82     fun setHeader (n, v) = headers := StringMap.insert (!headers, n, v)
  83     fun getHeader n = StringMap.find (!headers, n)
  84     fun addHeader (n, v) =
  85         headers := StringMap.insert (!headers, n, case getHeader n of
  86                                                       NONE => [v]
  87                                                     | SOME vs => vs @ [v])
  88     fun getSingleHeader n =
  89         (case StringMap.find (!headers, n) of
  90              SOME (v::_) => SOME v
  91            | _ => NONE)
  92
  93     val text = ref ([] : string list)
  94
  95     fun print x = text := x :: (!text)
  96     fun clear () = text := []
  97     fun noOutput () = !text = []
  98     fun output () =
  99         (TextIO.print "Status: 200\n";
 100          StringMap.appi (fn (n, vs) =>
 101                             app (fn v => (TextIO.print n;
 102                                           TextIO.print ": ";
 103                                           TextIO.print v;
 104                                           TextIO.print "\n"))
 105                                 vs) (!headers);
 106          TextIO.print "\n";
 107          TextIO.print (String.concat (List.rev (!text))))
 108
 109     val getCgi = OS.Process.getEnv
 110
 111     val explode = CharVector.foldr (op::) []
 112
 113     fun html s =
 114         let
 115             fun xch #"<" = "&lt;"
 116               | xch #">" = "&gt;"
 117               | xch #"&" = "&amp;"
 118               | xch #"\"" = "&quot;"
 119               | xch ch = str ch
 120         in
 121             String.concat (map xch (explode s))
 122         end
 123
 124     fun htmlNl s =
 125         let
 126             fun xch #"<" = "&lt;"
 127               | xch #">" = "&gt;"
 128               | xch #"&" = "&amp;"
 129               | xch #"\"" = "&quot;"
 130               | xch #"\n" = "<br />"
 131               | xch ch = str ch
 132         in
 133             String.concat  (map xch (explode s))
 134         end
 135
 136     fun pad (n, ch) s =
 137         if size s < n then
 138             pad (n, ch) (ch ^ s)
 139         else
 140             s
 141
 142     fun urlEncode s =
 143         let
 144             fun xch ch =
 145                 if Char.isAlphaNum ch orelse ch = #"." then
 146                     str ch
 147                 else if ch = #" " then
 148                     "+"
 149                 else
 150                     "%" ^ pad (2, "0") (Int.fmt StringCvt.HEX (ord ch))
 151         in
 152             String.concat (map xch (explode s))
 153         end
 154
 155     exception Format of string
 156
 157     fun stoiOpt s = Int.fromString s
 158     fun stoi s =
 159         (case Int.fromString s of
 160              NONE => raise Format s
 161            | SOME i => i)
 162
 163     fun storOpt s = Real.fromString s
 164     fun stor s =
 165         (case Real.fromString s of
 166              NONE => raise Format s
 167            | SOME r => r)
 168
 169     fun summary () =
 170         StringMap.foldli (fn (n, vs, s) => foldl (fn (v, s) => s ^ " VALUE: " ^ v) (s ^ " NAME: " ^ n) vs)
 171         "" (!params)
 172
 173     val exn = ref (NONE : exn option)
 174     fun setExn ex = exn := SOME ex
 175     fun getExn () = valOf (!exn)
 176
 177     type cookie = {name : string, value : string, expires : Date.date option,
 178                    domain : string option, path : string option, secure : bool}
 179
 180     fun setCookie {name, value, expires, domain, path, secure} =
 181         let
 182             val s = name ^ "=" ^ value
 183             val s =
 184                 case expires of
 185                     NONE => s
 186                   | SOME date => s ^ "; expires=" ^ Date.fmt "%a, %d-%b-%Y %H:%M:%S GMT" date
 187             val s =
 188                 case domain of
 189                     NONE => s
 190                   | SOME dom => s ^ "; domain=" ^ dom
 191             val s =
 192                 case path of
 193                     NONE => s
 194                   | SOME path => s ^ "; path=" ^ path
 195             val s =
 196                 if secure then
 197                     s ^ "; secure"
 198                 else
 199                     s
 200         in
 201             addHeader ("Set-Cookie", s)
 202         end
 203
 204     fun getCookie n =
 205         (case getCgi "HTTP_COOKIE" of
 206              NONE => NONE
 207            | SOME cookies =>
 208              let
 209                  fun search (n'::v::rest) =
 210                      if n = n' then
 211                          SOME v
 212                      else
 213                          search rest
 214                    | search _ = NONE
 215              in
 216                  search (String.tokens (fn ch => ch = #"=" orelse ch = #";" orelse ch = #" ") cookies)
 217              end)
 218
 219     fun remoteHost () =
 220         case getCgi "REMOTE_HOST" of
 221             NONE => getCgi "REMOTE_ADDR"
 222           | h => h
 223
 224     fun plusSeconds (t, s) = Time.+ (t, Time.fromSeconds (LargeInt.fromInt s))
 225     fun minusSeconds (t, s) = Time.- (t, Time.fromSeconds (LargeInt.fromInt s))
 226
 227     fun split (s, ch) =
 228         let
 229             val len = size s
 230
 231             fun find i =
 232                 if i >= len then
 233                     NONE
 234                 else if String.sub (s, i) = ch then
 235                     SOME (String.substring (s, 0, i), String.extract (s, i+1, NONE))
 236                 else
 237                     find (i+1)
 238         in
 239             find 0
 240         end
 241
 242     fun replaceUrlVar (url, n, v) =
 243         case split (url, #"?") of
 244             NONE => url
 245           | SOME (uri, qs)  =>
 246             let
 247                 fun doPair (nv, (L, yn)) =
 248                     (case split (nv, #"=") of
 249                          NONE => (nv::L, yn)
 250                        | SOME (n', v') =>
 251                          if n = n' then
 252                              ((n ^ "=" ^ v)::L, true)
 253                          else
 254                              (nv::L, yn))
 255                 val (pairs, yn) = foldr doPair ([], false) (String.tokens (fn ch => ch = #"&") qs)
 256                 val pairs =
 257                     if yn then
 258                         pairs
 259                     else
 260                         (n ^ "=" ^ v) :: pairs
 261             in
 262                 case pairs of
 263                     [] => url
 264                   | nv::rest =>
 265                     String.concat (uri :: "?" :: nv :: foldr (fn (nv, L) => "&"::nv::L) [] rest)
 266             end
 267 end