Mercurial > urweb

comparison src/monoize.sml @ 735:5ccb67665d05

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Only use cookie signatures when cookies might be read
author Adam Chlipala <adamc@hcoop.net>
date Thu, 23 Apr 2009 14:10:10 -0400
parents f2a2be93331c
children 796e42c93c48
comparison
equal deleted inserted replaced
734:f2a2be93331c 735:5ccb67665d05
32 32
33 structure L = Core 33 structure L = Core
34 structure L' = Mono 34 structure L' = Mono
35 35
36 structure IM = IntBinaryMap 36 structure IM = IntBinaryMap
37 structure IS = IntBinarySet
37 38
38 val urlPrefix = ref "/" 39 val urlPrefix = ref "/"
39 40
40 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan) 41 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
41 42
535 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc)) 536 (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc))
536 e1 es 537 e1 es
537 end 538 end
538 539
539 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs) 540 fun strcatR loc e xs = strcatComma loc (map (fn (x, _) => (L'.EField (e, x), loc)) xs)
541
542 val readCookie = ref IS.empty
540 543
541 fun monoExp (env, st, fm) (all as (e, loc)) = 544 fun monoExp (env, st, fm) (all as (e, loc)) =
542 let 545 let
543 val strcat = strcat loc 546 val strcat = strcat loc
544 val strcatComma = strcatComma loc 547 val strcatComma = strcatComma loc
2451 NotFound => Found et 2454 NotFound => Found et
2452 | _ => Error) 2455 | _ => Error)
2453 | _ => findSubmit xml) 2456 | _ => findSubmit xml)
2454 | _ => NotFound 2457 | _ => NotFound
2455 2458
2456 val (action, fm) = case findSubmit xml of 2459 val (func, action, fm) = case findSubmit xml of
2457 NotFound => ((L'.EPrim (Prim.String ""), loc), fm) 2460 NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm)
2458 | Error => raise Fail "Not ready for multi-submit lforms yet" 2461 | Error => raise Fail "Not ready for multi-submit lforms yet"
2459 | Found (action, actionT) => 2462 | Found (action, actionT) =>
2460 let 2463 let
2464 val func = case #1 action of
2465 L.EClosure (n, _) => n
2466 | _ => raise Fail "Monoize: Action is not a closure"
2461 val actionT = monoType env actionT 2467 val actionT = monoType env actionT
2462 val (action, fm) = monoExp (env, st, fm) action 2468 val (action, fm) = monoExp (env, st, fm) action
2463 val (action, fm) = urlifyExp env fm (action, actionT) 2469 val (action, fm) = urlifyExp env fm (action, actionT)
2464 in 2470 in
2465 ((L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc), 2471 (func,
2472 (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc),
2466 (L'.EStrcat (action, 2473 (L'.EStrcat (action,
2467 (L'.EPrim (Prim.String "\""), loc)), loc)), loc), 2474 (L'.EPrim (Prim.String "\""), loc)), loc)), loc),
2468 fm) 2475 fm)
2469 end 2476 end
2470
2471 fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
2472 | _ => true) fields
2473
2474 fun getSigName () =
2475 let
2476 fun getSigName' n =
2477 let
2478 val s = "Sig" ^ Int.toString n
2479 in
2480 if inFields s then
2481 getSigName' (n + 1)
2482 else
2483 s
2484 end
2485 in
2486 if inFields "Sig" then
2487 getSigName' 0
2488 else
2489 "Sig"
2490 end
2491
2492 val sigName = getSigName ()
2493 val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc)
2494 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
2495 ^ sigName
2496 ^ "\" value=\"")), loc),
2497 sigSet), loc)
2498 val sigSet = (L'.EStrcat (sigSet,
2499 (L'.EPrim (Prim.String "\">"), loc)), loc)
2500 2477
2501 val (xml, fm) = monoExp (env, st, fm) xml 2478 val (xml, fm) = monoExp (env, st, fm) xml
2502 val xml = (L'.EStrcat (sigSet, xml), loc) 2479
2480 val xml =
2481 if IS.member (!readCookie, func) then
2482 let
2483 fun inFields s = List.exists (fn ((L.CName s', _), _) => s' = s
2484 | _ => true) fields
2485
2486 fun getSigName () =
2487 let
2488 fun getSigName' n =
2489 let
2490 val s = "Sig" ^ Int.toString n
2491 in
2492 if inFields s then
2493 getSigName' (n + 1)
2494 else
2495 s
2496 end
2497 in
2498 if inFields "Sig" then
2499 getSigName' 0
2500 else
2501 "Sig"
2502 end
2503
2504 val sigName = getSigName ()
2505 val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc)
2506 val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\""
2507 ^ sigName
2508 ^ "\" value=\"")), loc),
2509 sigSet), loc)
2510 val sigSet = (L'.EStrcat (sigSet,
2511 (L'.EPrim (Prim.String "\">"), loc)), loc)
2512 in
2513 (L'.EStrcat (sigSet, xml), loc)
2514 end
2515 else
2516 xml
2503 in 2517 in
2504 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc), 2518 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc),
2505 (L'.EStrcat (action, 2519 (L'.EStrcat (action,
2506 (L'.EPrim (Prim.String ">"), loc)), loc)), loc), 2520 (L'.EPrim (Prim.String ">"), loc)), loc)), loc),
2507 (L'.EStrcat (xml, 2521 (L'.EStrcat (xml,
2790 urlPrefix := "/" 2804 urlPrefix := "/"
2791 else if String.sub (p, size p - 1) <> #"/" then 2805 else if String.sub (p, size p - 1) <> #"/" then
2792 urlPrefix := p ^ "/" 2806 urlPrefix := p ^ "/"
2793 else 2807 else
2794 () 2808 ()
2809
2810 (* Calculate which exported functions need cookie signature protection *)
2811 val rcook = foldl (fn ((d, _), rcook) =>
2812 case d of
2813 L.DExport (L.Action L.ReadCookieWrite, n) => IS.add (rcook, n)
2814 | L.DExport (L.Rpc L.ReadCookieWrite, n) => IS.add (rcook, n)
2815 | _ => rcook)
2816 IS.empty file
2817 val () = readCookie := rcook
2795 2818
2796 val loc = E.dummySpan 2819 val loc = E.dummySpan
2797 val client = (L'.TFfi ("Basis", "client"), loc) 2820 val client = (L'.TFfi ("Basis", "client"), loc)
2798 val unit = (L'.TRecord [], loc) 2821 val unit = (L'.TRecord [], loc)
2799 2822