Mercurial > urweb

comparison src/scriptcheck.sml @ 2064:3dd041b00087

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Extend ScriptCheck to take RPCs into account
author Adam Chlipala <adam@chlipala.net>
date Sun, 24 Aug 2014 11:43:49 -0400
parents a9159911c3ba
children 25874084bf1f
comparison
equal deleted inserted replaced
2063:83bdb52962c9 2064:3dd041b00087
1 (* Copyright (c) 2009, Adam Chlipala 1 (* Copyright (c) 2009, 2014, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
27 27
28 structure ScriptCheck :> SCRIPT_CHECK = struct 28 structure ScriptCheck :> SCRIPT_CHECK = struct
29 29
30 open Mono 30 open Mono
31 31
32 structure SM = BinaryMapFn(struct
33 type ord_key = string
34 val compare = String.compare
35 end)
32 structure SS = BinarySetFn(struct 36 structure SS = BinarySetFn(struct
33 type ord_key = string 37 type ord_key = string
34 val compare = String.compare 38 val compare = String.compare
35 end) 39 end)
36 structure IS = IntBinarySet 40 structure IS = IntBinarySet
37 41
38 val pushBasis = SS.addList (SS.empty, 42 val pushBasis = SS.addList (SS.empty,
39 ["new_channel", 43 ["new_channel",
40 "self"]) 44 "self"])
41 45
46 datatype rpcmap =
47 Rpc of int (* ID of function definition *)
48 | Module of rpcmap SM.map
49
50 fun lookup (r : rpcmap, k : string) =
51 let
52 fun lookup' (r, ks) =
53 case r of
54 Rpc x => SOME x
55 | Module m =>
56 case ks of
57 [] => NONE
58 | k :: ks' =>
59 case SM.find (m, k) of
60 NONE => NONE
61 | SOME r' => lookup' (r', ks')
62 in
63 lookup' (r, String.tokens (fn ch => ch = #"/") k)
64 end
65
66 fun insert (r : rpcmap, k : string, v) =
67 let
68 fun insert' (r, ks) =
69 case r of
70 Rpc _ => Rpc v
71 | Module m =>
72 case ks of
73 [] => Rpc v
74 | k :: ks' =>
75 let
76 val r' = case SM.find (m, k) of
77 NONE => Module SM.empty
78 | SOME r' => r'
79 in
80 Module (SM.insert (m, k, insert' (r', ks')))
81 end
82 in
83 insert' (r, String.tokens (fn ch => ch = #"/") k)
84 end
85
86 fun dump (r : rpcmap) =
87 case r of
88 Rpc _ => print "ROOT\n"
89 | Module m => (print "<Module>\n";
90 SM.appi (fn (k, r') => (print (k ^ ":\n");
91 dump r')) m;
92 print "</Module>\n")
93
42 fun classify (ds, ps) = 94 fun classify (ds, ps) =
43 let 95 let
44 val proto = Settings.currentProtocol () 96 val proto = Settings.currentProtocol ()
45 97
46 fun inString {needle, haystack} = String.isSubstring needle haystack 98 fun inString {needle, haystack} = String.isSubstring needle haystack
47 99
48 fun hasClient {basis, funcs, push} = 100 fun hasClient {basis, rpcs, funcs, push} =
49 MonoUtil.Exp.exists {typ = fn _ => false, 101 MonoUtil.Exp.exists {typ = fn _ => false,
50 exp = fn ERecv _ => push 102 exp = fn ERecv _ => push
51 | EFfiApp ("Basis", x, _) => SS.member (basis, x) 103 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
52 | EJavaScript _ => not push 104 | EJavaScript _ => not push
53 | ENamed n => IS.member (funcs, n) 105 | ENamed n => IS.member (funcs, n)
106 | EServerCall (e, _, _, _) =>
107 let
108 fun head (e : exp) =
109 case #1 e of
110 EStrcat (e1, _) => head e1
111 | EPrim (Prim.String (_, s)) => SOME s
112 | _ => NONE
113 in
114 case head e of
115 NONE => true
116 | SOME fcall =>
117 case lookup (rpcs, fcall) of
118 NONE => true
119 | SOME n => IS.member (funcs, n)
120 end
54 | _ => false} 121 | _ => false}
122
123 fun decl ((d, _), rpcs) =
124 case d of
125 DExport (Mono.Rpc _, fcall, n, _, _, _) =>
126 insert (rpcs, fcall, n)
127 | _ => rpcs
128
129 val rpcs = foldl decl (Module SM.empty) ds
55 130
56 fun decl ((d, _), (pull_ids, push_ids)) = 131 fun decl ((d, _), (pull_ids, push_ids)) =
57 let 132 let
58 val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false} 133 val hasClientPull = hasClient {basis = SS.empty, rpcs = rpcs, funcs = pull_ids, push = false}
59 val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true} 134 val hasClientPush = hasClient {basis = pushBasis, rpcs = rpcs, funcs = push_ids, push = true}
60 in 135 in
61 case d of 136 case d of
62 DVal (_, n, _, e, _) => (if hasClientPull e then 137 DVal (_, n, _, e, _) => (if hasClientPull e then
63 IS.add (pull_ids, n) 138 IS.add (pull_ids, n)
64 else 139 else
65 pull_ids, 140 pull_ids,
66 if hasClientPush e then 141 if hasClientPush e then
67 IS.add (push_ids, n) 142 IS.add (push_ids, n)
68 else 143 else
69 push_ids) 144 push_ids)
70 | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then 145 | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
71 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) 146 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
72 pull_ids xes 147 pull_ids xes
73 else 148 else
74 pull_ids, 149 pull_ids,
75 if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then 150 if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then
76 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) 151 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
77 push_ids xes 152 push_ids xes