Mercurial > urweb
comparison src/cjr_print.sml @ 734:f2a2be93331c
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\");", |