Mercurial > urweb

comparison src/cjr_print.sml @ 734:f2a2be93331c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Cookie signing working for forms
author Adam Chlipala <adamc@hcoop.net>
date Thu, 16 Apr 2009 19:12:12 -0400
parents e0dd85ea58e1
children 5ccb67665d05
comparison
equal deleted inserted replaced
733:15ddd64a5113 734:f2a2be93331c
2196 fun is_not_null t = 2196 fun is_not_null t =
2197 case t of 2197 case t of
2198 (TOption _, _) => false 2198 (TOption _, _) => false
2199 | _ => true 2199 | _ => true
2200 2200
2201 fun sigName fields =
2202 let
2203 fun inFields s = List.exists (fn (s', _) => s' = s) fields
2204
2205 fun getSigName n =
2206 let
2207 val s = "Sig" ^ Int.toString n
2208 in
2209 if inFields s then
2210 getSigName (n + 1)
2211 else
2212 s
2213 end
2214 in
2215 if inFields "Sig" then
2216 getSigName 0
2217 else
2218 "Sig"
2219 end
2220
2201 fun p_file env (ds, ps) = 2221 fun p_file env (ds, ps) =
2202 let 2222 let
2203 val (pds, env) = ListUtil.foldlMap (fn (d, env) => 2223 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
2204 (p_decl env d, 2224 (p_decl env d,
2205 E.declBinds env d)) 2225 E.declBinds env d))
2212 | Core.Action _ => 2232 | Core.Action _ =>
2213 case List.nth (ts, length ts - 2) of 2233 case List.nth (ts, length ts - 2) of
2214 (TRecord i, _) => 2234 (TRecord i, _) =>
2215 let 2235 let
2216 val xts = E.lookupStruct env i 2236 val xts = E.lookupStruct env i
2237 val xts = (sigName xts, (TRecord 0, ErrorMsg.dummySpan)) :: xts
2217 val xtsSet = SS.addList (SS.empty, map #1 xts) 2238 val xtsSet = SS.addList (SS.empty, map #1 xts)
2218 in 2239 in
2219 foldl (fn ((x, _), fields) => 2240 foldl (fn ((x, _), fields) =>
2220 let 2241 let
2221 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty) 2242 val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
2242 n 2263 n
2243 in 2264 in
2244 SM.insert (fnums, x, findAvailable 0) 2265 SM.insert (fnums, x, findAvailable 0)
2245 end) 2266 end)
2246 SM.empty fields 2267 SM.empty fields
2268
2269 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
2247 2270
2248 fun makeSwitch (fnums, i) = 2271 fun makeSwitch (fnums, i) =
2249 case SM.foldl (fn (n, NotFound) => Found n 2272 case SM.foldl (fn (n, NotFound) => Found n
2250 | (n, Error) => Error 2273 | (n, Error) => Error
2251 | (n, Found n') => if n = n' then 2274 | (n, Found n') => if n = n' then
2326 string "}"] 2349 string "}"]
2327 end 2350 end
2328 2351
2329 fun p_page (ek, s, n, ts, ran, side) = 2352 fun p_page (ek, s, n, ts, ran, side) =
2330 let 2353 let
2331 val (ts, defInputs, inputsVar) = 2354 val (ts, defInputs, inputsVar, fields) =
2332 case ek of 2355 case ek of
2333 Core.Link => (List.take (ts, length ts - 1), string "", string "") 2356 Core.Link => (List.take (ts, length ts - 1), string "", string "", NONE)
2334 | Core.Rpc _ => (List.take (ts, length ts - 1), string "", string "") 2357 | Core.Rpc _ => (List.take (ts, length ts - 1), string "", string "", NONE)
2335 | Core.Action _ => 2358 | Core.Action _ =>
2336 case List.nth (ts, length ts - 2) of 2359 case List.nth (ts, length ts - 2) of
2337 (TRecord i, _) => 2360 (TRecord i, _) =>
2338 let 2361 let
2339 val xts = E.lookupStruct env i 2362 val xts = E.lookupStruct env i
2390 newline]) xts), 2413 newline]) xts),
2391 string "};", 2414 string "};",
2392 newline], 2415 newline],
2393 box [string ",", 2416 box [string ",",
2394 space, 2417 space,
2395 string "uw_inputs"]) 2418 string "uw_inputs"],
2419 SOME xts)
2396 end 2420 end
2397 2421
2398 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record" 2422 | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
2423
2424 fun couldWrite ek =
2425 case ek of
2426 Link => false
2427 | Action ef => ef = ReadWrite
2428 | Rpc ef => ef = ReadWrite
2399 in 2429 in
2400 box [string "if (!strncmp(request, \"", 2430 box [if couldWrite ek then
2431 box [string "{",
2432 newline,
2433 string "uw_Basis_string sig = ",
2434 case fields of
2435 NONE => string "uw_Basis_requestHeader(ctx, \"UrWeb-Sig\")"
2436 | SOME fields =>
2437 case SM.find (fnums, sigName fields) of
2438 NONE => raise Fail "CjrPrint: sig name wasn't assigned a number"
2439 | SOME inum =>
2440 string ("uw_get_input(ctx, " ^ Int.toString inum ^ ")"),
2441 string ";",
2442 newline,
2443 string "if (sig == NULL) uw_error(ctx, FATAL, \"Missing cookie signature\");",
2444 newline,
2445 string "if (strcmp(sig, uw_cookie_sig(ctx)))",
2446 newline,
2447 box [string "uw_error(ctx, FATAL, \"Wrong cookie signature\");",
2448 newline],
2449 string "}",
2450 newline]
2451 else
2452 box [],
2453
2454 string "if (!strncmp(request, \"",
2401 string (String.toString s), 2455 string (String.toString s),
2402 string "\", ", 2456 string "\", ",
2403 string (Int.toString (size s)), 2457 string (Int.toString (size s)),
2404 string ") && (request[", 2458 string ") && (request[",
2405 string (Int.toString (size s)), 2459 string (Int.toString (size s)),
2743 end) sequences, 2797 end) sequences,
2744 2798
2745 string "}"] 2799 string "}"]
2746 2800
2747 val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds 2801 val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds
2802
2803 val cookies = List.mapPartial (fn (DCookie s, _) => SOME s | _ => NONE) ds
2804
2805 val cookieCode = foldl (fn (cookie, acc) =>
2806 SOME (case acc of
2807 NONE => string ("uw_unnull(uw_Basis_get_cookie(ctx, \""
2808 ^ cookie ^ "\"))")
2809 | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_get_cookie(ctx, \""
2810 ^ cookie ^ "\")), uw_Basis_strcat(ctx, \"/\", "),
2811 acc,
2812 string "))"]))
2813 NONE cookies
2748 in 2814 in
2749 box [string "#include <stdio.h>", 2815 box [string "#include <stdio.h>",
2750 newline, 2816 newline,
2751 string "#include <stdlib.h>", 2817 string "#include <stdlib.h>",
2752 newline, 2818 newline,
2781 newline, 2847 newline,
2782 makeSwitch (fnums, 0), 2848 makeSwitch (fnums, 0),
2783 string "}", 2849 string "}",
2784 newline, 2850 newline,
2785 newline, 2851 newline,
2852
2853 string "extern void uw_sign(const char *in, char *out);",
2854 newline,
2855 string "extern int uw_hash_blocksize;",
2856 newline,
2857 string "uw_Basis_string uw_cookie_sig(uw_context ctx) {",
2858 newline,
2859 box [string "uw_Basis_string r = uw_malloc(ctx, uw_hash_blocksize);",
2860 newline,
2861 string "uw_sign(",
2862 case cookieCode of
2863 NONE => string "\"\""
2864 | SOME code => code,
2865 string ", r);",
2866 newline,
2867 string "return uw_Basis_makeSigString(ctx, r);",
2868 newline],
2869 string "}",
2870 newline,
2871 newline,
2872
2786 string "void uw_handle(uw_context ctx, char *request) {", 2873 string "void uw_handle(uw_context ctx, char *request) {",
2787 newline, 2874 newline,
2788 string "if (!strcmp(request, \"/app.js\")) {", 2875 string "if (!strcmp(request, \"/app.js\")) {",
2789 newline, 2876 newline,
2790 box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", 2877 box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",