Mercurial > urweb

comparison src/compiler.sml @ 1296:0d3d9e653829

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Shortcut invocations for single .ur files
author Adam Chlipala <adam@chlipala.net>
date Tue, 07 Sep 2010 09:21:51 -0400
parents b4480a56cab7
children d2ad997ca157
comparison
equal deleted inserted replaced
1295:929981850d9d 1296:0d3d9e653829
286 286
287 val pathmap = ref (M.insert (M.empty, "", Config.libUr)) 287 val pathmap = ref (M.insert (M.empty, "", Config.libUr))
288 288
289 fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v) 289 fun addPath (k, v) = pathmap := M.insert (!pathmap, k, v)
290 290
291 fun capitalize "" = ""
292 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
293
294 fun institutionalizeJob (job : job) =
295 (Settings.setUrlPrefix (#prefix job);
296 Settings.setTimeout (#timeout job);
297 Settings.setHeaders (#headers job);
298 Settings.setScripts (#scripts job);
299 Settings.setClientToServer (#clientToServer job);
300 Settings.setEffectful (#effectful job);
301 Settings.setBenignEffectful (#benignEffectful job);
302 Settings.setClientOnly (#clientOnly job);
303 Settings.setServerOnly (#serverOnly job);
304 Settings.setJsFuncs (#jsFuncs job);
305 Settings.setRewriteRules (#rewrites job);
306 Settings.setUrlRules (#filterUrl job);
307 Settings.setMimeRules (#filterMime job);
308 Option.app Settings.setProtocol (#protocol job);
309 Option.app Settings.setDbms (#dbms job);
310 Settings.setSafeGets (#safeGets job);
311 Settings.setOnError (#onError job))
312
291 fun parseUrp' accLibs fname = 313 fun parseUrp' accLibs fname =
292 let 314 if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", []))
293 val pathmap = ref (!pathmap) 315 andalso Posix.FileSys.access (fname ^ ".ur", []) then
294 val bigLibs = ref [] 316 let
295 317 val job = {prefix = "/",
296 fun pu filename = 318 database = NONE,
297 let 319 sources = [fname],
298 val dir = OS.Path.dir filename 320 exe = fname ^ ".exe",
299 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) 321 sql = NONE,
300 322 debug = false,
301 val inf = opener () 323 profile = false,
302 324 timeout = 60,
303 fun hasSpaceLine () = 325 ffi = [],
304 case TextIO.inputLine inf of 326 link = [],
305 NONE => false 327 headers = [],
306 | SOME s => s = "debug\n" orelse s = "profile\n" 328 scripts = [],
307 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine () 329 clientToServer = [],
308 330 effectful = [],
309 val hasBlankLine = hasSpaceLine () 331 benignEffectful = [],
310 332 clientOnly = [],
311 val inf = (TextIO.closeIn inf; opener ()) 333 serverOnly = [],
312 334 jsFuncs = [],
313 fun pathify fname = 335 rewrites = [{pkind = Settings.Any,
314 if size fname > 0 andalso String.sub (fname, 0) = #"$" then 336 kind = Settings.Prefix,
337 from = capitalize (OS.Path.file fname) ^ "/", to = ""}],
338 filterUrl = [],
339 filterMime = [],
340 protocol = NONE,
341 dbms = NONE,
342 sigFile = NONE,
343 safeGets = [],
344 onError = NONE}
345 in
346 institutionalizeJob job;
347 {Job = job, Libs = []}
348 end
349 else
350 let
351 val pathmap = ref (!pathmap)
352 val bigLibs = ref []
353
354 fun pu filename =
355 let
356 val dir = OS.Path.dir filename
357 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
358
359 val inf = opener ()
360
361 fun hasSpaceLine () =
362 case TextIO.inputLine inf of
363 NONE => false
364 | SOME s => s = "debug\n" orelse s = "profile\n"
365 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
366
367 val hasBlankLine = hasSpaceLine ()
368
369 val inf = (TextIO.closeIn inf; opener ())
370
371 fun pathify fname =
372 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
373 let
374 val fname' = Substring.extract (fname, 1, NONE)
375 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
376 in
377 if Substring.isEmpty after then
378 fname
379 else
380 case M.find (!pathmap, Substring.string befor) of
381 NONE => fname
382 | SOME rep => rep ^ Substring.string after
383 end
384 else
385 fname
386
387 fun relify fname =
315 let 388 let
316 val fname' = Substring.extract (fname, 1, NONE) 389 val fname = pathify fname
317 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
318 in 390 in
319 if Substring.isEmpty after then 391 OS.Path.concat (dir, fname)
320 fname 392 handle OS.Path.Path => fname
393 end
394
395 fun libify path =
396 (if Posix.FileSys.access (path ^ ".urp", []) then
397 path
398 else
399 path ^ "/lib")
400 handle SysErr => path
401
402 fun libify' path =
403 (if Posix.FileSys.access (relify path ^ ".urp", []) then
404 path
405 else
406 path ^ "/lib")
407 handle SysErr => path
408
409 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
410
411 fun relifyA fname =
412 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
413
414 fun readSources acc =
415 case TextIO.inputLine inf of
416 NONE => rev acc
417 | SOME line =>
418 let
419 val acc = if CharVector.all Char.isSpace line then
420 acc
421 else
422 let
423 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
424 (String.explode line))
425 val fname = relifyA fname
426 in
427 fname :: acc
428 end
429 in
430 readSources acc
431 end
432
433 val prefix = ref NONE
434 val database = ref (Settings.getDbstring ())
435 val exe = ref (Settings.getExe ())
436 val sql = ref (Settings.getSql ())
437 val debug = ref (Settings.getDebug ())
438 val profile = ref false
439 val timeout = ref NONE
440 val ffi = ref []
441 val link = ref []
442 val headers = ref []
443 val scripts = ref []
444 val clientToServer = ref []
445 val effectful = ref []
446 val benignEffectful = ref []
447 val clientOnly = ref []
448 val serverOnly = ref []
449 val jsFuncs = ref []
450 val rewrites = ref []
451 val url = ref []
452 val mime = ref []
453 val libs = ref []
454 val protocol = ref NONE
455 val dbms = ref NONE
456 val sigFile = ref (Settings.getSigFile ())
457 val safeGets = ref []
458 val onError = ref NONE
459
460 fun finish sources =
461 let
462 val job = {
463 prefix = Option.getOpt (!prefix, "/"),
464 database = !database,
465 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
466 ext = SOME "exe"}),
467 sql = !sql,
468 debug = !debug,
469 profile = !profile,
470 timeout = Option.getOpt (!timeout, 60),
471 ffi = rev (!ffi),
472 link = rev (!link),
473 headers = rev (!headers),
474 scripts = rev (!scripts),
475 clientToServer = rev (!clientToServer),
476 effectful = rev (!effectful),
477 benignEffectful = rev (!benignEffectful),
478 clientOnly = rev (!clientOnly),
479 serverOnly = rev (!serverOnly),
480 jsFuncs = rev (!jsFuncs),
481 rewrites = rev (!rewrites),
482 filterUrl = rev (!url),
483 filterMime = rev (!mime),
484 sources = sources,
485 protocol = !protocol,
486 dbms = !dbms,
487 sigFile = !sigFile,
488 safeGets = rev (!safeGets),
489 onError = !onError
490 }
491
492 fun mergeO f (old, new) =
493 case (old, new) of
494 (NONE, _) => new
495 | (_, NONE) => old
496 | (SOME v1, SOME v2) => SOME (f (v1, v2))
497
498 fun same desc = mergeO (fn (x : string, y) =>
499 (if x = y then
500 ()
501 else
502 ErrorMsg.error ("Multiple "
503 ^ desc ^ " values that don't agree");
504 x))
505
506 fun merge (old : job, new : job) = {
507 prefix = #prefix old,
508 database = mergeO (fn (old, _) => old) (#database old, #database new),
509 exe = #exe old,
510 sql = #sql old,
511 debug = #debug old orelse #debug new,
512 profile = #profile old orelse #profile new,
513 timeout = #timeout old,
514 ffi = #ffi old @ #ffi new,
515 link = #link old @ #link new,
516 headers = #headers old @ #headers new,
517 scripts = #scripts old @ #scripts new,
518 clientToServer = #clientToServer old @ #clientToServer new,
519 effectful = #effectful old @ #effectful new,
520 benignEffectful = #benignEffectful old @ #benignEffectful new,
521 clientOnly = #clientOnly old @ #clientOnly new,
522 serverOnly = #serverOnly old @ #serverOnly new,
523 jsFuncs = #jsFuncs old @ #jsFuncs new,
524 rewrites = #rewrites old @ #rewrites new,
525 filterUrl = #filterUrl old @ #filterUrl new,
526 filterMime = #filterMime old @ #filterMime new,
527 sources = #sources new
528 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
529 (#sources old),
530 protocol = mergeO #2 (#protocol old, #protocol new),
531 dbms = mergeO #2 (#dbms old, #dbms new),
532 sigFile = mergeO #2 (#sigFile old, #sigFile new),
533 safeGets = #safeGets old @ #safeGets new,
534 onError = mergeO #2 (#onError old, #onError new)
535 }
536 in
537 if accLibs then
538 foldr (fn (job', job) => merge (job, job')) job (!libs)
321 else 539 else
322 case M.find (!pathmap, Substring.string befor) of 540 job
323 NONE => fname
324 | SOME rep => rep ^ Substring.string after
325 end 541 end
326 else 542
327 fname 543 fun parsePkind s =
328 544 case s of
329 fun relify fname = 545 "all" => Settings.Any
330 let 546 | "url" => Settings.Url
331 val fname = pathify fname 547 | "table" => Settings.Table
332 in 548 | "sequence" => Settings.Sequence
333 OS.Path.concat (dir, fname) 549 | "view" => Settings.View
334 handle OS.Path.Path => fname 550 | "relation" => Settings.Relation
335 end 551 | "cookie" => Settings.Cookie
336 552 | "style" => Settings.Style
337 fun libify path = 553 | _ => (ErrorMsg.error "Bad path kind spec";
338 (if Posix.FileSys.access (path ^ ".urp", []) then 554 Settings.Any)
339 path 555
340 else 556 fun parseFrom s =
341 path ^ "/lib") 557 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
342 handle SysErr => path 558 (Settings.Prefix, String.substring (s, 0, size s - 1))
343
344 fun libify' path =
345 (if Posix.FileSys.access (relify path ^ ".urp", []) then
346 path
347 else
348 path ^ "/lib")
349 handle SysErr => path
350
351 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
352
353 fun relifyA fname =
354 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
355
356 fun readSources acc =
357 case TextIO.inputLine inf of
358 NONE => rev acc
359 | SOME line =>
360 let
361 val acc = if CharVector.all Char.isSpace line then
362 acc
363 else
364 let
365 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
366 (String.explode line))
367 val fname = relifyA fname
368 in
369 fname :: acc
370 end
371 in
372 readSources acc
373 end
374
375 val prefix = ref NONE
376 val database = ref (Settings.getDbstring ())
377 val exe = ref (Settings.getExe ())
378 val sql = ref (Settings.getSql ())
379 val debug = ref (Settings.getDebug ())
380 val profile = ref false
381 val timeout = ref NONE
382 val ffi = ref []
383 val link = ref []
384 val headers = ref []
385 val scripts = ref []
386 val clientToServer = ref []
387 val effectful = ref []
388 val benignEffectful = ref []
389 val clientOnly = ref []
390 val serverOnly = ref []
391 val jsFuncs = ref []
392 val rewrites = ref []
393 val url = ref []
394 val mime = ref []
395 val libs = ref []
396 val protocol = ref NONE
397 val dbms = ref NONE
398 val sigFile = ref (Settings.getSigFile ())
399 val safeGets = ref []
400 val onError = ref NONE
401
402 fun finish sources =
403 let
404 val job = {
405 prefix = Option.getOpt (!prefix, "/"),
406 database = !database,
407 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
408 ext = SOME "exe"}),
409 sql = !sql,
410 debug = !debug,
411 profile = !profile,
412 timeout = Option.getOpt (!timeout, 60),
413 ffi = rev (!ffi),
414 link = rev (!link),
415 headers = rev (!headers),
416 scripts = rev (!scripts),
417 clientToServer = rev (!clientToServer),
418 effectful = rev (!effectful),
419 benignEffectful = rev (!benignEffectful),
420 clientOnly = rev (!clientOnly),
421 serverOnly = rev (!serverOnly),
422 jsFuncs = rev (!jsFuncs),
423 rewrites = rev (!rewrites),
424 filterUrl = rev (!url),
425 filterMime = rev (!mime),
426 sources = sources,
427 protocol = !protocol,
428 dbms = !dbms,
429 sigFile = !sigFile,
430 safeGets = rev (!safeGets),
431 onError = !onError
432 }
433
434 fun mergeO f (old, new) =
435 case (old, new) of
436 (NONE, _) => new
437 | (_, NONE) => old
438 | (SOME v1, SOME v2) => SOME (f (v1, v2))
439
440 fun same desc = mergeO (fn (x : string, y) =>
441 (if x = y then
442 ()
443 else
444 ErrorMsg.error ("Multiple "
445 ^ desc ^ " values that don't agree");
446 x))
447
448 fun merge (old : job, new : job) = {
449 prefix = #prefix old,
450 database = mergeO (fn (old, _) => old) (#database old, #database new),
451 exe = #exe old,
452 sql = #sql old,
453 debug = #debug old orelse #debug new,
454 profile = #profile old orelse #profile new,
455 timeout = #timeout old,
456 ffi = #ffi old @ #ffi new,
457 link = #link old @ #link new,
458 headers = #headers old @ #headers new,
459 scripts = #scripts old @ #scripts new,
460 clientToServer = #clientToServer old @ #clientToServer new,
461 effectful = #effectful old @ #effectful new,
462 benignEffectful = #benignEffectful old @ #benignEffectful new,
463 clientOnly = #clientOnly old @ #clientOnly new,
464 serverOnly = #serverOnly old @ #serverOnly new,
465 jsFuncs = #jsFuncs old @ #jsFuncs new,
466 rewrites = #rewrites old @ #rewrites new,
467 filterUrl = #filterUrl old @ #filterUrl new,
468 filterMime = #filterMime old @ #filterMime new,
469 sources = #sources new
470 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
471 (#sources old),
472 protocol = mergeO #2 (#protocol old, #protocol new),
473 dbms = mergeO #2 (#dbms old, #dbms new),
474 sigFile = mergeO #2 (#sigFile old, #sigFile new),
475 safeGets = #safeGets old @ #safeGets new,
476 onError = mergeO #2 (#onError old, #onError new)
477 }
478 in
479 if accLibs then
480 foldr (fn (job', job) => merge (job, job')) job (!libs)
481 else 559 else
482 job 560 (Settings.Exact, s)
483 end 561
484 562 fun parseFkind s =
485 fun parsePkind s = 563 case s of
486 case s of 564 "url" => url
487 "all" => Settings.Any 565 | "mime" => mime
488 | "url" => Settings.Url 566 | _ => (ErrorMsg.error "Bad filter kind";
489 | "table" => Settings.Table 567 url)
490 | "sequence" => Settings.Sequence 568
491 | "view" => Settings.View 569 fun parsePattern s =
492 | "relation" => Settings.Relation 570 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
493 | "cookie" => Settings.Cookie 571 (Settings.Prefix, String.substring (s, 0, size s - 1))
494 | "style" => Settings.Style 572 else
495 | _ => (ErrorMsg.error "Bad path kind spec"; 573 (Settings.Exact, s)
496 Settings.Any) 574
497 575 fun read () =
498 fun parseFrom s = 576 case TextIO.inputLine inf of
499 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then 577 NONE => finish []
500 (Settings.Prefix, String.substring (s, 0, size s - 1)) 578 | SOME "\n" => finish (readSources [])
501 else 579 | SOME line =>
502 (Settings.Exact, s) 580 let
503 581 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
504 fun parseFkind s = 582 val cmd = Substring.string (trim cmd)
505 case s of 583 val arg = Substring.string (trim arg)
506 "url" => url 584
507 | "mime" => mime 585 fun ffiS () =
508 | _ => (ErrorMsg.error "Bad filter kind"; 586 case String.fields (fn ch => ch = #".") arg of
509 url) 587 [m, x] => (m, x)
510 588 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
511 fun parsePattern s = 589 ("", ""))
512 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then 590
513 (Settings.Prefix, String.substring (s, 0, size s - 1)) 591 fun ffiM () =
514 else 592 case String.fields (fn ch => ch = #"=") arg of
515 (Settings.Exact, s) 593 [f, s] =>
516 594 (case String.fields (fn ch => ch = #".") f of
517 fun read () = 595 [m, x] => ((m, x), s)
518 case TextIO.inputLine inf of 596 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
519 NONE => finish [] 597 (("", ""), "")))
520 | SOME "\n" => finish (readSources []) 598 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
521 | SOME line => 599 (("", ""), ""))
522 let 600 in
523 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) 601 case cmd of
524 val cmd = Substring.string (trim cmd) 602 "prefix" =>
525 val arg = Substring.string (trim arg) 603 (case !prefix of
526 604 NONE => ()
527 fun ffiS () = 605 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
528 case String.fields (fn ch => ch = #".") arg of 606 prefix := SOME arg)
529 [m, x] => (m, x) 607 | "database" =>
530 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); 608 (case !database of
531 ("", "")) 609 NONE => database := SOME arg
532 610 | SOME _ => ())
533 fun ffiM () = 611 | "dbms" =>
534 case String.fields (fn ch => ch = #"=") arg of 612 (case !dbms of
535 [f, s] => 613 NONE => dbms := SOME arg
536 (case String.fields (fn ch => ch = #".") f of 614 | SOME _ => ())
537 [m, x] => ((m, x), s) 615 | "sigfile" =>
538 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); 616 (case !sigFile of
539 (("", ""), ""))) 617 NONE => sigFile := SOME arg
540 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); 618 | SOME _ => ())
541 (("", ""), "")) 619 | "exe" =>
542 in 620 (case !exe of
543 case cmd of 621 NONE => exe := SOME (relify arg)
544 "prefix" => 622 | SOME _ => ())
545 (case !prefix of 623 | "sql" =>
546 NONE => () 624 (case !sql of
547 | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; 625 NONE => sql := SOME (relify arg)
548 prefix := SOME arg) 626 | SOME _ => ())
549 | "database" => 627 | "debug" => debug := true
550 (case !database of 628 | "profile" => profile := true
551 NONE => database := SOME arg 629 | "timeout" =>
552 | SOME _ => ()) 630 (case !timeout of
553 | "dbms" => 631 NONE => ()
554 (case !dbms of 632 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
555 NONE => dbms := SOME arg 633 timeout := SOME (valOf (Int.fromString arg)))
556 | SOME _ => ()) 634 | "ffi" => ffi := relify arg :: !ffi
557 | "sigfile" => 635 | "link" => let
558 (case !sigFile of 636 val arg = if size arg >= 1
559 NONE => sigFile := SOME arg 637 andalso String.sub (arg, 0) = #"-" then
560 | SOME _ => ()) 638 arg
561 | "exe" => 639 else
562 (case !exe of 640 relifyA arg
563 NONE => exe := SOME (relify arg) 641 in
564 | SOME _ => ()) 642 link := arg :: !link
565 | "sql" => 643 end
566 (case !sql of 644 | "include" => headers := relifyA arg :: !headers
567 NONE => sql := SOME (relify arg) 645 | "script" => scripts := arg :: !scripts
568 | SOME _ => ()) 646 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
569 | "debug" => debug := true 647 | "safeGet" => safeGets := arg :: !safeGets
570 | "profile" => profile := true 648 | "effectful" => effectful := ffiS () :: !effectful
571 | "timeout" => 649 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
572 (case !timeout of 650 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
573 NONE => () 651 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
574 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive"; 652 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
575 timeout := SOME (valOf (Int.fromString arg))) 653 | "rewrite" =>
576 | "ffi" => ffi := relify arg :: !ffi 654 let
577 | "link" => let 655 fun doit (pkind, from, to) =
578 val arg = if size arg >= 1 656 let
579 andalso String.sub (arg, 0) = #"-" then 657 val pkind = parsePkind pkind
580 arg 658 val (kind, from) = parseFrom from
581 else 659 in
582 relifyA arg 660 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites
583 in 661 end
584 link := arg :: !link 662 in
585 end 663 case String.tokens Char.isSpace arg of
586 | "include" => headers := relifyA arg :: !headers 664 [pkind, from, to] => doit (pkind, from, to)
587 | "script" => scripts := arg :: !scripts 665 | [pkind, from] => doit (pkind, from, "")
588 | "clientToServer" => clientToServer := ffiS () :: !clientToServer 666 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
589 | "safeGet" => safeGets := arg :: !safeGets 667 end
590 | "effectful" => effectful := ffiS () :: !effectful 668 | "allow" =>
591 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful 669 (case String.tokens Char.isSpace arg of
592 | "clientOnly" => clientOnly := ffiS () :: !clientOnly 670 [fkind, pattern] =>
593 | "serverOnly" => serverOnly := ffiS () :: !serverOnly 671 let
594 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs 672 val fkind = parseFkind fkind
595 | "rewrite" => 673 val (kind, pattern) = parsePattern pattern
596 let 674 in
597 fun doit (pkind, from, to) = 675 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
598 let 676 end
599 val pkind = parsePkind pkind 677 | _ => ErrorMsg.error "Bad 'allow' syntax")
600 val (kind, from) = parseFrom from 678 | "deny" =>
601 in 679 (case String.tokens Char.isSpace arg of
602 rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites 680 [fkind, pattern] =>
603 end 681 let
604 in 682 val fkind = parseFkind fkind
605 case String.tokens Char.isSpace arg of 683 val (kind, pattern) = parsePattern pattern
606 [pkind, from, to] => doit (pkind, from, to) 684 in
607 | [pkind, from] => doit (pkind, from, "") 685 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
608 | _ => ErrorMsg.error "Bad 'rewrite' syntax" 686 end
609 end 687 | _ => ErrorMsg.error "Bad 'deny' syntax")
610 | "allow" => 688 | "library" => if accLibs then
611 (case String.tokens Char.isSpace arg of 689 libs := pu (libify (relify arg)) :: !libs
612 [fkind, pattern] => 690 else
613 let 691 bigLibs := libify' arg :: !bigLibs
614 val fkind = parseFkind fkind 692 | "path" =>
615 val (kind, pattern) = parsePattern pattern 693 (case String.fields (fn ch => ch = #"=") arg of
616 in 694 [n, v] => pathmap := M.insert (!pathmap, n, v)
617 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind 695 | _ => ErrorMsg.error "path argument not of the form name=value'")
618 end 696 | "onError" =>
619 | _ => ErrorMsg.error "Bad 'allow' syntax") 697 (case String.fields (fn ch => ch = #".") arg of
620 | "deny" => 698 m1 :: (fs as _ :: _) =>
621 (case String.tokens Char.isSpace arg of 699 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
622 [fkind, pattern] => 700 | _ => ErrorMsg.error "invalid 'onError' argument")
623 let 701
624 val fkind = parseFkind fkind 702 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
625 val (kind, pattern) = parsePattern pattern 703 read ()
626 in 704 end
627 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind 705
628 end 706 val job = if hasBlankLine then
629 | _ => ErrorMsg.error "Bad 'deny' syntax") 707 read ()
630 | "library" => if accLibs then 708 else
631 libs := pu (libify (relify arg)) :: !libs 709 finish (readSources [])
632 else 710 in
633 bigLibs := libify' arg :: !bigLibs 711 TextIO.closeIn inf;
634 | "path" => 712 institutionalizeJob job;
635 (case String.fields (fn ch => ch = #"=") arg of 713 job
636 [n, v] => pathmap := M.insert (!pathmap, n, v) 714 end
637 | _ => ErrorMsg.error "path argument not of the form name=value'") 715 in
638 | "onError" => 716 {Job = pu fname, Libs = !bigLibs}
639 (case String.fields (fn ch => ch = #".") arg of 717 end
640 m1 :: (fs as _ :: _) =>
641 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
642 | _ => ErrorMsg.error "invalid 'onError' argument")
643
644 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
645 read ()
646 end
647
648 val job = if hasBlankLine then
649 read ()
650 else
651 finish (readSources [])
652 in
653 TextIO.closeIn inf;
654 Settings.setUrlPrefix (#prefix job);
655 Settings.setTimeout (#timeout job);
656 Settings.setHeaders (#headers job);
657 Settings.setScripts (#scripts job);
658 Settings.setClientToServer (#clientToServer job);
659 Settings.setEffectful (#effectful job);
660 Settings.setBenignEffectful (#benignEffectful job);
661 Settings.setClientOnly (#clientOnly job);
662 Settings.setServerOnly (#serverOnly job);
663 Settings.setJsFuncs (#jsFuncs job);
664 Settings.setRewriteRules (#rewrites job);
665 Settings.setUrlRules (#filterUrl job);
666 Settings.setMimeRules (#filterMime job);
667 Option.app Settings.setProtocol (#protocol job);
668 Option.app Settings.setDbms (#dbms job);
669 Settings.setSafeGets (#safeGets job);
670 Settings.setOnError (#onError job);
671 job
672 end
673 in
674 {Job = pu fname, Libs = !bigLibs}
675 end
676 718
677 fun p_job' {Job = j, Libs = _ : string list} = p_job j 719 fun p_job' {Job = j, Libs = _ : string list} = p_job j
678 720
679 val parseUrp = { 721 val parseUrp = {
680 func = #Job o parseUrp' true, 722 func = #Job o parseUrp' true,
700 case ro of 742 case ro of
701 NONE => (NONE, pmap) 743 NONE => (NONE, pmap)
702 | SOME v => #time tr2 (v, pmap) 744 | SOME v => #time tr2 (v, pmap)
703 end 745 end
704 } 746 }
705
706 fun capitalize "" = ""
707 | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
708 747
709 structure SM = BinaryMapFn(struct 748 structure SM = BinaryMapFn(struct
710 type ord_key = string 749 type ord_key = string
711 val compare = String.compare 750 val compare = String.compare
712 end) 751 end)