Mercurial > urweb

annotate src/demo.sml @ 853:19fdeef40ada

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out common request functionality, in preparation for supporting different protocols
author Adam Chlipala <adamc@hcoop.net>
date Tue, 23 Jun 2009 14:05:12 -0400
parents 9f2555f06901
children 305bc0a431de
rev   line source
adamc@380 1 (* Copyright (c) 2008, Adam Chlipala
adamc@380 2 * All rights reserved.
adamc@380 3 *
adamc@380 4 * Redistribution and use in source and binary forms, with or without
adamc@380 5 * modification, are permitted provided that the following conditions are met:
adamc@380 6 *
adamc@380 7 * - Redistributions of source code must retain the above copyright notice,
adamc@380 8 * this list of conditions and the following disclaimer.
adamc@380 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@380 10 * this list of conditions and the following disclaimer in the documentation
adamc@380 11 * and/or other materials provided with the distribution.
adamc@380 12 * - The names of contributors may not be used to endorse or promote products
adamc@380 13 * derived from this software without specific prior written permission.
adamc@380 14 *
adamc@380 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@380 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@380 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@380 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@380 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@380 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@380 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@380 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@380 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@380 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@380 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@380 26 *)
adamc@380 27
adamc@380 28 structure Demo :> DEMO = struct
adamc@380 29
adamc@501 30 fun make {prefix, dirname, guided} =
adamc@380 31 let
adamc@380 32 val prose = OS.Path.joinDirFile {dir = dirname,
adamc@380 33 file = "prose"}
adamc@380 34 val inf = TextIO.openIn prose
adamc@380 35
adamc@380 36 val outDir = OS.Path.concat (dirname, "out")
adamc@380 37
adamc@380 38 val () = if OS.FileSys.access (outDir, []) then
adamc@380 39 ()
adamc@380 40 else
adamc@380 41 OS.FileSys.mkDir outDir
adamc@380 42
adamc@380 43 val fname = OS.Path.joinDirFile {dir = outDir,
adamc@380 44 file = "index.html"}
adamc@380 45
adamc@380 46 val out = TextIO.openOut fname
adamc@773 47 val () = (TextIO.output (out, "<frameset cols=\"15%,85%\">\n");
adamc@380 48 TextIO.output (out, "<frame src=\"demos.html\">\n");
adamc@380 49 TextIO.output (out, "<frame src=\"intro.html\" name=\"staging\">\n");
adamc@380 50 TextIO.output (out, "</frameset>\n");
adamc@380 51 TextIO.closeOut out)
adamc@380 52
adamc@380 53 val fname = OS.Path.joinDirFile {dir = outDir,
adamc@380 54 file = "demos.html"}
adamc@380 55
adamc@380 56 val demosOut = TextIO.openOut fname
adamc@381 57 val () = (TextIO.output (demosOut, "<html><body>\n\n");
adamc@380 58 TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"intro.html\">Intro</a></li>\n\n"))
adamc@380 59
adamc@384 60 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 61 file = "demo.urs"}
adamc@384 62 val ursOut = TextIO.openOut fname
adamc@384 63 val () = (TextIO.output (ursOut, "val main : unit -> transaction page\n");
adamc@384 64 TextIO.closeOut ursOut)
adamc@384 65
adamc@384 66 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 67 file = "demo.ur"}
adamc@384 68 val urOut = TextIO.openOut fname
adamc@384 69 val () = TextIO.output (urOut, "fun main () = return <xml><body>\n")
adamc@384 70
adamc@380 71 fun mergeWith f (o1, o2) =
adamc@380 72 case (o1, o2) of
adamc@380 73 (NONE, _) => o2
adamc@380 74 | (_, NONE) => o1
adamc@380 75 | (SOME v1, SOME v2) => SOME (f (v1, v2))
adamc@380 76
adamc@380 77 fun combiner (combined : Compiler.job, urp : Compiler.job) = {
adamc@385 78 prefix = prefix,
adamc@380 79 database = mergeWith (fn (v1, v2) =>
adamc@380 80 if v1 = v2 then
adamc@380 81 v1
adamc@380 82 else
adamc@380 83 raise Fail "Different demos want to use different database strings")
adamc@380 84 (#database combined, #database urp),
adamc@380 85 sources = foldl (fn (file, files) =>
adamc@380 86 if List.exists (fn x => x = file) files then
adamc@380 87 files
adamc@380 88 else
adamc@380 89 files @ [file])
adamc@380 90 (#sources combined) (#sources urp),
adamc@380 91 exe = OS.Path.joinDirFile {dir = dirname,
adamc@380 92 file = "demo.exe"},
adamc@380 93 sql = SOME (OS.Path.joinDirFile {dir = dirname,
adamc@380 94 file = "demo.sql"}),
adamc@502 95 debug = false,
adamc@673 96 timeout = Int.max (#timeout combined, #timeout urp),
adamc@764 97 profile = false,
adamc@764 98 ffi = [],
adamc@764 99 link = [],
adamc@765 100 headers = [],
adamc@766 101 scripts = [],
adamc@765 102 clientToServer = [],
adamc@765 103 effectful = [],
adamc@765 104 clientOnly = [],
adamc@765 105 serverOnly = [],
adamc@768 106 jsFuncs = [],
adamc@774 107 rewrites = #rewrites combined @ #rewrites urp,
adamc@769 108 filterUrl = #filterUrl combined @ #filterUrl urp,
adamc@769 109 filterMime = #filterMime combined @ #filterMime urp
adamc@380 110 }
adamc@380 111
adamc@380 112 val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
adamc@380 113
adamc@380 114 fun capitalize "" = ""
adamc@380 115 | capitalize s = str (Char.toUpper (String.sub (s, 0)))
adamc@380 116 ^ String.extract (s, 1, NONE)
adamc@380 117
adamc@380 118 fun startUrp urp =
adamc@380 119 let
adamc@380 120 val base = OS.Path.base urp
adamc@380 121 val name = capitalize base
adamc@380 122
adamc@380 123 val () = (TextIO.output (demosOut, "<li> <a target=\"staging\" href=\"");
adamc@380 124 TextIO.output (demosOut, base);
adamc@380 125 TextIO.output (demosOut, ".html\">");
adamc@380 126 TextIO.output (demosOut, name);
adamc@380 127 TextIO.output (demosOut, "</a></li>\n"))
adamc@380 128
adamc@384 129 val () = (TextIO.output (urOut, " <li> <a link={");
adamc@384 130 TextIO.output (urOut, name);
adamc@384 131 TextIO.output (urOut, ".main ()}>");
adamc@384 132 TextIO.output (urOut, name);
adamc@384 133 TextIO.output (urOut, "</a></li>\n"))
adamc@384 134
adamc@380 135 val urp_file = OS.Path.joinDirFile {dir = dirname,
adamc@380 136 file = urp}
adamc@380 137
adamc@380 138 val out = OS.Path.joinBaseExt {base = base,
adamc@380 139 ext = SOME "html"}
adamc@380 140 val out = OS.Path.joinDirFile {dir = outDir,
adamc@380 141 file = out}
adamc@380 142 val out = TextIO.openOut out
adamc@380 143
adamc@501 144 val () = (TextIO.output (out, "<frameset rows=\"");
adamc@501 145 TextIO.output (out, if guided then
adamc@501 146 "*,100"
adamc@501 147 else
adamc@501 148 "50%,*");
adamc@501 149 TextIO.output (out, "\">\n");
adamc@380 150 TextIO.output (out, "<frame src=\"");
adamc@380 151 TextIO.output (out, prefix);
adamc@380 152 TextIO.output (out, "/");
adamc@380 153 TextIO.output (out, name);
adamc@380 154 TextIO.output (out, "/main\" name=\"showcase\">\n");
adamc@380 155 TextIO.output (out, "<frame src=\"");
adamc@380 156 TextIO.output (out, base);
adamc@380 157 TextIO.output (out, ".desc.html\">\n");
adamc@380 158 TextIO.output (out, "</frameset>\n");
adamc@380 159 TextIO.closeOut out)
adamc@380 160 val () = TextIO.closeOut out
adamc@380 161
adamc@380 162 val out = OS.Path.joinBaseExt {base = base,
adamc@380 163 ext = SOME "desc"}
adamc@380 164 val out = OS.Path.joinBaseExt {base = out,
adamc@380 165 ext = SOME "html"}
adamc@380 166 val out = TextIO.openOut (OS.Path.joinDirFile {dir = outDir,
adamc@380 167 file = out})
adamc@380 168 in
adamc@380 169 case parse (OS.Path.base urp_file) of
adamc@380 170 NONE => raise Fail ("Can't parse " ^ urp_file)
adamc@380 171 | SOME urpData =>
adamc@380 172 (TextIO.output (out, "<html><head>\n<title>");
adamc@380 173 TextIO.output (out, name);
adamc@380 174 TextIO.output (out, "</title>\n</head><body>\n\n<h1>");
adamc@380 175 TextIO.output (out, name);
adamc@380 176 TextIO.output (out, "</h1>\n\n<center>[ <a target=\"showcase\" href=\"");
adamc@382 177 TextIO.output (out, prefix);
adamc@382 178 TextIO.output (out, "/");
adamc@382 179 TextIO.output (out, name);
adamc@382 180 TextIO.output (out, "/main\">Application</a>");
adamc@382 181 TextIO.output (out, " | <a target=\"showcase\" href=\"");
adamc@380 182 TextIO.output (out, urp);
adamc@380 183 TextIO.output (out, ".html\"><tt>");
adamc@380 184 TextIO.output (out, urp);
adamc@380 185 TextIO.output (out, "</tt></a>");
adamc@380 186 app (fn file =>
adamc@380 187 let
adamc@380 188 fun ifEx s =
adamc@380 189 let
adamc@380 190 val src = OS.Path.joinBaseExt {base = file,
adamc@380 191 ext = SOME s}
adamc@380 192 val src' = OS.Path.file src
adamc@380 193 in
adamc@380 194 if OS.FileSys.access (src, []) then
adamc@380 195 (TextIO.output (out, " | <a target=\"showcase\" href=\"");
adamc@380 196 TextIO.output (out, src');
adamc@380 197 TextIO.output (out, ".html\"><tt>");
adamc@380 198 TextIO.output (out, src');
adamc@380 199 TextIO.output (out, "</tt></a>"))
adamc@380 200 else
adamc@380 201 ()
adamc@380 202 end
adamc@380 203 in
adamc@380 204 ifEx "urs";
adamc@380 205 ifEx "ur"
adamc@380 206 end) (#sources urpData);
adamc@380 207 TextIO.output (out, " ]</center>\n\n");
adamc@380 208
adamc@380 209 (urpData, out))
adamc@380 210 end
adamc@380 211
adamc@380 212 fun endUrp out =
adamc@380 213 (TextIO.output (out, "\n</body></html>\n");
adamc@380 214 TextIO.closeOut out)
adamc@380 215
adamc@380 216 fun readUrp (combined, out) =
adamc@380 217 let
adamc@380 218 fun finished () = endUrp out
adamc@380 219
adamc@380 220 fun readUrp' () =
adamc@380 221 case TextIO.inputLine inf of
adamc@384 222 NONE => (finished ();
adamc@384 223 combined)
adamc@380 224 | SOME line =>
adamc@380 225 if String.isSuffix ".urp\n" line then
adamc@380 226 let
adamc@380 227 val urp = String.substring (line, 0, size line - 1)
adamc@380 228 val (urpData, out) = startUrp urp
adamc@380 229 in
adamc@380 230 finished ();
adamc@380 231
adamc@380 232 readUrp (combiner (combined, urpData),
adamc@380 233 out)
adamc@380 234 end
adamc@380 235 else
adamc@380 236 (TextIO.output (out, line);
adamc@380 237 readUrp' ())
adamc@380 238 in
adamc@380 239 readUrp' ()
adamc@380 240 end
adamc@380 241
adamc@380 242 val indexFile = OS.Path.joinDirFile {dir = outDir,
adamc@380 243 file = "intro.html"}
adamc@380 244
adamc@380 245 val out = TextIO.openOut indexFile
adamc@380 246 val () = TextIO.output (out, "<html><head>\n<title>Ur/Web Demo</title>\n</head><body>\n\n")
adamc@380 247
adamc@380 248 fun readIndex () =
adamc@380 249 let
adamc@380 250 fun finished () = (TextIO.output (out, "\n</body></html>\n");
adamc@380 251 TextIO.closeOut out)
adamc@380 252 in
adamc@380 253 case TextIO.inputLine inf of
adamc@384 254 NONE => (finished ();
adamc@384 255 NONE)
adamc@380 256 | SOME line =>
adamc@380 257 if String.isSuffix ".urp\n" line then
adamc@380 258 let
adamc@380 259 val urp = String.substring (line, 0, size line - 1)
adamc@380 260 val (urpData, out) = startUrp urp
adamc@380 261 in
adamc@380 262 finished ();
adamc@380 263
adamc@384 264 SOME (readUrp (urpData,
adamc@384 265 out))
adamc@380 266 end
adamc@380 267 else
adamc@380 268 (TextIO.output (out, line);
adamc@380 269 readIndex ())
adamc@380 270 end
adamc@381 271
adamc@381 272 fun prettyPrint () =
adamc@381 273 let
adamc@381 274 val dir = Posix.FileSys.opendir dirname
adamc@381 275
adamc@381 276 fun loop () =
adamc@381 277 case Posix.FileSys.readdir dir of
adamc@381 278 NONE => Posix.FileSys.closedir dir
adamc@381 279 | SOME file =>
adamc@381 280 let
adamc@381 281 fun doit f =
adamc@381 282 f (OS.Path.joinDirFile {dir = dirname,
adamc@381 283 file = file},
adamc@382 284 OS.Path.mkAbsolute
adamc@382 285 {relativeTo = OS.FileSys.getDir (),
adamc@382 286 path = OS.Path.joinDirFile {dir = outDir,
adamc@382 287 file = OS.Path.joinBaseExt {base = file,
adamc@382 288 ext = SOME "html"}}})
adamc@382 289
adamc@382 290 fun highlight () =
adamc@382 291 doit (fn (src, html) =>
adamc@382 292 let
adamc@410 293 val dirty =
adamc@410 294 let
adamc@410 295 val srcSt = Posix.FileSys.stat src
adamc@410 296 val htmlSt = Posix.FileSys.stat html
adamc@410 297 in
adamc@410 298 Time.> (Posix.FileSys.ST.mtime srcSt,
adamc@410 299 Posix.FileSys.ST.mtime htmlSt)
adamc@410 300 end handle OS.SysErr _ => true
adamc@410 301
adamc@382 302 val cmd = "emacs --eval \"(progn "
adamc@382 303 ^ "(global-font-lock-mode t) "
adamc@382 304 ^ "(add-to-list 'load-path \\\""
adamc@382 305 ^ Config.sitelisp
adamc@382 306 ^ "/\\\") "
adamc@382 307 ^ "(load \\\"urweb-mode-startup\\\") "
adamc@382 308 ^ "(urweb-mode) "
adamc@382 309 ^ "(find-file \\\""
adamc@382 310 ^ src
adamc@382 311 ^ "\\\") "
adamc@382 312 ^ "(switch-to-buffer (htmlize-buffer)) "
adamc@382 313 ^ "(write-file \\\""
adamc@382 314 ^ html
adamc@382 315 ^ "\\\") "
adamc@382 316 ^ "(kill-emacs))\""
adamc@382 317 in
adamc@410 318 if dirty then
adamc@410 319 (print (">>> " ^ cmd ^ "\n");
adamc@410 320 ignore (OS.Process.system cmd))
adamc@410 321 else
adamc@410 322 ()
adamc@382 323 end)
adamc@381 324 in
adamc@384 325 if OS.Path.base file = "demo" then
adamc@384 326 ()
adamc@384 327 else case OS.Path.ext file of
adamc@384 328 SOME "urp" =>
adamc@384 329 doit (fn (src, html) =>
adamc@384 330 let
adamc@384 331 val inf = TextIO.openIn src
adamc@384 332 val out = TextIO.openOut html
adamc@381 333
adamc@384 334 fun loop () =
adamc@384 335 case TextIO.inputLine inf of
adamc@384 336 NONE => ()
adamc@384 337 | SOME line => (TextIO.output (out, line);
adamc@384 338 loop ())
adamc@384 339 in
adamc@384 340 TextIO.output (out, "<html><body>\n\n<pre>");
adamc@384 341 loop ();
adamc@384 342 TextIO.output (out, "</pre>\n\n</body></html>");
adamc@381 343
adamc@384 344 TextIO.closeIn inf;
adamc@384 345 TextIO.closeOut out
adamc@384 346 end)
adamc@384 347 | SOME "urs" => highlight ()
adamc@384 348 | SOME "ur" => highlight ()
adamc@384 349 | _ => ();
adamc@381 350 loop ()
adamc@381 351 end
adamc@381 352 in
adamc@381 353 loop ()
adamc@381 354 end
adamc@380 355 in
adamc@384 356 case readIndex () of
adamc@384 357 NONE => raise Fail "No demo applications!"
adamc@384 358 | SOME combined =>
adamc@384 359 let
adamc@384 360 val () = (TextIO.output (urOut, "</body></xml>\n");
adamc@384 361 TextIO.closeOut urOut)
adamc@384 362
adamc@384 363 val fname = OS.Path.joinDirFile {dir = dirname,
adamc@384 364 file = "demo.urp"}
adamc@384 365 val outf = TextIO.openOut fname
adamc@776 366
adamc@776 367 fun filters kind =
adamc@776 368 app (fn rule : Settings.rule =>
adamc@776 369 (TextIO.output (outf, case #action rule of
adamc@776 370 Settings.Allow => "allow"
adamc@776 371 | Settings.Deny => "deny");
adamc@776 372 TextIO.output (outf, " ");
adamc@776 373 TextIO.output (outf, kind);
adamc@776 374 TextIO.output (outf, " ");
adamc@776 375 TextIO.output (outf, #pattern rule);
adamc@776 376 case #kind rule of
adamc@776 377 Settings.Exact => ()
adamc@776 378 | Settings.Prefix => TextIO.output (outf, "*");
adamc@776 379 TextIO.output (outf, "\n")))
adamc@384 380 in
adamc@384 381 Option.app (fn db => (TextIO.output (outf, "database ");
adamc@384 382 TextIO.output (outf, db);
adamc@384 383 TextIO.output (outf, "\n")))
adamc@384 384 (#database combined);
adamc@384 385 TextIO.output (outf, "sql demo.sql\n");
adamc@385 386 TextIO.output (outf, "prefix ");
adamc@385 387 TextIO.output (outf, prefix);
adamc@385 388 TextIO.output (outf, "\n");
adamc@774 389 app (fn rule =>
adamc@774 390 (TextIO.output (outf, "rewrite ");
adamc@774 391 TextIO.output (outf, case #pkind rule of
adamc@774 392 Settings.Any => "any"
adamc@774 393 | Settings.Url => "url"
adamc@774 394 | Settings.Table => "table"
adamc@774 395 | Settings.Sequence => "sequence"
adamc@774 396 | Settings.View => "view"
adamc@774 397 | Settings.Relation => "relation"
adamc@774 398 | Settings.Cookie => "cookie"
adamc@774 399 | Settings.Style => "style");
adamc@774 400 TextIO.output (outf, " ");
adamc@774 401 TextIO.output (outf, #from rule);
adamc@774 402 case #kind rule of
adamc@774 403 Settings.Exact => ()
adamc@774 404 | Settings.Prefix => TextIO.output (outf, "*");
adamc@774 405 TextIO.output (outf, " ");
adamc@774 406 TextIO.output (outf, #to rule);
adamc@774 407 TextIO.output (outf, "\n"))) (#rewrites combined);
adamc@776 408 filters "url" (#filterUrl combined);
adamc@776 409 filters "mime" (#filterMime combined);
adamc@384 410 TextIO.output (outf, "\n");
adamc@384 411
adamc@384 412 app (fn s =>
adamc@384 413 let
adamc@384 414 val s = OS.Path.mkAbsolute {relativeTo = OS.FileSys.getDir (),
adamc@384 415 path = s}
adamc@384 416 in
adamc@384 417 TextIO.output (outf, s);
adamc@384 418 TextIO.output (outf, "\n")
adamc@384 419 end)
adamc@384 420 (#sources combined);
adamc@384 421 TextIO.output (outf, "\n");
adamc@384 422 TextIO.output (outf, "demo\n");
adamc@384 423
adamc@384 424 TextIO.closeOut outf;
adamc@384 425
adamc@384 426 Compiler.compile (OS.Path.base fname)
adamc@384 427 end;
adamc@380 428
adamc@381 429 TextIO.output (demosOut, "\n</body></html>\n");
adamc@381 430 TextIO.closeOut demosOut;
adamc@381 431
adamc@381 432 prettyPrint ()
adamc@380 433 end
adamc@380 434
adamc@380 435 end