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 StringMap.map)
  82     fun setHeader (n, v) = headers := StringMap.insert (!headers, n, v)
  83     fun getHeader n = StringMap.find (!headers, n)
  84
  85     val text = ref ([] : string list)
  86
  87     fun print x = text := x :: (!text)
  88     fun clear () = text := []
  89     fun noOutput () = !text = []
  90     fun output () =
  91         (TextIO.print "Status: 200\n";
  92          StringMap.appi (fn (n, v) => (TextIO.print n;
  93                                        TextIO.print ": ";
  94                                        TextIO.print v;
  95                                        TextIO.print "\n")) (!headers);
  96          TextIO.print "\n";
  97          TextIO.print (String.concat (List.rev (!text))))
  98
  99     val getCgi = OS.Process.getEnv
 100
 101     val explode = CharVector.foldr (op::) []
 102
 103     fun html s =
 104         let
 105             fun xch #"<" = "&lt;"
 106               | xch #">" = "&gt;"
 107               | xch #"&" = "&amp;"
 108               | xch #"\"" = "&quot;"
 109               | xch ch = str ch
 110         in
 111             String.concat (map xch (explode s))
 112         end
 113
 114     fun htmlNl s =
 115         let
 116             fun xch #"<" = "&lt;"
 117               | xch #">" = "&gt;"
 118               | xch #"&" = "&amp;"
 119               | xch #"\"" = "&quot;"
 120               | xch #"\n" = "<br />"
 121               | xch ch = str ch
 122         in
 123             String.concat  (map xch (explode s))
 124         end
 125
 126     fun pad (n, ch) s =
 127         if size s < n then
 128             pad (n, ch) (ch ^ s)
 129         else
 130             s
 131
 132     fun urlEncode s =
 133         let
 134             fun xch ch =
 135                 if Char.isAlphaNum ch orelse ch = #"." then
 136                     str ch
 137                 else if ch = #" " then
 138                     "+"
 139                 else
 140                     "%" ^ pad (2, "0") (Int.fmt StringCvt.HEX (ord ch))
 141         in
 142             String.concat (map xch (explode s))
 143         end
 144
 145     exception Format of string
 146
 147     fun stoiOpt s = Int.fromString s
 148     fun stoi s =
 149         (case Int.fromString s of
 150              NONE => raise Format s
 151            | SOME i => i)
 152
 153     fun storOpt s = Real.fromString s
 154     fun stor s =
 155         (case Real.fromString s of
 156              NONE => raise Format s
 157            | SOME r => r)
 158
 159     fun summary () =
 160         StringMap.foldli (fn (n, vs, s) => foldl (fn (v, s) => s ^ " VALUE: " ^ v) (s ^ " NAME: " ^ n) vs)
 161         "" (!params)
 162
 163     val exn = ref (NONE : exn option)
 164     fun setExn ex = exn := SOME ex
 165     fun getExn () = valOf (!exn)
 166
 167     type cookie = {name : string, value : string, expires : Date.date option,
 168                    domain : string option, path : string option, secure : bool}
 169
 170     fun setCookie {name, value, expires, domain, path, secure} =
 171         let
 172             val s = name ^ "=" ^ value
 173             val s =
 174                 case expires of
 175                     NONE => s
 176                   | SOME date => s ^ "; expires=" ^ Date.fmt "%a, %d-%b-%Y %H:%M:%S GMT" date
 177             val s =
 178                 case domain of
 179                     NONE => s
 180                   | SOME dom => s ^ "; domain=" ^ dom
 181             val s =
 182                 case path of
 183                     NONE => s
 184                   | SOME path => s ^ "; path=" ^ path
 185             val s =
 186                 if secure then
 187                     s ^ "; secure"
 188                 else
 189                     s
 190         in
 191             setHeader ("Set-Cookie", s)
 192         end
 193
 194     fun getCookie n =
 195         (case getCgi "HTTP_COOKIE" of
 196              NONE => NONE
 197            | SOME cookies =>
 198              let
 199                  fun search (n'::v::rest) =
 200                      if n = n' then
 201                          SOME v
 202                      else
 203                          search rest
 204                    | search _ = NONE
 205              in
 206                  search (String.tokens (fn ch => ch = #"=" orelse ch = #";" orelse ch = #" ") cookies)
 207              end)
 208
 209     fun remoteHost () =
 210         case getCgi "REMOTE_HOST" of
 211             NONE => getCgi "REMOTE_ADDR"
 212           | h => h
 213
 214     fun minusSeconds (t, s) = Time.- (t, Time.fromSeconds (LargeInt.fromInt s))
 215
 216     fun split (s, ch) =
 217         let
 218             val len = size s
 219
 220             fun find i =
 221                 if i >= len then
 222                     NONE
 223                 else if String.sub (s, i) = ch then
 224                     SOME (String.substring (s, 0, i), String.extract (s, i+1, NONE))
 225                 else
 226                     find (i+1)
 227         in
 228             find 0
 229         end
 230
 231     fun replaceUrlVar (url, n, v) =
 232         case split (url, #"?") of
 233             NONE => url
 234           | SOME (uri, qs)  =>
 235             let
 236                 fun doPair (nv, (L, yn)) =
 237                     (case split (nv, #"=") of
 238                          NONE => (nv::L, yn)
 239                        | SOME (n', v') =>
 240                          if n = n' then
 241                              ((n ^ "=" ^ v)::L, true)
 242                          else
 243                              (nv::L, yn))
 244                 val (pairs, yn) = foldr doPair ([], false) (String.tokens (fn ch => ch = #"&") qs)
 245                 val pairs =
 246                     if yn then
 247                         pairs
 248                     else
 249                         (n ^ "=" ^ v) :: pairs
 250             in
 251                 case pairs of
 252                     [] => url
 253                   | nv::rest =>
 254                     String.concat (uri :: "?" :: nv :: foldr (fn (nv, L) => "&"::nv::L) [] rest)
 255             end
 256 end