summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG2
-rw-r--r--include/urweb.h3
-rw-r--r--lib/ur/basis.urs2
-rw-r--r--src/c/urweb.c45
-rw-r--r--src/cjr_print.sml34
-rw-r--r--src/settings.sig2
-rw-r--r--src/settings.sml3
-rw-r--r--tests/url.ur9
-rw-r--r--tests/url.urp3
9 files changed, 89 insertions, 14 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 49a009b6..8df1b3b8 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -4,7 +4,7 @@ Next
- Reimplement constructor class resolution to be more general and Prolog-like
- SQL table constraints
-- URLs, with configurable gatekeeper function Basis.bless
+- URLs
- Client-side error handling callbacks
- CSS
- Signing cookie values cryptographically to thwart cross site request forgery
diff --git a/include/urweb.h b/include/urweb.h
index 27ab799f..d2fa30da 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -169,6 +169,9 @@ uw_Basis_client uw_Basis_self(uw_context, uw_unit);
uw_Basis_string uw_Basis_bless(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_blessMime(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_checkUrl(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_checkMime(uw_context, uw_Basis_string);
+
uw_Basis_string uw_unnull(uw_Basis_string);
uw_Basis_string uw_Basis_makeSigString(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_sigString(uw_context, uw_unit);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index e5175a08..25ad2786 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -514,6 +514,7 @@ con tr = [Body, Tr]
type url
val bless : string -> url
+val checkUrl : string -> option url
val dyn : use ::: {Type} -> bind ::: {Type} -> unit
-> tag [Signal = signal (xml body use bind)] body [] use bind
@@ -600,6 +601,7 @@ val upload : formTag file [] [Value = string, Size = int]
type mimeType
val blessMime : string -> mimeType
+val checkMime : string -> option mimeType
val returnBlob : t ::: Type -> blob -> mimeType -> transaction t
val blobSize : blob -> int
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cc02b3d1..1f256681 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -2437,18 +2437,49 @@ failure_kind uw_initialize(uw_context ctx) {
return r;
}
+extern int uw_check_url(const char *);
+extern int uw_check_mime(const char *);
+
uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
- return s;
+ if (uw_check_url(s))
+ return s;
+ else
+ uw_error(ctx, FATAL, "Disallowed URL %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) {
+ if (uw_check_url(s))
+ return s;
+ else
+ return NULL;
+}
+
+int mime_format(const char *s) {
+ for (; *s; ++s)
+ if (!isalnum(*s) && *s != '/' && *s != '-' && *s != '.')
+ return 0;
+
+ return 1;
}
uw_Basis_string uw_Basis_blessMime(uw_context ctx, uw_Basis_string s) {
- char *s2;
+ if (!mime_format(s))
+ uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
- for (s2 = s; *s2; ++s2)
- if (!isalnum(*s2) && *s2 != '/' && *s2 != '-' && *s2 != '.')
- uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character %c\n", s, *s2);
-
- return s;
+ if (uw_check_mime(s))
+ return s;
+ else
+ uw_error(ctx, FATAL, "Disallowed MIME type %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkMime(uw_context ctx, uw_Basis_string s) {
+ if (!mime_format(s))
+ return NULL;
+
+ if (uw_check_mime(s))
+ return s;
+ else
+ return NULL;
}
uw_Basis_string uw_unnull(uw_Basis_string s) {
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 3a124ff4..cb92588d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3176,6 +3176,34 @@ fun p_file env (ds, ps) =
acc,
string "))"]))
NONE cookies
+
+ fun makeChecker (name, rules : Settings.rule list) =
+ box [string "int ",
+ string name,
+ string "(const char *s) {",
+ newline,
+ box [p_list_sep (box [])
+ (fn rule =>
+ box [string "if (!str",
+ case #kind rule of
+ Settings.Exact => box [string "cmp(s, \"",
+ string (String.toString (#pattern rule)),
+ string "\"))"]
+ | Settings.Prefix => box [string "ncmp(s, \"",
+ string (String.toString (#pattern rule)),
+ string "\", ",
+ string (Int.toString (size (#pattern rule))),
+ string "))"],
+ string " return ",
+ string (case #action rule of
+ Settings.Allow => "1"
+ | Settings.Deny => "0"),
+ string ";",
+ newline]) rules,
+ string "return 0;",
+ newline],
+ string "}",
+ newline]
in
box [string "#include <stdio.h>",
newline,
@@ -3218,6 +3246,12 @@ fun p_file env (ds, ps) =
string "}",
newline,
newline,
+
+ makeChecker ("uw_check_url", Settings.getUrlRules ()),
+ newline,
+
+ makeChecker ("uw_check_mime", Settings.getMimeRules ()),
+ newline,
string "extern void uw_sign(const char *in, char *out);",
newline,
diff --git a/src/settings.sig b/src/settings.sig
index f750c14a..dd812ac4 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -78,9 +78,11 @@ signature SETTINGS = sig
(* Validating URLs and MIME types *)
val setUrlRules : rule list -> unit
+ val getUrlRules : unit -> rule list
val checkUrl : string -> bool
val setMimeRules : rule list -> unit
+ val getMimeRules : unit -> rule list
val checkMime : string -> bool
end
diff --git a/src/settings.sml b/src/settings.sml
index e7020615..24971eff 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -197,6 +197,9 @@ val mime = ref ([] : rule list)
fun setUrlRules ls = url := ls
fun setMimeRules ls = mime := ls
+fun getUrlRules () = !url
+fun getMimeRules () = !mime
+
fun check f rules s =
let
fun chk (ls : rule list) =
diff --git a/tests/url.ur b/tests/url.ur
index c45681e0..ea236502 100644
--- a/tests/url.ur
+++ b/tests/url.ur
@@ -1,12 +1,11 @@
-val url = "http://www.yahoo.com/"
-
fun readersChoice r = return <xml><body>
- <a href={bless r.Url}>Your pick, boss</a>
+ {case checkUrl r.Url of
+ None => <xml>I can't do that, Dave.</xml>
+ | Some url => <xml><a href={url}>Your pick, boss</a></xml>}
</body></xml>
fun main () : transaction page = return <xml><body>
- <a href="http://www.google.com/">Google!</a>
- <a href={bless url}>Yahoo!</a><br/>
+ <a href="http://en.wikipedia.org/wiki/Wikipedia:About">Learn</a>
<br/>
<form><textbox{#Url}/> <submit action={readersChoice}/></form>
diff --git a/tests/url.urp b/tests/url.urp
index ab5ec1b7..aaa84900 100644
--- a/tests/url.urp
+++ b/tests/url.urp
@@ -1,4 +1,5 @@
debug
-allow url http://*
+deny url http://en.wikipedia.org/wiki/Perl
+allow url http://en.wikipedia.org/*
url
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-13 06:58:15 +0000