summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/ur/basis.urs9
-rw-r--r--src/cjrize.sml1
-rw-r--r--src/core.sml1
-rw-r--r--src/core_env.sml1
-rw-r--r--src/core_print.sml3
-rw-r--r--src/core_util.sml8
-rw-r--r--src/corify.sml6
-rw-r--r--src/css.sml1
-rw-r--r--src/elab.sml1
-rw-r--r--src/elab_env.sml1
-rw-r--r--src/elab_print.sml3
-rw-r--r--src/elab_util.sml8
-rw-r--r--src/elaborate.sml10
-rw-r--r--src/elisp/urweb-defs.el6
-rw-r--r--src/elisp/urweb-mode.el4
-rw-r--r--src/expl.sml1
-rw-r--r--src/expl_env.sml1
-rw-r--r--src/expl_print.sml3
-rw-r--r--src/explify.sml1
-rw-r--r--src/mono.sml6
-rw-r--r--src/mono_env.sml1
-rw-r--r--src/mono_print.sml9
-rw-r--r--src/mono_shake.sml13
-rw-r--r--src/mono_util.sml14
-rw-r--r--src/monoize.sml14
-rw-r--r--src/reduce.sml9
-rw-r--r--src/reduce_local.sml1
-rw-r--r--src/shake.sml11
-rw-r--r--src/source.sml1
-rw-r--r--src/source_print.sml3
-rw-r--r--src/unnest.sml1
-rw-r--r--src/urweb.grm3
-rw-r--r--src/urweb.lex1
-rw-r--r--tests/policy.ur3
-rw-r--r--tests/policy.urp1
35 files changed, 145 insertions, 15 deletions
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 8388e107..aad04b5f 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -795,4 +795,13 @@ type task_kind
val initialize : task_kind
+(** Information flow security *)
+
+type sql_policy
+
+val query_policy : tables ::: {{Type}} -> exps ::: {Type}
+ -> [tables ~ exps] => sql_query [] tables exps
+ -> sql_policy
+
+
val debug : string -> transaction unit
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6e41a69b..b98b3c25 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -674,6 +674,7 @@ fun cifyDecl ((d, loc), sm) =
end
| _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
(NONE, NONE, sm)))
+ | L.DPolicy _ => (NONE, NONE, sm)
fun cjrize ds =
let
diff --git a/src/core.sml b/src/core.sml
index 90005f16..e5358f48 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -135,6 +135,7 @@ datatype decl' =
| DCookie of string * int * con * string
| DStyle of string * int * string
| DTask of exp * exp
+ | DPolicy of exp
withtype decl = decl' located
diff --git a/src/core_env.sml b/src/core_env.sml
index 9001e29c..478ef495 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -349,6 +349,7 @@ fun declBinds env (d, loc) =
pushENamed env x n t NONE s
end
| DTask _ => env
+ | DPolicy _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index d6be76a3..fd0556e6 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -618,6 +618,9 @@ fun p_decl env (dAll as (d, _) : decl) =
string "=",
space,
p_exp env e2]
+ | DPolicy e1 => box [string "policy",
+ space,
+ p_exp env e1]
fun p_file env file =
let
diff --git a/src/core_util.sml b/src/core_util.sml
index 247dd32e..eedcd2bb 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -992,6 +992,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
S.map2 (mfe ctx e2,
fn e2' =>
(DTask (e1', e2'), loc)))
+ | DPolicy e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (DPolicy e', loc))
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mfc ctx t,
@@ -1147,6 +1151,7 @@ fun mapfoldB (all as {bind, ...}) =
bind (ctx, NamedE (x, n, t, NONE, s))
end
| DTask _ => ctx
+ | DPolicy _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -1210,7 +1215,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DDatabase _ => count
| DCookie (_, n, _, _) => Int.max (n, count)
| DStyle (_, n, _) => Int.max (n, count)
- | DTask _ => count) 0
+ | DTask _ => count
+ | DPolicy _ => count) 0
end
diff --git a/src/corify.sml b/src/corify.sml
index 6931600e..88473455 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1080,6 +1080,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
| L.DTask (e1, e2) =>
([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st)
+ | L.DPolicy e1 =>
+ ([(L'.DPolicy (corifyExp st e1), loc)], st)
+
and corifyStr mods ((str, _), st) =
case str of
L.StrConst ds =>
@@ -1137,7 +1140,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
| L.DDatabase _ => n
| L.DCookie (_, _, n', _) => Int.max (n, n')
| L.DStyle (_, _, n') => Int.max (n, n')
- | L.DTask _ => n)
+ | L.DTask _ => n
+ | L.DPolicy _ => n)
0 ds
and maxNameStr (str, _) =
diff --git a/src/css.sml b/src/css.sml
index 7189904f..3df35ed1 100644
--- a/src/css.sml
+++ b/src/css.sml
@@ -287,6 +287,7 @@ fun summarize file =
| DCookie _ => st
| DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
| DTask _ => st
+ | DPolicy _ => st
end
val (globals, classes) = foldl decl (IM.empty, IM.empty) file
diff --git a/src/elab.sml b/src/elab.sml
index a0f9a4e8..e040a059 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -171,6 +171,7 @@ datatype decl' =
| DCookie of int * string * int * con
| DStyle of int * string * int
| DTask of exp * exp
+ | DPolicy of exp
and str' =
StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 5092c6fb..dd050c9e 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1623,5 +1623,6 @@ fun declBinds env (d, loc) =
pushENamedAs env x n t
end
| DTask _ => env
+ | DPolicy _ => env
end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 62b5262f..86448659 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -806,6 +806,9 @@ fun p_decl env (dAll as (d, _) : decl) =
string "=",
space,
p_exp env e2]
+ | DPolicy e1 => box [string "policy",
+ space,
+ p_exp env e1]
and p_str env (str, _) =
case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index d0e140c5..8345e3f3 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -854,7 +854,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
c), loc)))
| DStyle (tn, x, n) =>
bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
- | DTask _ => ctx,
+ | DTask _ => ctx
+ | DPolicy _ => ctx,
mfd ctx d)) ctx ds,
fn ds' => (StrConst ds', loc))
| StrVar _ => S.return2 strAll
@@ -985,6 +986,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
S.map2 (mfe ctx e2,
fn e2' =>
(DTask (e1', e2'), loc)))
+ | DPolicy e1 =>
+ S.map2 (mfe ctx e1,
+ fn e1' =>
+ (DPolicy e1', loc))
and mfvi ctx (x, n, c, e) =
S.bind2 (mfc ctx c,
@@ -1128,6 +1133,7 @@ and maxNameDecl (d, _) =
| DCookie (n1, _, n2, _) => Int.max (n1, n2)
| DStyle (n1, _, n2) => Int.max (n1, n2)
| DTask _ => 0
+ | DPolicy _ => 0
and maxNameStr (str, _) =
case str of
StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 1651f344..07818a57 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2595,6 +2595,7 @@ and sgiOfDecl (d, loc) =
| L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
| L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
| L'.DTask _ => []
+ | L'.DPolicy _ => []
and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3729,6 +3730,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
checkCon env e2' t2 t2';
([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs))
end
+ | L.DPolicy e1 =>
+ let
+ val (e1', t1, gs1) = elabExp (env, denv) e1
+
+ val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc)
+ in
+ checkCon env e1' t1 t1';
+ ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs))
+ end
(*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index c697a274..8054d829 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
"datatype" "type" "open" "include"
urweb-module-head-syms
"con" "map" "where" "extern" "constraint" "constraints"
- "table" "sequence" "class" "cookie" "task")
+ "table" "sequence" "class" "cookie" "task" "policy")
"Symbols starting an sexp.")
;; (defconst urweb-not-arg-start-re
@@ -135,7 +135,7 @@ notion of \"the end of an outline\".")
(("case" "datatype" "if" "then" "else"
"let" "open" "sig" "struct" "type" "val"
"con" "constraint" "table" "sequence" "class" "cookie"
- "task")))))
+ "task" "policy")))))
(defconst urweb-starters-indent-after
(urweb-syms-re "let" "in" "struct" "sig")
@@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol."
'("datatype" "fun"
"open" "type" "val" "and"
"con" "constraint" "table" "sequence" "class" "cookie"
- "task"))
+ "task" "policy"))
"The starters of new expressions.")
(defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 107ea3bc..c9fe5f19 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
"datatype" "else" "end" "extern" "fn" "map"
"fun" "functor" "if" "include"
"of" "open" "let" "in"
- "rec" "sequence" "sig" "signature" "cookie" "style" "task"
+ "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
"struct" "structure" "table" "view" "then" "type" "val" "where"
"with"
@@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'."
("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
(1 font-lock-keyword-face)
(3 (amAttribute font-lock-type-def-face)))
- ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+ ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
(1 font-lock-keyword-face)
(3 (amAttribute font-lock-variable-name-face)))
("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/expl.sml b/src/expl.sml
index 17797626..1212383f 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -148,6 +148,7 @@ datatype decl' =
| DCookie of int * string * int * con
| DStyle of int * string * int
| DTask of exp * exp
+ | DPolicy of exp
and str' =
StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 0bf7323f..583e4881 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -344,6 +344,7 @@ fun declBinds env (d, loc) =
pushENamed env x n t
end
| DTask _ => env
+ | DPolicy _ => env
fun sgiBinds env (sgi, loc) =
case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 5284eecb..15838729 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -720,6 +720,9 @@ fun p_decl env (dAll as (d, _) : decl) =
string "=",
space,
p_exp env e2]
+ | DPolicy e1 => box [string "policy",
+ space,
+ p_exp env e1]
and p_str env (str, _) =
case str of
diff --git a/src/explify.sml b/src/explify.sml
index aff91a34..0013906f 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -196,6 +196,7 @@ fun explifyDecl (d, loc : EM.span) =
| L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
| L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
| L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
+ | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
and explifyStr (str, loc) =
case str of
diff --git a/src/mono.sml b/src/mono.sml
index 898feb9b..33ab5bd4 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -123,6 +123,8 @@ datatype exp' =
withtype exp = exp' located
+datatype policy = PolQuery of exp
+
datatype decl' =
DDatatype of (string * int * (string * int * typ option) list) list
| DVal of string * int * typ * exp * string
@@ -141,6 +143,8 @@ datatype decl' =
| DTask of exp * exp
+ | DPolicy of policy
+
withtype decl = decl' located
type file = decl list
diff --git a/src/mono_env.sml b/src/mono_env.sml
index c2e6cf02..87f96488 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -130,6 +130,7 @@ fun declBinds env (d, loc) =
| DCookie _ => env
| DStyle _ => env
| DTask _ => env
+ | DPolicy _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index d1f5fc27..50c4717a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -412,6 +412,12 @@ fun p_datatype env (x, n, cons) =
cons]
end
+fun p_policy env pol =
+ case pol of
+ PolQuery e => box [string "query",
+ space,
+ p_exp env e]
+
fun p_decl env (dAll as (d, _) : decl) =
case d of
DDatatype x => box [string "datatype",
@@ -506,6 +512,9 @@ fun p_decl env (dAll as (d, _) : decl) =
string "=",
space,
p_exp env e2]
+ | DPolicy p => box [string "policy",
+ space,
+ p_policy env p]
fun p_file env file =
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index e53b6930..358b31d2 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -58,6 +58,13 @@ fun shake file =
| ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
(page_cs, IS.addList (page_es, [n1, n2]))
| ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
+ | ((DPolicy pol, _), st) =>
+ let
+ val e1 = case pol of
+ PolQuery e1 => e1
+ in
+ usedVars st e1
+ end
| (_, st) => st) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
@@ -74,7 +81,8 @@ fun shake file =
| ((DJavaScript _, _), acc) => acc
| ((DCookie _, _), acc) => acc
| ((DStyle _, _), acc) => acc
- | ((DTask _, _), acc) => acc)
+ | ((DTask _, _), acc) => acc
+ | ((DPolicy _, _), acc) => acc)
(IM.empty, IM.empty) file
fun typ (c, s) =
@@ -141,7 +149,8 @@ fun shake file =
| (DJavaScript _, _) => true
| (DCookie _, _) => true
| (DStyle _, _) => true
- | (DTask _, _) => true) file
+ | (DTask _, _) => true
+ | (DPolicy _, _) => true) file
end
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index a75843c4..094f216b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -534,6 +534,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
S.map2 (mfe ctx e2,
fn e2' =>
(DTask (e1', e2'), loc)))
+ | DPolicy pol =>
+ S.map2 (mfpol ctx pol,
+ fn p' =>
+ (DPolicy p', loc))
+
+ and mfpol ctx pol =
+ case pol of
+ PolQuery e =>
+ S.map2 (mfe ctx e,
+ PolQuery)
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mft t,
@@ -621,6 +631,7 @@ fun mapfoldB (all as {bind, ...}) =
| DCookie _ => ctx
| DStyle _ => ctx
| DTask _ => ctx
+ | DPolicy _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -674,7 +685,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DJavaScript _ => count
| DCookie _ => count
| DStyle _ => count
- | DTask _ => count) 0
+ | DTask _ => count
+ | DPolicy _ => count) 0
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 25ea87f5..6f229766 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3738,6 +3738,20 @@ fun monoDecl (env, fm) (all as (d, loc)) =
fm,
[(L'.DTask (e1, e2), loc)])
end
+ | L.DPolicy e =>
+ let
+ val (e, make) =
+ case #1 e of
+ L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "query_policy"), _), _), _), _), _), e) =>
+ (e, L'.PolQuery)
+ | _ => (poly (); (e, L'.PolQuery))
+
+ val (e, fm) = monoExp (env, St.empty, fm) e
+ in
+ SOME (env,
+ fm,
+ [(L'.DPolicy (make e), loc)])
+ end
end
datatype expungable = Client | Channel
diff --git a/src/reduce.sml b/src/reduce.sml
index b7ad567a..cefe1955 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -746,6 +746,15 @@ fun reduce file =
namedC,
namedE))
end
+ | DPolicy e1 =>
+ let
+ val e1 = exp (namedC, namedE) [] e1
+ in
+ ((DPolicy e1, loc),
+ (polyC,
+ namedC,
+ namedE))
+ end
val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index b040a1ec..4c5ab52e 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -252,6 +252,7 @@ fun reduce file =
| DCookie _ => d
| DStyle _ => d
| DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
+ | DPolicy e1 => (DPolicy (exp [] e1), loc)
in
map doDecl file
end
diff --git a/src/shake.sml b/src/shake.sml
index 686a043c..f679c6e8 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -90,6 +90,11 @@ fun shake file =
st
else
usedVars (usedVars st e1) e2
+ | ((DPolicy e1, _), st) =>
+ if !sliceDb then
+ st
+ else
+ usedVars st e1
| (_, acc) => acc) (IS.empty, IS.empty) file
val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -116,7 +121,8 @@ fun shake file =
(cdef, IM.insert (edef, n, ([], c, dummye)))
| ((DStyle (_, n, _), _), (cdef, edef)) =>
(cdef, IM.insert (edef, n, ([], dummyt, dummye)))
- | ((DTask _, _), acc) => acc)
+ | ((DTask _, _), acc) => acc
+ | ((DPolicy _, _), acc) => acc)
(IM.empty, IM.empty) file
fun kind (_, s) = s
@@ -203,7 +209,8 @@ fun shake file =
| (DDatabase _, _) => not (!sliceDb)
| (DCookie _, _) => not (!sliceDb)
| (DStyle _, _) => not (!sliceDb)
- | (DTask _, _) => not (!sliceDb)) file
+ | (DTask _, _) => not (!sliceDb)
+ | (DPolicy _, _) => not (!sliceDb)) file
end
end
diff --git a/src/source.sml b/src/source.sml
index dc867026..9768cfc0 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -168,6 +168,7 @@ datatype decl' =
| DCookie of string * con
| DStyle of string
| DTask of exp * exp
+ | DPolicy of exp
and str' =
StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index e3b4fe94..590d15d5 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -669,6 +669,9 @@ fun p_decl ((d, _) : decl) =
string "=",
space,
p_exp e2]
+ | DPolicy e1 => box [string "policy",
+ space,
+ p_exp e1]
and p_str (str, _) =
case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index e030bbc6..77589bfb 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -423,6 +423,7 @@ fun unnest file =
| DCookie _ => default ()
| DStyle _ => default ()
| DTask _ => explore ()
+ | DPolicy _ => explore ()
end
and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index ad3de6b2..3df9554f 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -202,7 +202,7 @@ fun patType loc (p : pat) =
| LET | IN
| STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
| INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
- | COOKIE | STYLE | TASK
+ | COOKIE | STYLE | TASK | POLICY
| CASE | IF | THEN | ELSE | ANDALSO | ORELSE
| XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -481,6 +481,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
| COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
| STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
| TASK eapps EQ eexp ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
+ | POLICY eexp ([(DPolicy eexp, s (POLICYleft, eexpright))])
dtype : SYMBOL dargs EQ barOpt dcons (SYMBOL, dargs, dcons)
diff --git a/src/urweb.lex b/src/urweb.lex
index 45f555dd..8930c463 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -416,6 +416,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<INITIAL> "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
<INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
<INITIAL> "task" => (Tokens.TASK (pos yypos, pos yypos + size yytext));
+<INITIAL> "policy" => (Tokens.POLICY (pos yypos, pos yypos + size yytext));
<INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
<INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/policy.ur b/tests/policy.ur
new file mode 100644
index 00000000..db87b582
--- /dev/null
+++ b/tests/policy.ur
@@ -0,0 +1,3 @@
+table fruit : { Id : int, Nam : string, Weight : float }
+
+policy query_policy (SELECT * FROM fruit)
diff --git a/tests/policy.urp b/tests/policy.urp
new file mode 100644
index 00000000..b26ebd4a
--- /dev/null
+++ b/tests/policy.urp
@@ -0,0 +1 @@
+policy
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-23 08:24:52 +0000