Mercurial > urweb

comparison src/compiler.sml @ 769:efceae06df17

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
allow/deny working in Mono_opt
author Adam Chlipala <adamc@hcoop.net>
date Sat, 02 May 2009 13:37:52 -0400
parents 3b7e46790fa7
children d20d6afc1206
comparison
equal deleted inserted replaced
768:3b7e46790fa7 769:efceae06df17
49 clientToServer : Settings.ffi list, 49 clientToServer : Settings.ffi list,
50 effectful : Settings.ffi list, 50 effectful : Settings.ffi list,
51 clientOnly : Settings.ffi list, 51 clientOnly : Settings.ffi list,
52 serverOnly : Settings.ffi list, 52 serverOnly : Settings.ffi list,
53 jsFuncs : (Settings.ffi * string) list, 53 jsFuncs : (Settings.ffi * string) list,
54 rewrites : Settings.rewrite list 54 rewrites : Settings.rewrite list,
55 filterUrl : Settings.rule list,
56 filterMime : Settings.rule list
55 } 57 }
56 58
57 type ('src, 'dst) phase = { 59 type ('src, 'dst) phase = {
58 func : 'src -> 'dst, 60 func : 'src -> 'dst,
59 print : 'dst -> Print.PD.pp_desc 61 print : 'dst -> Print.PD.pp_desc
312 val effectful = ref [] 314 val effectful = ref []
313 val clientOnly = ref [] 315 val clientOnly = ref []
314 val serverOnly = ref [] 316 val serverOnly = ref []
315 val jsFuncs = ref [] 317 val jsFuncs = ref []
316 val rewrites = ref [] 318 val rewrites = ref []
319 val url = ref []
320 val mime = ref []
317 val libs = ref [] 321 val libs = ref []
318 322
319 fun finish sources = 323 fun finish sources =
320 let 324 let
321 val job = { 325 val job = {
335 effectful = rev (!effectful), 339 effectful = rev (!effectful),
336 clientOnly = rev (!clientOnly), 340 clientOnly = rev (!clientOnly),
337 serverOnly = rev (!serverOnly), 341 serverOnly = rev (!serverOnly),
338 jsFuncs = rev (!jsFuncs), 342 jsFuncs = rev (!jsFuncs),
339 rewrites = rev (!rewrites), 343 rewrites = rev (!rewrites),
344 filterUrl = rev (!url),
345 filterMime = rev (!mime),
340 sources = sources 346 sources = sources
341 } 347 }
342 348
343 fun mergeO f (old, new) = 349 fun mergeO f (old, new) =
344 case (old, new) of 350 case (old, new) of
370 effectful = #effectful old @ #effectful new, 376 effectful = #effectful old @ #effectful new,
371 clientOnly = #clientOnly old @ #clientOnly new, 377 clientOnly = #clientOnly old @ #clientOnly new,
372 serverOnly = #serverOnly old @ #serverOnly new, 378 serverOnly = #serverOnly old @ #serverOnly new,
373 jsFuncs = #jsFuncs old @ #jsFuncs new, 379 jsFuncs = #jsFuncs old @ #jsFuncs new,
374 rewrites = #rewrites old @ #rewrites new, 380 rewrites = #rewrites old @ #rewrites new,
381 filterUrl = #filterUrl old @ #filterUrl new,
382 filterMime = #filterMime old @ #filterMime new,
375 sources = #sources old @ #sources new 383 sources = #sources old @ #sources new
376 } 384 }
377 in 385 in
378 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs) 386 foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs)
379 end 387 end
391 | _ => (ErrorMsg.error "Bad path kind spec"; 399 | _ => (ErrorMsg.error "Bad path kind spec";
392 Settings.Any) 400 Settings.Any)
393 401
394 fun parseFrom s = 402 fun parseFrom s =
395 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then 403 if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then
404 (Settings.Prefix, String.substring (s, 0, size s - 1))
405 else
406 (Settings.Exact, s)
407
408 fun parseFkind s =
409 case s of
410 "url" => url
411 | "mime" => mime
412 | _ => (ErrorMsg.error "Bad filter kind";
413 url)
414
415 fun parsePattern s =
416 if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
396 (Settings.Prefix, String.substring (s, 0, size s - 1)) 417 (Settings.Prefix, String.substring (s, 0, size s - 1))
397 else 418 else
398 (Settings.Exact, s) 419 (Settings.Exact, s)
399 420
400 fun read () = 421 fun read () =
473 case String.tokens Char.isSpace arg of 494 case String.tokens Char.isSpace arg of
474 [pkind, from, to] => doit (pkind, from, to) 495 [pkind, from, to] => doit (pkind, from, to)
475 | [pkind, from] => doit (pkind, from, "") 496 | [pkind, from] => doit (pkind, from, "")
476 | _ => ErrorMsg.error "Bad 'rewrite' syntax" 497 | _ => ErrorMsg.error "Bad 'rewrite' syntax"
477 end 498 end
499 | "allow" =>
500 (case String.tokens Char.isSpace arg of
501 [fkind, pattern] =>
502 let
503 val fkind = parseFkind fkind
504 val (kind, pattern) = parsePattern pattern
505 in
506 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
507 end
508 | _ => ErrorMsg.error "Bad 'allow' syntax")
509 | "deny" =>
510 (case String.tokens Char.isSpace arg of
511 [fkind, pattern] =>
512 let
513 val fkind = parseFkind fkind
514 val (kind, pattern) = parsePattern pattern
515 in
516 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
517 end
518 | _ => ErrorMsg.error "Bad 'deny' syntax")
478 | "library" => libs := relify arg :: !libs 519 | "library" => libs := relify arg :: !libs
479 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); 520 | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
480 read () 521 read ()
481 end 522 end
482 523
491 Settings.setEffectful (#effectful job); 532 Settings.setEffectful (#effectful job);
492 Settings.setClientOnly (#clientOnly job); 533 Settings.setClientOnly (#clientOnly job);
493 Settings.setServerOnly (#serverOnly job); 534 Settings.setServerOnly (#serverOnly job);
494 Settings.setJsFuncs (#jsFuncs job); 535 Settings.setJsFuncs (#jsFuncs job);
495 Settings.setRewriteRules (#rewrites job); 536 Settings.setRewriteRules (#rewrites job);
537 Settings.setUrlRules (#filterUrl job);
538 Settings.setMimeRules (#filterMime job);
496 job 539 job
497 end 540 end
498 541
499 val parseUrp = { 542 val parseUrp = {
500 func = parseUrp', 543 func = parseUrp',