Mercurial > urweb

comparison src/compiler.sml @ 1780:85a87f155e7b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Flush elaboration cache when switching between .urp files
author Adam Chlipala <adam@chlipala.net>
date Sat, 23 Jun 2012 10:11:33 -0400
parents b5f5e8d439c7
children 3d922a28370b
comparison
equal deleted inserted replaced
1779:7095e1b7240b 1780:85a87f155e7b
399 else 399 else
400 s)) 400 s))
401 end 401 end
402 end 402 end
403 403
404 val lastUrp = ref ""
405
404 fun parseUrp' accLibs fname = 406 fun parseUrp' accLibs fname =
405 if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", [])) 407 (if !lastUrp = fname then
406 andalso Posix.FileSys.access (fname ^ ".ur", []) then 408 ()
407 let 409 else
408 val job = {prefix = "/", 410 ModDb.reset ();
409 database = NONE, 411 lastUrp := fname;
410 sources = [fname], 412 if not (Posix.FileSys.access (fname ^ ".urp", []) orelse Posix.FileSys.access (fname ^ "/lib.urp", []))
411 exe = fname ^ ".exe", 413 andalso Posix.FileSys.access (fname ^ ".ur", []) then
412 sql = NONE, 414 let
413 debug = Settings.getDebug (), 415 val job = {prefix = "/",
414 profile = false, 416 database = NONE,
415 timeout = 60, 417 sources = [fname],
416 ffi = [], 418 exe = fname ^ ".exe",
417 link = [], 419 sql = NONE,
418 linker = NONE, 420 debug = Settings.getDebug (),
419 headers = [], 421 profile = false,
420 scripts = [], 422 timeout = 60,
421 clientToServer = [], 423 ffi = [],
422 effectful = [], 424 link = [],
423 benignEffectful = [], 425 linker = NONE,
424 clientOnly = [], 426 headers = [],
425 serverOnly = [], 427 scripts = [],
426 jsFuncs = [], 428 clientToServer = [],
427 rewrites = [{pkind = Settings.Any, 429 effectful = [],
428 kind = Settings.Prefix, 430 benignEffectful = [],
429 from = capitalize (OS.Path.file fname) ^ "/", to = "", 431 clientOnly = [],
430 hyphenate = false}], 432 serverOnly = [],
431 filterUrl = [], 433 jsFuncs = [],
432 filterMime = [], 434 rewrites = [{pkind = Settings.Any,
433 filterRequest = [], 435 kind = Settings.Prefix,
434 filterResponse = [], 436 from = capitalize (OS.Path.file fname) ^ "/", to = "",
435 protocol = NONE, 437 hyphenate = false}],
436 dbms = NONE, 438 filterUrl = [],
437 sigFile = NONE, 439 filterMime = [],
438 safeGets = [], 440 filterRequest = [],
439 onError = NONE, 441 filterResponse = [],
440 minHeap = 0} 442 protocol = NONE,
441 in 443 dbms = NONE,
442 institutionalizeJob job; 444 sigFile = NONE,
443 {Job = job, Libs = []} 445 safeGets = [],
444 end 446 onError = NONE,
445 else 447 minHeap = 0}
446 let 448 in
447 val pathmap = ref (!pathmap) 449 institutionalizeJob job;
448 val bigLibs = ref [] 450 {Job = job, Libs = []}
449 451 end
450 fun pu filename = 452 else
451 let 453 let
452 val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()} 454 val pathmap = ref (!pathmap)
453 455 val bigLibs = ref []
454 val dir = OS.Path.dir filename 456
455 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) 457 fun pu filename =
456 458 let
457 val inf = opener () 459 val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()}
458 460
459 fun hasSpaceLine () = 461 val dir = OS.Path.dir filename
460 case inputCommentableLine inf of 462 fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
461 Content s => s = "debug" orelse s = "profile" 463
462 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine () 464 val inf = opener ()
463 | EndOfFile => false 465
464 | OnlyComment => hasSpaceLine () 466 fun hasSpaceLine () =
465 467 case inputCommentableLine inf of
466 val hasBlankLine = hasSpaceLine () 468 Content s => s = "debug" orelse s = "profile"
467 469 orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
468 val inf = (TextIO.closeIn inf; opener ()) 470 | EndOfFile => false
469 471 | OnlyComment => hasSpaceLine ()
470 fun pathify fname = 472
471 if size fname > 0 andalso String.sub (fname, 0) = #"$" then 473 val hasBlankLine = hasSpaceLine ()
472 let 474
473 val fname' = Substring.extract (fname, 1, NONE) 475 val inf = (TextIO.closeIn inf; opener ())
474 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname' 476
475 in 477 fun pathify fname =
476 case M.find (!pathmap, Substring.string befor) of 478 if size fname > 0 andalso String.sub (fname, 0) = #"$" then
477 NONE => fname 479 let
478 | SOME rep => rep ^ Substring.string after 480 val fname' = Substring.extract (fname, 1, NONE)
479 end 481 val (befor, after) = Substring.splitl (fn ch => ch <> #"/") fname'
480 else 482 in
481 fname 483 case M.find (!pathmap, Substring.string befor) of
482 484 NONE => fname
483 fun relify fname = 485 | SOME rep => rep ^ Substring.string after
484 let 486 end
485 val fname = pathify fname
486 in
487 OS.Path.concat (dir, fname)
488 handle OS.Path.Path => fname
489 end
490
491 fun libify path =
492 (if Posix.FileSys.access (path ^ ".urp", []) then
493 path
494 else 487 else
495 path ^ "/lib") 488 fname
496 handle SysErr => path 489
497 490 fun relify fname =
498 fun libify' path = 491 let
499 (if Posix.FileSys.access (relify path ^ ".urp", []) then 492 val fname = pathify fname
500 path 493 in
494 OS.Path.concat (dir, fname)
495 handle OS.Path.Path => fname
496 end
497
498 fun libify path =
499 (if Posix.FileSys.access (path ^ ".urp", []) then
500 path
501 else
502 path ^ "/lib")
503 handle SysErr => path
504
505 fun libify' path =
506 (if Posix.FileSys.access (relify path ^ ".urp", []) then
507 path
508 else
509 path ^ "/lib")
510 handle SysErr => path
511
512 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
513
514 fun relifyA fname =
515 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir}
516
517 fun readSources acc =
518 case inputCommentableLine inf of
519 Content line =>
520 let
521 val acc = if CharVector.all Char.isSpace line then
522 acc
523 else
524 let
525 val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
526 (String.explode line))
527 val fname = relifyA fname
528 in
529 fname :: acc
530 end
531 in
532 readSources acc
533 end
534 | OnlyComment => readSources acc
535 | EndOfFile => rev acc
536
537 val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s)
538 val database = ref (Settings.getDbstring ())
539 val exe = ref (Settings.getExe ())
540 val sql = ref (Settings.getSql ())
541 val debug = ref (Settings.getDebug ())
542 val profile = ref false
543 val timeout = ref NONE
544 val ffi = ref []
545 val link = ref []
546 val linker = ref NONE
547 val headers = ref []
548 val scripts = ref []
549 val clientToServer = ref []
550 val effectful = ref []
551 val benignEffectful = ref []
552 val clientOnly = ref []
553 val serverOnly = ref []
554 val jsFuncs = ref []
555 val rewrites = ref []
556 val url = ref []
557 val mime = ref []
558 val request = ref []
559 val response = ref []
560 val libs = ref []
561 val protocol = ref NONE
562 val dbms = ref NONE
563 val sigFile = ref (Settings.getSigFile ())
564 val safeGets = ref []
565 val onError = ref NONE
566 val minHeap = ref 0
567
568 fun finish sources =
569 let
570 val job = {
571 prefix = Option.getOpt (!prefix, "/"),
572 database = !database,
573 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
574 ext = SOME "exe"}),
575 sql = !sql,
576 debug = !debug,
577 profile = !profile,
578 timeout = Option.getOpt (!timeout, 60),
579 ffi = rev (!ffi),
580 link = rev (!link),
581 linker = !linker,
582 headers = rev (!headers),
583 scripts = rev (!scripts),
584 clientToServer = rev (!clientToServer),
585 effectful = rev (!effectful),
586 benignEffectful = rev (!benignEffectful),
587 clientOnly = rev (!clientOnly),
588 serverOnly = rev (!serverOnly),
589 jsFuncs = rev (!jsFuncs),
590 rewrites = rev (!rewrites),
591 filterUrl = rev (!url),
592 filterMime = rev (!mime),
593 filterRequest = rev (!request),
594 filterResponse = rev (!response),
595 sources = sources,
596 protocol = !protocol,
597 dbms = !dbms,
598 sigFile = !sigFile,
599 safeGets = rev (!safeGets),
600 onError = !onError,
601 minHeap = !minHeap
602 }
603
604 fun mergeO f (old, new) =
605 case (old, new) of
606 (NONE, _) => new
607 | (_, NONE) => old
608 | (SOME v1, SOME v2) => SOME (f (v1, v2))
609
610 fun same desc = mergeO (fn (x : string, y) =>
611 (if x = y then
612 ()
613 else
614 ErrorMsg.error ("Multiple "
615 ^ desc ^ " values that don't agree");
616 x))
617
618 fun merge (old : job, new : job) = {
619 prefix = case #prefix old of
620 "/" => #prefix new
621 | pold => case #prefix new of
622 "/" => pold
623 | pnew => (if pold = pnew then
624 ()
625 else
626 ErrorMsg.error ("Multiple prefix values that don't agree: "
627 ^ pold ^ ", " ^ pnew);
628 pold),
629 database = mergeO (fn (old, _) => old) (#database old, #database new),
630 exe = #exe old,
631 sql = #sql old,
632 debug = #debug old orelse #debug new,
633 profile = #profile old orelse #profile new,
634 timeout = #timeout old,
635 ffi = #ffi old @ #ffi new,
636 link = #link old @ #link new,
637 linker = mergeO (fn (_, new) => new) (#linker old, #linker new),
638 headers = #headers old @ #headers new,
639 scripts = #scripts old @ #scripts new,
640 clientToServer = #clientToServer old @ #clientToServer new,
641 effectful = #effectful old @ #effectful new,
642 benignEffectful = #benignEffectful old @ #benignEffectful new,
643 clientOnly = #clientOnly old @ #clientOnly new,
644 serverOnly = #serverOnly old @ #serverOnly new,
645 jsFuncs = #jsFuncs old @ #jsFuncs new,
646 rewrites = #rewrites old @ #rewrites new,
647 filterUrl = #filterUrl old @ #filterUrl new,
648 filterMime = #filterMime old @ #filterMime new,
649 filterRequest = #filterRequest old @ #filterRequest new,
650 filterResponse = #filterResponse old @ #filterResponse new,
651 sources = #sources new
652 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
653 (#sources old),
654 protocol = mergeO #2 (#protocol old, #protocol new),
655 dbms = mergeO #2 (#dbms old, #dbms new),
656 sigFile = mergeO #2 (#sigFile old, #sigFile new),
657 safeGets = #safeGets old @ #safeGets new,
658 onError = mergeO #2 (#onError old, #onError new),
659 minHeap = Int.max (#minHeap old, #minHeap new)
660 }
661 in
662 if accLibs then
663 foldr (fn (job', job) => merge (job, job')) job (!libs)
664 else
665 job
666 end
667
668 fun parsePkind s =
669 case s of
670 "all" => Settings.Any
671 | "url" => Settings.Url
672 | "table" => Settings.Table
673 | "sequence" => Settings.Sequence
674 | "view" => Settings.View
675 | "relation" => Settings.Relation
676 | "cookie" => Settings.Cookie
677 | "style" => Settings.Style
678 | _ => (ErrorMsg.error "Bad path kind spec";
679 Settings.Any)
680
681 fun parseFrom s =
682 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
683 (Settings.Prefix, String.substring (s, 0, size s - 1))
501 else 684 else
502 path ^ "/lib") 685 (Settings.Exact, s)
503 handle SysErr => path 686
504 687 fun parseFkind s =
505 val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()} 688 case s of
506 689 "url" => url
507 fun relifyA fname = 690 | "mime" => mime
508 OS.Path.mkAbsolute {path = pathify fname, relativeTo = absDir} 691 | "requestHeader" => request
509 692 | "responseHeader" => response
510 fun readSources acc = 693 | _ => (ErrorMsg.error "Bad filter kind";
511 case inputCommentableLine inf of 694 url)
512 Content line => 695
513 let 696 fun parsePattern s =
514 val acc = if CharVector.all Char.isSpace line then 697 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
515 acc 698 (Settings.Prefix, String.substring (s, 0, size s - 1))
516 else 699 else
517 let 700 (Settings.Exact, s)
518 val fname = String.implode (List.filter (fn x => not (Char.isSpace x)) 701
519 (String.explode line)) 702 fun read () =
520 val fname = relifyA fname 703 case inputCommentableLine inf of
521 in 704 EndOfFile => finish []
522 fname :: acc 705 | OnlyComment => read ()
523 end 706 | Content "" => finish (readSources [])
524 in 707 | Content line =>
525 readSources acc 708 let
526 end 709 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
527 | OnlyComment => readSources acc 710 val cmd = Substring.string (trim cmd)
528 | EndOfFile => rev acc 711 val arg = Substring.string (trim arg)
529 712
530 val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s) 713 fun ffiS () =
531 val database = ref (Settings.getDbstring ()) 714 case String.fields (fn ch => ch = #".") arg of
532 val exe = ref (Settings.getExe ()) 715 [m, x] => (m, x)
533 val sql = ref (Settings.getSql ()) 716 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
534 val debug = ref (Settings.getDebug ()) 717 ("", ""))
535 val profile = ref false 718
536 val timeout = ref NONE 719 fun ffiM () =
537 val ffi = ref [] 720 case String.fields (fn ch => ch = #"=") arg of
538 val link = ref [] 721 [f, s] =>
539 val linker = ref NONE 722 let
540 val headers = ref [] 723 val f = trimS f
541 val scripts = ref [] 724 val s = trimS s
542 val clientToServer = ref [] 725 in
543 val effectful = ref [] 726 case String.fields (fn ch => ch = #".") f of
544 val benignEffectful = ref [] 727 [m, x] => ((m, x), s)
545 val clientOnly = ref [] 728 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
546 val serverOnly = ref [] 729 (("", ""), ""))
547 val jsFuncs = ref [] 730 end
548 val rewrites = ref [] 731 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
549 val url = ref [] 732 (("", ""), ""))
550 val mime = ref [] 733 in
551 val request = ref [] 734 case cmd of
552 val response = ref [] 735 "prefix" => prefix := SOME arg
553 val libs = ref [] 736 | "database" =>
554 val protocol = ref NONE 737 (case !database of
555 val dbms = ref NONE 738 NONE => database := SOME arg
556 val sigFile = ref (Settings.getSigFile ()) 739 | SOME _ => ())
557 val safeGets = ref [] 740 | "dbms" =>
558 val onError = ref NONE 741 (case !dbms of
559 val minHeap = ref 0 742 NONE => dbms := SOME arg
560 743 | SOME _ => ())
561 fun finish sources = 744 | "sigfile" =>
562 let 745 (case !sigFile of
563 val job = { 746 NONE => sigFile := SOME arg
564 prefix = Option.getOpt (!prefix, "/"), 747 | SOME _ => ())
565 database = !database, 748 | "exe" =>
566 exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, 749 (case !exe of
567 ext = SOME "exe"}), 750 NONE => exe := SOME (relify arg)
568 sql = !sql, 751 | SOME _ => ())
569 debug = !debug, 752 | "sql" =>
570 profile = !profile, 753 (case !sql of
571 timeout = Option.getOpt (!timeout, 60), 754 NONE => sql := SOME (relify arg)
572 ffi = rev (!ffi), 755 | SOME _ => ())
573 link = rev (!link), 756 | "debug" => debug := true
574 linker = !linker, 757 | "profile" => profile := true
575 headers = rev (!headers), 758 | "timeout" =>
576 scripts = rev (!scripts), 759 (case !timeout of
577 clientToServer = rev (!clientToServer), 760 NONE => ()
578 effectful = rev (!effectful), 761 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
579 benignEffectful = rev (!benignEffectful), 762 timeout := SOME (valOf (Int.fromString arg)))
580 clientOnly = rev (!clientOnly), 763 | "ffi" => ffi := relify arg :: !ffi
581 serverOnly = rev (!serverOnly), 764 | "link" => let
582 jsFuncs = rev (!jsFuncs), 765 val arg = if size arg >= 1
583 rewrites = rev (!rewrites), 766 andalso String.sub (arg, 0) = #"-" then
584 filterUrl = rev (!url), 767 arg
585 filterMime = rev (!mime), 768 else
586 filterRequest = rev (!request), 769 relifyA arg
587 filterResponse = rev (!response), 770 in
588 sources = sources, 771 link := arg :: !link
589 protocol = !protocol, 772 end
590 dbms = !dbms, 773 | "linker" => linker := SOME arg
591 sigFile = !sigFile, 774 | "include" => headers := relifyA arg :: !headers
592 safeGets = rev (!safeGets), 775 | "script" => scripts := arg :: !scripts
593 onError = !onError, 776 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
594 minHeap = !minHeap 777 | "safeGet" => safeGets := arg :: !safeGets
595 } 778 | "effectful" => effectful := ffiS () :: !effectful
596 779 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
597 fun mergeO f (old, new) = 780 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
598 case (old, new) of 781 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
599 (NONE, _) => new 782 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
600 | (_, NONE) => old 783 | "rewrite" =>
601 | (SOME v1, SOME v2) => SOME (f (v1, v2)) 784 let
602 785 fun doit (pkind, from, to, hyph) =
603 fun same desc = mergeO (fn (x : string, y) => 786 let
604 (if x = y then 787 val pkind = parsePkind pkind
605 () 788 val (kind, from) = parseFrom from
606 else 789 in
607 ErrorMsg.error ("Multiple " 790 rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites
608 ^ desc ^ " values that don't agree"); 791 end
609 x)) 792 in
610 793 case String.tokens Char.isSpace arg of
611 fun merge (old : job, new : job) = { 794 [pkind, from, to, "[-]"] => doit (pkind, from, to, true)
612 prefix = case #prefix old of 795 | [pkind, from, "[-]"] => doit (pkind, from, "", true)
613 "/" => #prefix new 796 | [pkind, from, to] => doit (pkind, from, to, false)
614 | pold => case #prefix new of 797 | [pkind, from] => doit (pkind, from, "", false)
615 "/" => pold 798 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
616 | pnew => (if pold = pnew then 799 end
617 () 800 | "allow" =>
618 else 801 (case String.tokens Char.isSpace arg of
619 ErrorMsg.error ("Multiple prefix values that don't agree: " 802 [fkind, pattern] =>
620 ^ pold ^ ", " ^ pnew); 803 let
621 pold), 804 val fkind = parseFkind fkind
622 database = mergeO (fn (old, _) => old) (#database old, #database new), 805 val (kind, pattern) = parsePattern pattern
623 exe = #exe old, 806 in
624 sql = #sql old, 807 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
625 debug = #debug old orelse #debug new, 808 end
626 profile = #profile old orelse #profile new, 809 | _ => ErrorMsg.error "Bad 'allow' syntax")
627 timeout = #timeout old, 810 | "deny" =>
628 ffi = #ffi old @ #ffi new, 811 (case String.tokens Char.isSpace arg of
629 link = #link old @ #link new, 812 [fkind, pattern] =>
630 linker = mergeO (fn (_, new) => new) (#linker old, #linker new), 813 let
631 headers = #headers old @ #headers new, 814 val fkind = parseFkind fkind
632 scripts = #scripts old @ #scripts new, 815 val (kind, pattern) = parsePattern pattern
633 clientToServer = #clientToServer old @ #clientToServer new, 816 in
634 effectful = #effectful old @ #effectful new, 817 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
635 benignEffectful = #benignEffectful old @ #benignEffectful new, 818 end
636 clientOnly = #clientOnly old @ #clientOnly new, 819 | _ => ErrorMsg.error "Bad 'deny' syntax")
637 serverOnly = #serverOnly old @ #serverOnly new, 820 | "library" => if accLibs then
638 jsFuncs = #jsFuncs old @ #jsFuncs new, 821 libs := pu (libify (relify arg)) :: !libs
639 rewrites = #rewrites old @ #rewrites new,
640 filterUrl = #filterUrl old @ #filterUrl new,
641 filterMime = #filterMime old @ #filterMime new,
642 filterRequest = #filterRequest old @ #filterRequest new,
643 filterResponse = #filterResponse old @ #filterResponse new,
644 sources = #sources new
645 @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
646 (#sources old),
647 protocol = mergeO #2 (#protocol old, #protocol new),
648 dbms = mergeO #2 (#dbms old, #dbms new),
649 sigFile = mergeO #2 (#sigFile old, #sigFile new),
650 safeGets = #safeGets old @ #safeGets new,
651 onError = mergeO #2 (#onError old, #onError new),
652 minHeap = Int.max (#minHeap old, #minHeap new)
653 }
654 in
655 if accLibs then
656 foldr (fn (job', job) => merge (job, job')) job (!libs)
657 else
658 job
659 end
660
661 fun parsePkind s =
662 case s of
663 "all" => Settings.Any
664 | "url" => Settings.Url
665 | "table" => Settings.Table
666 | "sequence" => Settings.Sequence
667 | "view" => Settings.View
668 | "relation" => Settings.Relation
669 | "cookie" => Settings.Cookie
670 | "style" => Settings.Style
671 | _ => (ErrorMsg.error "Bad path kind spec";
672 Settings.Any)
673
674 fun parseFrom s =
675 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
676 (Settings.Prefix, String.substring (s, 0, size s - 1))
677 else
678 (Settings.Exact, s)
679
680 fun parseFkind s =
681 case s of
682 "url" => url
683 | "mime" => mime
684 | "requestHeader" => request
685 | "responseHeader" => response
686 | _ => (ErrorMsg.error "Bad filter kind";
687 url)
688
689 fun parsePattern s =
690 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
691 (Settings.Prefix, String.substring (s, 0, size s - 1))
692 else
693 (Settings.Exact, s)
694
695 fun read () =
696 case inputCommentableLine inf of
697 EndOfFile => finish []
698 | OnlyComment => read ()
699 | Content "" => finish (readSources [])
700 | Content line =>
701 let
702 val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
703 val cmd = Substring.string (trim cmd)
704 val arg = Substring.string (trim arg)
705
706 fun ffiS () =
707 case String.fields (fn ch => ch = #".") arg of
708 [m, x] => (m, x)
709 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func");
710 ("", ""))
711
712 fun ffiM () =
713 case String.fields (fn ch => ch = #"=") arg of
714 [f, s] =>
715 let
716 val f = trimS f
717 val s = trimS s
718 in
719 case String.fields (fn ch => ch = #".") f of
720 [m, x] => ((m, x), s)
721 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
722 (("", ""), ""))
723 end
724 | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'");
725 (("", ""), ""))
726 in
727 case cmd of
728 "prefix" => prefix := SOME arg
729 | "database" =>
730 (case !database of
731 NONE => database := SOME arg
732 | SOME _ => ())
733 | "dbms" =>
734 (case !dbms of
735 NONE => dbms := SOME arg
736 | SOME _ => ())
737 | "sigfile" =>
738 (case !sigFile of
739 NONE => sigFile := SOME arg
740 | SOME _ => ())
741 | "exe" =>
742 (case !exe of
743 NONE => exe := SOME (relify arg)
744 | SOME _ => ())
745 | "sql" =>
746 (case !sql of
747 NONE => sql := SOME (relify arg)
748 | SOME _ => ())
749 | "debug" => debug := true
750 | "profile" => profile := true
751 | "timeout" =>
752 (case !timeout of
753 NONE => ()
754 | SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
755 timeout := SOME (valOf (Int.fromString arg)))
756 | "ffi" => ffi := relify arg :: !ffi
757 | "link" => let
758 val arg = if size arg >= 1
759 andalso String.sub (arg, 0) = #"-" then
760 arg
761 else 822 else
762 relifyA arg 823 bigLibs := libify' arg :: !bigLibs
763 in 824 | "path" =>
764 link := arg :: !link 825 (case String.fields (fn ch => ch = #"=") arg of
765 end 826 [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
766 | "linker" => linker := SOME arg
767 | "include" => headers := relifyA arg :: !headers
768 | "script" => scripts := arg :: !scripts
769 | "clientToServer" => clientToServer := ffiS () :: !clientToServer
770 | "safeGet" => safeGets := arg :: !safeGets
771 | "effectful" => effectful := ffiS () :: !effectful
772 | "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
773 | "clientOnly" => clientOnly := ffiS () :: !clientOnly
774 | "serverOnly" => serverOnly := ffiS () :: !serverOnly
775 | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
776 | "rewrite" =>
777 let
778 fun doit (pkind, from, to, hyph) =
779 let
780 val pkind = parsePkind pkind
781 val (kind, from) = parseFrom from
782 in
783 rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites
784 end
785 in
786 case String.tokens Char.isSpace arg of
787 [pkind, from, to, "[-]"] => doit (pkind, from, to, true)
788 | [pkind, from, "[-]"] => doit (pkind, from, "", true)
789 | [pkind, from, to] => doit (pkind, from, to, false)
790 | [pkind, from] => doit (pkind, from, "", false)
791 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
792 end
793 | "allow" =>
794 (case String.tokens Char.isSpace arg of
795 [fkind, pattern] =>
796 let
797 val fkind = parseFkind fkind
798 val (kind, pattern) = parsePattern pattern
799 in
800 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
801 end
802 | _ => ErrorMsg.error "Bad 'allow' syntax")
803 | "deny" =>
804 (case String.tokens Char.isSpace arg of
805 [fkind, pattern] =>
806 let
807 val fkind = parseFkind fkind
808 val (kind, pattern) = parsePattern pattern
809 in
810 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
811 end
812 | _ => ErrorMsg.error "Bad 'deny' syntax")
813 | "library" => if accLibs then
814 libs := pu (libify (relify arg)) :: !libs
815 else
816 bigLibs := libify' arg :: !bigLibs
817 | "path" =>
818 (case String.fields (fn ch => ch = #"=") arg of
819 [n, v] => ((pathmap := M.insert (!pathmap, n, OS.Path.mkAbsolute {path = v, relativeTo = dir}))
820 handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument") 827 handle OS.Path.Path => ErrorMsg.error "Invalid 'path' directory argument")
821 | _ => ErrorMsg.error "path argument not of the form name=value'") 828 | _ => ErrorMsg.error "path argument not of the form name=value'")
822 | "onError" => 829 | "onError" =>
823 (case String.fields (fn ch => ch = #".") arg of 830 (case String.fields (fn ch => ch = #".") arg of
824 m1 :: (fs as _ :: _) => 831 m1 :: (fs as _ :: _) =>
825 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs) 832 onError := SOME (m1, List.take (fs, length fs - 1), List.last fs)
826 | _ => ErrorMsg.error "invalid 'onError' argument") 833 | _ => ErrorMsg.error "invalid 'onError' argument")
827 | "limit" => 834 | "limit" =>
828 (case String.fields Char.isSpace arg of 835 (case String.fields Char.isSpace arg of
829 [class, num] => 836 [class, num] =>
830 (case Int.fromString num of 837 (case Int.fromString num of
831 NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'") 838 NONE => ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
832 | SOME n => 839 | SOME n =>
833 if n < 0 then 840 if n < 0 then
834 ErrorMsg.error ("invalid limit number '" ^ num ^ "'") 841 ErrorMsg.error ("invalid limit number '" ^ num ^ "'")
835 else 842 else
836 Settings.addLimit (class, n)) 843 Settings.addLimit (class, n))
837 | _ => ErrorMsg.error "invalid 'limit' arguments") 844 | _ => ErrorMsg.error "invalid 'limit' arguments")
838 | "minHeap" => 845 | "minHeap" =>
839 (case Int.fromString arg of 846 (case Int.fromString arg of
840 NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'") 847 NONE => ErrorMsg.error ("invalid min heap '" ^ arg ^ "'")
841 | SOME n => minHeap := n) 848 | SOME n => minHeap := n)
842 | "alwaysInline" => Settings.addAlwaysInline arg 849 | "alwaysInline" => Settings.addAlwaysInline arg
843 | "noXsrfProtection" => Settings.addNoXsrfProtection arg 850 | "noXsrfProtection" => Settings.addNoXsrfProtection arg
844 | "timeFormat" => Settings.setTimeFormat arg 851 | "timeFormat" => Settings.setTimeFormat arg
845 852
846 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); 853 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
847 read () 854 read ()
848 end 855 end
849 856
850 val job = if hasBlankLine then 857 val job = if hasBlankLine then
851 read () 858 read ()
852 else 859 else
853 finish (readSources []) 860 finish (readSources [])
854 in 861 in
855 TextIO.closeIn inf; 862 TextIO.closeIn inf;
856 institutionalizeJob job; 863 institutionalizeJob job;
857 job 864 job
858 end 865 end
859 in 866 in
860 {Job = pu fname, Libs = !bigLibs} 867 {Job = pu fname, Libs = !bigLibs}
861 end 868 end)
862 869
863 fun p_job' {Job = j, Libs = _ : string list} = p_job j 870 fun p_job' {Job = j, Libs = _ : string list} = p_job j
864 871
865 val parseUrp = { 872 val parseUrp = {
866 func = #Job o parseUrp' true, 873 func = #Job o parseUrp' true,