Mercurial > urweb

comparison src/cjr_print.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
2225 E.declBinds env d)) 2225 E.declBinds env d))
2226 env ds 2226 env ds
2227 2227
2228 val fields = foldl (fn ((ek, _, _, ts, _, _), fields) => 2228 val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
2229 case ek of 2229 case ek of
2230 Core.Link => fields 2230 Link => fields
2231 | Core.Rpc _ => fields 2231 | Rpc _ => fields
2232 | Core.Action _ => 2232 | Action eff =>
2233 case List.nth (ts, length ts - 2) of 2233 case List.nth (ts, length ts - 2) of
2234 (TRecord i, _) => 2234 (TRecord i, _) =>
2235 let 2235 let
2236 val xts = E.lookupStruct env i 2236 val xts = E.lookupStruct env i
2237 val xts = (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts 2237 val xts = case eff of
2238 ReadCookieWrite =>
2239 (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
2240 | _ => xts
2238 val xtsSet = SS.addList (SS.empty, map #1 xts) 2241 val xtsSet = SS.addList (SS.empty, map #1 xts)
2239 in 2242 in
2240 foldl (fn ((x, _), fields) => 2243 foldl (fn ((x, _), fields) =>
2241 let 2244 let
2242 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) 2245 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
2422 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record" 2425 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
2423 2426
2424 fun couldWrite ek = 2427 fun couldWrite ek =
2425 case ek of 2428 case ek of
2426 Link => false 2429 Link => false
2427 | Action ef => ef = ReadWrite 2430 | Action ef => ef = ReadCookieWrite
2428 | Rpc ef => ef = ReadWrite 2431 | Rpc ef => ef = ReadCookieWrite
2429 in 2432 in
2430 box [if couldWrite ek then 2433 box [string "if (!strncmp(request, \"",
2434 string (String.toString s),
2435 string "\", ",
2436 string (Int.toString (size s)),
2437 string ") && (request[",
2438 string (Int.toString (size s)),
2439 string "] == 0 || request[",
2440 string (Int.toString (size s)),
2441 string "] == '/')) {",
2442 newline,
2443 string "request += ",
2444 string (Int.toString (size s)),
2445 string ";",
2446 newline,
2447 string "if (*request == '/') ++request;",
2448 newline,
2449 if couldWrite ek then
2431 box [string "{", 2450 box [string "{",
2432 newline, 2451 newline,
2433 string "uw_Basis_string sig = ", 2452 string "uw_Basis_string sig = ",
2434 case fields of 2453 case fields of
2435 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")" 2454 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
2448 newline], 2467 newline],
2449 string "}", 2468 string "}",
2450 newline] 2469 newline]
2451 else 2470 else
2452 box [], 2471 box [],
2453
2454 string "if (!strncmp(request, \"",
2455 string (String.toString s),
2456 string "\", ",
2457 string (Int.toString (size s)),
2458 string ") && (request[",
2459 string (Int.toString (size s)),
2460 string "] == 0 || request[",
2461 string (Int.toString (size s)),
2462 string "] == '/')) {",
2463 newline,
2464 string "request += ",
2465 string (Int.toString (size s)),
2466 string ";",
2467 newline,
2468 string "if (*request == '/') ++request;",
2469 newline,
2470 box (case ek of 2472 box (case ek of
2471 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");", 2473 Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
2472 newline] 2474 newline]
2473 | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");", 2475 | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
2474 newline, 2476 newline,