summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml45
-rw-r--r--src/demo.sml4
-rw-r--r--src/mono_opt.sig3
-rw-r--r--src/mono_opt.sml11
-rw-r--r--src/settings.sig7
-rw-r--r--src/settings.sml34
7 files changed, 95 insertions, 13 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index 048ca39f..276cb4f2 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -47,7 +47,9 @@ signature COMPILER = sig
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
jsFuncs : (Settings.ffi * string) list,
- rewrites : Settings.rewrite list
+ rewrites : Settings.rewrite list,
+ filterUrl : Settings.rule list,
+ filterMime : Settings.rule list
}
val compile : string -> unit
val compileC : {cname : string, oname : string, ename : string, libs : string,
diff --git a/src/compiler.sml b/src/compiler.sml
index 5a0a148a..66e8eda2 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -51,7 +51,9 @@ type job = {
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
jsFuncs : (Settings.ffi * string) list,
- rewrites : Settings.rewrite list
+ rewrites : Settings.rewrite list,
+ filterUrl : Settings.rule list,
+ filterMime : Settings.rule list
}
type ('src, 'dst) phase = {
@@ -314,6 +316,8 @@ fun parseUrp' filename =
val serverOnly = ref []
val jsFuncs = ref []
val rewrites = ref []
+ val url = ref []
+ val mime = ref []
val libs = ref []
fun finish sources =
@@ -337,6 +341,8 @@ fun parseUrp' filename =
serverOnly = rev (!serverOnly),
jsFuncs = rev (!jsFuncs),
rewrites = rev (!rewrites),
+ filterUrl = rev (!url),
+ filterMime = rev (!mime),
sources = sources
}
@@ -372,6 +378,8 @@ fun parseUrp' filename =
serverOnly = #serverOnly old @ #serverOnly new,
jsFuncs = #jsFuncs old @ #jsFuncs new,
rewrites = #rewrites old @ #rewrites new,
+ filterUrl = #filterUrl old @ #filterUrl new,
+ filterMime = #filterMime old @ #filterMime new,
sources = #sources old @ #sources new
}
in
@@ -397,6 +405,19 @@ fun parseUrp' filename =
else
(Settings.Exact, s)
+ fun parseFkind s =
+ case s of
+ "url" => url
+ | "mime" => mime
+ | _ => (ErrorMsg.error "Bad filter kind";
+ url)
+
+ fun parsePattern s =
+ if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
+ (Settings.Prefix, String.substring (s, 0, size s - 1))
+ else
+ (Settings.Exact, s)
+
fun read () =
case TextIO.inputLine inf of
NONE => finish []
@@ -475,6 +496,26 @@ fun parseUrp' filename =
| [pkind, from] => doit (pkind, from, "")
| _ => ErrorMsg.error "Bad 'rewrite' syntax"
end
+ | "allow" =>
+ (case String.tokens Char.isSpace arg of
+ [fkind, pattern] =>
+ let
+ val fkind = parseFkind fkind
+ val (kind, pattern) = parsePattern pattern
+ in
+ fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
+ end
+ | _ => ErrorMsg.error "Bad 'allow' syntax")
+ | "deny" =>
+ (case String.tokens Char.isSpace arg of
+ [fkind, pattern] =>
+ let
+ val fkind = parseFkind fkind
+ val (kind, pattern) = parsePattern pattern
+ in
+ fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
+ end
+ | _ => ErrorMsg.error "Bad 'deny' syntax")
| "library" => libs := relify arg :: !libs
| _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
read ()
@@ -493,6 +534,8 @@ fun parseUrp' filename =
Settings.setServerOnly (#serverOnly job);
Settings.setJsFuncs (#jsFuncs job);
Settings.setRewriteRules (#rewrites job);
+ Settings.setUrlRules (#filterUrl job);
+ Settings.setMimeRules (#filterMime job);
job
end
diff --git a/src/demo.sml b/src/demo.sml
index c08ce0fe..dc4715d7 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -104,7 +104,9 @@ fun make {prefix, dirname, guided} =
clientOnly = [],
serverOnly = [],
jsFuncs = [],
- rewrites = []
+ rewrites = [],
+ filterUrl = #filterUrl combined @ #filterUrl urp,
+ filterMime = #filterMime combined @ #filterMime urp
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/mono_opt.sig b/src/mono_opt.sig
index 905dc53b..d0268087 100644
--- a/src/mono_opt.sig
+++ b/src/mono_opt.sig
@@ -30,7 +30,4 @@ signature MONO_OPT = sig
val optimize : Mono.file -> Mono.file
val optExp : Mono.exp -> Mono.exp
- val bless : (string -> bool) ref
- val blessMime : (string -> bool) ref
-
end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 41724eb0..fefe24e1 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -30,9 +30,6 @@ structure MonoOpt :> MONO_OPT = struct
open Mono
structure U = MonoUtil
-val bless = ref (fn _ : string => true)
-val blessMime = ref (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"-" orelse ch = #"/" orelse ch = #"."))
-
fun typ t = t
fun decl d = d
@@ -382,16 +379,16 @@ fun exp e =
| EJavaScript (_, _, SOME (e, _)) => e
| EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
- (if !bless s then
+ (if Settings.checkUrl s then
()
else
- ErrorMsg.errorAt loc "Invalid URL passed to 'bless'";
+ ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
se)
| EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
- (if !blessMime s then
+ (if Settings.checkMime s then
()
else
- ErrorMsg.errorAt loc "Invalid string passed to 'blessMime'";
+ ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
se)
| EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) =>
diff --git a/src/settings.sig b/src/settings.sig
index e5dd20d8..f750c14a 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -76,4 +76,11 @@ signature SETTINGS = sig
val setRewriteRules : rewrite list -> unit
val rewrite : path_kind -> string -> string
+ (* Validating URLs and MIME types *)
+ val setUrlRules : rule list -> unit
+ val checkUrl : string -> bool
+
+ val setMimeRules : rule list -> unit
+ val checkMime : string -> bool
+
end
diff --git a/src/settings.sml b/src/settings.sml
index 5e97f44b..e7020615 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -191,4 +191,38 @@ fun rewrite pk s =
rew (!rewrites)
end
+val url = ref ([] : rule list)
+val mime = ref ([] : rule list)
+
+fun setUrlRules ls = url := ls
+fun setMimeRules ls = mime := ls
+
+fun check f rules s =
+ let
+ fun chk (ls : rule list) =
+ case ls of
+ [] => false
+ | rule :: ls =>
+ let
+ val matches =
+ case #kind rule of
+ Exact => #pattern rule = s
+ | Prefix => String.isPrefix (#pattern rule) s
+ in
+ if matches then
+ case #action rule of
+ Allow => true
+ | Deny => false
+ else
+ chk ls
+ end
+ in
+ f s andalso chk (!rules)
+ end
+
+val checkUrl = check (fn _ => true) url
+val checkMime = check
+ (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"."))
+ mime
+
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 21:24:51 +0000