summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG13
-rw-r--r--Makefile.am15
-rw-r--r--configure.ac2
-rw-r--r--demo/listEdit.ur7
-rw-r--r--doc/manual.tex11
-rw-r--r--lib/js/urweb.js21
-rw-r--r--lib/ur/basis.urs20
-rw-r--r--lib/ur/json.ur387
-rw-r--r--lib/ur/json.urs31
-rw-r--r--lib/ur/top.ur7
-rw-r--r--lib/ur/top.urs4
-rw-r--r--src/c/Makefile.am7
-rw-r--r--src/c/http.c41
-rw-r--r--src/cjr_print.sml63
-rw-r--r--src/compiler.sml11
-rw-r--r--src/demo.sml4
-rw-r--r--src/elab_err.sml2
-rw-r--r--src/elisp/urweb-mode.el2
-rw-r--r--src/fileio.sig9
-rw-r--r--src/fileio.sml39
-rw-r--r--src/globals.sig7
-rw-r--r--src/globals.sml7
-rw-r--r--src/jscomp.sml2
-rw-r--r--src/main.mlton.sml5
-rw-r--r--src/settings.sig1
-rw-r--r--src/settings.sml13
-rw-r--r--src/sha1.sig31
-rw-r--r--src/sha1.sml264
-rw-r--r--src/sources9
-rw-r--r--src/tag.sml54
-rw-r--r--src/tutorial.sml4
-rw-r--r--tests/crud1.html4
-rw-r--r--tests/hello.html4
-rw-r--r--tests/jsonTest.ur6
-rw-r--r--tests/jsonTest.urp7
35 files changed, 1011 insertions, 103 deletions
diff --git a/CHANGELOG b/CHANGELOG
index f5c92708..20d79590 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,17 @@
========
+20161022
+========
+
+- Add Json module to standard library
+- Make HTML5 the default and add 'xhtml' .urp directive
+- Remove 'Value' attributes for AJAX-y UI widgets, because they should use 'Source' instead
+- Change compiler to support reproducible builds, via replacement of timestamp
+ calculation with different methods or use of content hashes
+- IPv6 support in HTTP-server binaries, via '-A' command-line option
+- New Top function: mapUX_rev
+- Bug fixes and documentation improvements
+
+========
20160805
========
diff --git a/Makefile.am b/Makefile.am
index 9ab31acd..83a08171 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -116,9 +116,22 @@ test:
bin/urweb -boot -noEmacs -dbms sqlite -db $(TESTDB) -demo /Demo demo
rm -f $(TESTDB)
sqlite3 $(TESTDB) < demo/demo.sql
- demo/demo.exe & echo $$! > $(TESTPID)
+ demo/demo.exe -a 127.0.0.1 & echo $$! > $(TESTPID)
sleep 1
(curl -s 'http://localhost:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false)
(curl -s 'http://localhost:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false)
kill `cat $(TESTPID)`
+ if (ifconfig lo | grep -q inet6); \
+ then \
+ echo "Running IPv6 tests."; \
+ rm -f $(TESTDB); \
+ sqlite3 $(TESTDB) < demo/demo.sql; \
+ demo/demo.exe -A ::1 & echo $$! > $(TESTPID); \
+ sleep 1; \
+ (curl -g -6 -s 'http://[::1]:8080/Demo/Hello/main' | diff tests/hello.html -) || (kill `cat $(TESTPID)`; echo "Test 'Hello' failed"; /bin/false); \
+ (curl -g -6 -s 'http://[::1]:8080/Demo/Crud1/create?A=1&B=2&C=3&D=4' | diff tests/crud1.html -) || (kill `cat $(TESTPID)`; echo "Test 'Crud1' failed"; /bin/false); \
+ kill `cat $(TESTPID)`; \
+ else \
+ echo "Skipped IPv6 tests."; \
+ fi
echo Tests succeeded.
diff --git a/configure.ac b/configure.ac
index 196d597c..fdf010b4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,4 +1,4 @@
-AC_INIT([urweb], [20160805])
+AC_INIT([urweb], [20161022])
WORKING_VERSION=0
AC_USE_SYSTEM_EXTENSIONS
diff --git a/demo/listEdit.ur b/demo/listEdit.ur
index 5b45d9a2..e75f2d04 100644
--- a/demo/listEdit.ur
+++ b/demo/listEdit.ur
@@ -37,12 +37,7 @@ fun main () =
val cons = Cons {Data = data, NewData = ndata, Tail = tail'}
in
set tail cons;
- set tailP tail';
-
- head' <- get head;
- case head' of
- Nil => set head cons
- | _ => return ()
+ set tailP tail'
end
in
return <xml><body>
diff --git a/doc/manual.tex b/doc/manual.tex
index 76f69330..b65809d0 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -151,7 +151,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func
\item \texttt{exe FILENAME} sets the filename to which to write the output executable. The default for file \texttt{P.urp} is \texttt{P.exe}.
\item \texttt{file URI FILENAME} asks for the application executable to respond to requests for \texttt{URI} by serving a snapshot of the contents of \texttt{FILENAME} as of compile time. That is, the file contents are baked into the executable. System file \texttt{/etc/mime.types} is consulted (again, at compile time) to figure out the right MIME type to suggest in the HTTP response.
\item \texttt{ffi FILENAME} reads the file \texttt{FILENAME.urs} to determine the interface to a new FFI module. The name of the module is calculated from \texttt{FILENAME} in the same way as for normal source files. See the files \texttt{include/urweb/urweb\_cpp.h} and \texttt{src/c/urweb.c} for examples of C headers and implementations for FFI modules. In general, every type or value \texttt{Module.ident} becomes \texttt{uw\_Module\_ident} in C.
-\item \texttt{html5} activates work-in-progress support for generating HTML5 instead of XHTML. For now, this option only affects the first few tokens on any page, which are always the same.
+\item \texttt{html5} asks to generate HTML5 code, which primarily affects the first few lines of the output documents, like the \texttt{DOCTYPE}. This option is on by default.
\item \texttt{include FILENAME} adds \texttt{FILENAME} to the list of files to be \texttt{\#include}d in C sources. This is most useful for interfacing with new FFI modules.
\item \texttt{jsFile FILENAME} asks to serve the contents of a file as JavaScript. All such content is concatenated into a single file, included via a \texttt{<script>} tag on every page that needs client-side scripting.
\item \texttt{jsFunc Module.ident=name} gives the JavaScript name of an FFI value.
@@ -192,6 +192,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func
\item \texttt{sql FILENAME} sets where to write an SQL file with the commands to create the expected database schema. The default is not to create such a file.
\item \texttt{timeFormat FMT} accepts a time format string, as processed by the POSIX C function \texttt{strftime()}. This controls the default rendering of $\mt{time}$ values, via the $\mt{show}$ instance for $\mt{time}$.
\item \texttt{timeout N} sets to \texttt{N} seconds the amount of time that the generated server will wait after the last contact from a client before determining that that client has exited the application. Clients that remain active will take the timeout setting into account in determining how often to ping the server, so it only makes sense to set a high timeout to cope with browser and network delays and failures. Higher timeouts can lead to more unnecessary client information taking up memory on the server. The timeout goes unused by any page that doesn't involve the \texttt{recv} function, since the server only needs to store per-client information for clients that receive asynchronous messages.
+\item \texttt{xhtml} asks to generate XHTML code, which primarily affects the first few lines of the output documents, like the \texttt{DOCTYPE}.
\end{itemize}
@@ -2095,6 +2096,12 @@ Configure the policy for meta names with the \texttt{allow} and \texttt{deny} \t
Ur/Web supports running code on web browsers, via automatic compilation to JavaScript.
+The concurrency model is \emph{cooperative multithreading}. Like with, say, POSIX threads, which uses the \emph{preemptive multithreading} model, there may be multiple threads of control active at a time. However, unlike with preemptive multithreading, the currently running thread gets to run interrupted until a well-defined \emph{context-switch} point. Specifically, four functions defined below are the context-switch points. They are $\mt{sleep}$, $\mt{rpc}$, $\mt{tryRpc}$, and $\mt{recv}$. (We explain their purposes as we come to them below.) Additional functions added via the foreign function interface might also have context-switching behavior. In any case, it is guaranteed that a running thread ``owns the processor'' until it calls a context-switching function, at which time we may switch to running a different thread instead.
+
+This concurrency paradigm has many nice properties. For instance, there is almost never any need for locking or other synchronization between threads.
+
+Readers used to the standard JavaScript model may recognize this style as the natural one that we obtain by imposing a thread-based perspective on top of the usual JavaScript callback-based API. Indeed, every context-switching Ur/Web function is implemented with an underlying JavaScript call that asks for some callback to be triggered when an event happens.
+
\subsubsection{The Basics}
All of the functions in this subsection are client-side only.
@@ -2245,7 +2252,7 @@ The $\mt{channel}$ and $\mt{send}$ operations may only be executed on the server
Clients and channels live only as long as the web browser page views that they are associated with. When a user surfs away, his client and its channels will be garbage-collected, after that user is not heard from for the timeout period. Garbage collection deletes any database row that contains a client or channel directly. Any reference to one of these types inside an $\mt{option}$ is set to $\mt{None}$ instead. Both kinds of handling have the flavor of weak pointers, and that is a useful way to think about clients and channels in the database.
-\emph{Note}: Currently, there are known concurrency issues with multi-threaded applications that employ message-passing on top of database engines that don't support true serializable transactions. Postgres 9.1 is the only supported engine that does this properly.
+\emph{Note}: Currently, there are known concurrency issues with multi-threaded applications that employ message-passing on top of database engines that don't support true serializable transactions. Postgres (versions 9.1 and up) is the only supported engine that does this properly.
\section{Ur/Web Syntax Extensions}
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 68e7979d..222a8322 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -731,6 +731,8 @@ function flattenLocal(s) {
// Dynamic tree management
function populate(node) {
+ if (node.dead) return;
+
var s = node.signal;
var oldSources = node.sources;
try {
@@ -760,8 +762,7 @@ function sv(s, v) {
s.data = v;
for (var ls = s.dyns; ls; ls = ls.next)
- if (!ls.dead)
- populate(ls.data);
+ populate(ls.data);
}
}
function sg(s) {
@@ -1099,12 +1100,18 @@ function active(s) {
function input(x, s, recreate, type, name) {
if (name) x.name = name;
if (type) x.type = type;
- x.dead = false;
- x.signal = ss(s);
- x.sources = null;
- x.recreate = recreate(x);
addNode(x);
- populate(x);
+
+ var sc = document.createElement("script");
+ sc.dead = false;
+ sc.signal = ss(s);
+ sc.sources = null;
+ sc.recreate = recreate(x);
+
+ if (x.parentNode)
+ x.parentNode.insertBefore(sc, x);
+
+ populate(sc);
return x;
}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 1163daed..8b0d4faa 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -1075,23 +1075,23 @@ val curl : ctext
val ctel : ctext
val ccolor : ctext
-val cnumber : cformTag ([Source = source float, Value = float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val crange : cformTag ([Source = source float, Value = float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cdate : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cdatetime : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cdatetime_local : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cmonth : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cweek : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val ctime : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cnumber : cformTag ([Source = source float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val crange : cformTag ([Source = source float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cmonth : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cweek : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val ctime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val button : cformTag ([Value = string] ++ boxAttrs) []
-val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val ccheckbox : cformTag ([Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) [Cselect]
val coption : unit -> tag [Value = string, Selected = bool] [Cselect, Body] [] [] []
-val ctextarea : cformTag ([Value = string, Rows = int, Cols = int, Source = source string, Onchange = transaction unit,
+val ctextarea : cformTag ([Rows = int, Cols = int, Source = source string, Onchange = transaction unit,
Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) []
(*** Tables *)
diff --git a/lib/ur/json.ur b/lib/ur/json.ur
new file mode 100644
index 00000000..9288a6dd
--- /dev/null
+++ b/lib/ur/json.ur
@@ -0,0 +1,387 @@
+con json a = {ToJson : a -> string,
+ FromJson : string -> a * string}
+
+fun mkJson [a] (x : {ToJson : a -> string,
+ FromJson : string -> a * string}) = x
+
+fun skipSpaces s =
+ let
+ val len = String.length s
+
+ fun skip i =
+ if i >= len then
+ ""
+ else
+ let
+ val ch = String.sub s i
+ in
+ if Char.isSpace ch then
+ skip (i+1)
+ else
+ String.substring s {Start = i, Len = len-i}
+ end
+ in
+ skip 0
+ end
+
+fun toJson [a] (j : json a) : a -> string = j.ToJson
+fun fromJson' [a] (j : json a) : string -> a * string = j.FromJson
+
+fun fromJson [a] (j : json a) (s : string) : a =
+ let
+ val (v, s') = j.FromJson (skipSpaces s)
+ in
+ if String.all Char.isSpace s' then
+ v
+ else
+ error <xml>Extra content at end of JSON record: {[s']}</xml>
+ end
+
+fun escape s =
+ let
+ fun esc s =
+ case s of
+ "" => "\""
+ | _ =>
+ let
+ val ch = String.sub s 0
+ in
+ (if ch = #"\"" || ch = #"\\" then
+ "\\" ^ String.str ch
+ else
+ String.str ch) ^ esc (String.suffix s 1)
+ end
+ in
+ "\"" ^ esc s
+ end
+
+fun unescape s =
+ let
+ val len = String.length s
+
+ fun findEnd i =
+ if i >= len then
+ error <xml>JSON unescape: string ends before quote: {[s]}</xml>
+ else
+ let
+ val ch = String.sub s i
+ in
+ case ch of
+ #"\"" => i
+ | #"\\" =>
+ if i+1 >= len then
+ error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else
+ findEnd (i+2)
+ | _ => findEnd (i+1)
+ end
+
+ val last = findEnd 1
+
+ fun unesc i =
+ if i >= last then
+ ""
+ else
+ let
+ val ch = String.sub s i
+ in
+ case ch of
+ #"\\" =>
+ if i+1 >= len then
+ error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else
+ String.str (String.sub s (i+1)) ^ unesc (i+2)
+ | _ => String.str ch ^ unesc (i+1)
+ end
+ in
+ if len = 0 || String.sub s 0 <> #"\"" then
+ error <xml>JSON unescape: String doesn't start with double quote: {[s]}</xml>
+ else
+ (unesc 1, String.substring s {Start = last+1, Len = len-last-1})
+ end
+
+val json_string = {ToJson = escape,
+ FromJson = unescape}
+
+fun numIn [a] (_ : read a) s : a * string =
+ let
+ val len = String.length s
+
+ fun findEnd i =
+ if i >= len then
+ i
+ else
+ let
+ val ch = String.sub s i
+ in
+ if Char.isDigit ch || ch = #"-" || ch = #"." || ch = #"E" || ch = #"e" then
+ findEnd (i+1)
+ else
+ i
+ end
+
+ val last = findEnd 0
+ in
+ (readError (String.substring s {Start = 0, Len = last}), String.substring s {Start = last, Len = len-last})
+ end
+
+fun json_num [a] (_ : show a) (_ : read a) : json a = {ToJson = show,
+ FromJson = numIn}
+
+val json_int = json_num
+val json_float = json_num
+
+val json_bool = {ToJson = fn b => if b then "true" else "false",
+ FromJson = fn s => if String.isPrefix {Full = s, Prefix = "true"} then
+ (True, String.substring s {Start = 4, Len = String.length s - 4})
+ else if String.isPrefix {Full = s, Prefix = "false"} then
+ (False, String.substring s {Start = 5, Len = String.length s - 5})
+ else
+ error <xml>JSON: bad boolean string: {[s]}</xml>}
+
+fun json_option [a] (j : json a) : json (option a) =
+ {ToJson = fn v => case v of
+ None => "null"
+ | Some v => j.ToJson v,
+ FromJson = fn s => if String.isPrefix {Full = s, Prefix = "null"} then
+ (None, String.substring s {Start = 4, Len = String.length s - 4})
+ else
+ let
+ val (v, s') = j.FromJson s
+ in
+ (Some v, s')
+ end}
+
+fun json_list [a] (j : json a) : json (list a) =
+ let
+ fun toJ' (ls : list a) : string =
+ case ls of
+ [] => ""
+ | x :: ls => "," ^ toJson j x ^ toJ' ls
+
+ fun toJ (x : list a) : string =
+ case x of
+ [] => "[]"
+ | x :: [] => "[" ^ toJson j x ^ "]"
+ | x :: ls => "[" ^ toJson j x ^ toJ' ls ^ "]"
+
+ fun fromJ (s : string) : list a * string =
+ let
+ fun fromJ' (s : string) : list a * string =
+ if String.length s = 0 then
+ error <xml>JSON list doesn't end with ']'</xml>
+ else
+ let
+ val ch = String.sub s 0
+ in
+ case ch of
+ #"]" => ([], String.substring s {Start = 1, Len = String.length s - 1})
+ | _ =>
+ let
+ val (x, s') = j.FromJson s
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 then
+ error <xml>JSON list doesn't end with ']'</xml>
+ else if String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+
+ val (ls, s'') = fromJ' s'
+ in
+ (x :: ls, s'')
+ end
+ end
+ in
+ if String.length s = 0 || String.sub s 0 <> #"[" then
+ error <xml>JSON list doesn't start with '[': {[s]}</xml>
+ else
+ fromJ' (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
+ end
+ in
+ {ToJson = toJ,
+ FromJson = fromJ}
+ end
+
+fun skipOne s =
+ let
+ fun skipOne s dquote squote brace bracket =
+ if String.length s = 0 then
+ s
+ else
+ let
+ val ch = String.sub s 0
+ val rest = String.suffix s 1
+ in
+ case ch of
+ #"\"" => skipOne rest (not dquote) squote brace bracket
+ | #"'" => skipOne rest dquote (not squote) brace bracket
+ | #"\\" => if String.length s >= 2 then
+ skipOne (String.suffix s 2) dquote squote brace bracket
+ else
+ ""
+ | #"{" => skipOne rest dquote squote (brace + 1) bracket
+ | #"}" => if brace = 0 then
+ s
+ else
+ skipOne rest dquote squote (brace - 1) bracket
+
+ | #"[" => skipOne rest dquote squote brace (bracket + 1)
+ | #"]" =>
+ if bracket = 0 then
+ s
+ else
+ skipOne rest dquote squote brace (bracket - 1)
+
+ | #"," =>
+ if not dquote && not squote && brace = 0 && bracket = 0 then
+ s
+ else
+ skipOne rest dquote squote brace bracket
+
+ | _ => skipOne rest dquote squote brace bracket
+ end
+ in
+ skipOne s False False 0 0
+ end
+
+fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts =
+ {ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
+ escape name ^ ":" ^ j.ToJson v ^ (case acc of
+ "" => ""
+ | acc => "," ^ acc))
+ "" fl jss names r ^ "}",
+ FromJson = fn s =>
+ let
+ fun fromJ s (r : $(map option ts)) : $(map option ts) * string =
+ if String.length s = 0 then
+ error <xml>JSON object doesn't end in brace</xml>
+ else if String.sub s 0 = #"}" then
+ (r, String.substring s {Start = 1, Len = String.length s - 1})
+ else let
+ val (name, s') = unescape s
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
+ error <xml>No colon after JSON object field name</xml>
+ else
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+
+ val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r =>
+ if name = name' then
+ let
+ val (v, s') = j.FromJson s'
+ in
+ (r -- nm ++ {nm = Some v}, s')
+ end
+ else
+ let
+ val (r', s') = acc (r -- nm)
+ in
+ (r' ++ {nm = r.nm}, s')
+ end)
+ (fn r => (r, skipOne s'))
+ fl jss names r
+
+ val s' = skipSpaces s'
+ val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+ in
+ fromJ s' r
+ end
+ in
+ if String.length s = 0 || String.sub s 0 <> #"{" then
+ error <xml>JSON record doesn't begin with brace</xml>
+ else
+ let
+ val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
+ (@map0 [option] (fn [t ::_] => None) fl)
+ in
+ (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name =>
+ case v of
+ None => error <xml>Missing JSON object field {[name]}</xml>
+ | Some v => v) fl r names, s')
+ end
+ end}
+
+fun destrR [K] [f :: K -> Type] [fr :: K -> Type] [t ::: Type]
+ (f : p :: K -> f p -> fr p -> t)
+ [r ::: {K}] (fl : folder r) (v : variant (map f r)) (r : $(map fr r)) : t =
+ match v
+ (@Top.mp [fr] [fn p => f p -> t]
+ (fn [p] (m : fr p) (v : f p) => f [p] v m)
+ fl r)
+
+fun json_variant [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json (variant ts) =
+ {ToJson = fn r => let val jnames = @map2 [json] [fn _ => string] [fn x => json x * string]
+ (fn [t] (j : json t) (name : string) => (j, name)) fl jss names
+ in @destrR [ident] [fn x => json x * string]
+ (fn [p ::_] (v : p) (j : json p, name : string) =>
+ "{" ^ escape name ^ ":" ^ j.ToJson v ^ "}") fl r jnames
+ end,
+ FromJson = fn s =>
+ if String.length s = 0 || String.sub s 0 <> #"{" then
+ error <xml>JSON variant doesn't begin with brace</xml>
+ else
+ let
+ val (name, s') = unescape (skipSpaces (String.suffix s 1))
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
+ error <xml>No colon after JSON object field name</xml>
+ else
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+
+ val (r, s') = (@foldR2 [json] [fn _ => string]
+ [fn ts => ts' :: {Type} -> [ts ~ ts'] => variant (ts ++ ts') * string]
+ (fn [nm ::_] [t ::_] [rest ::_] [[nm] ~ rest] (j : json t) name'
+ (acc : ts' :: {Type} -> [rest ~ ts'] => variant (rest ++ ts') * string) [fwd ::_] [[nm = t] ++ rest ~ fwd] =>
+ if name = name'
+ then
+ let val (v, s') = j.FromJson s'
+ in (make [nm] v, s')
+ end
+ else acc [fwd ++ [nm = t]]
+ )
+ (fn [fwd ::_] [[] ~ fwd] => error <xml>Unknown JSON object variant name {[name]}</xml>)
+ fl jss names) [[]] !
+
+ val s' = skipSpaces s'
+ val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+ in
+ if String.length s' = 0 then
+ error <xml>JSON object doesn't end in brace</xml>
+ else if String.sub s' 0 = #"}" then
+ (r, String.substring s' {Start = 1, Len = String.length s' - 1})
+ else error <xml>Junk after JSON value in object</xml>
+ end
+ }
+
+val json_unit : json unit = json_record {} {}
+
+functor Recursive (M : sig
+ con t :: Type -> Type
+ val json_t : a ::: Type -> json a -> json (t a)
+ end) = struct
+ open M
+
+ datatype r = Rec of t r
+
+ fun rTo (Rec x) = (json_t {ToJson = rTo,
+ FromJson = fn _ => error <xml>Tried to FromJson in ToJson!</xml>}).ToJson x
+
+ fun rFrom s =
+ let
+ val (x, s') = (json_t {ToJson = fn _ => error <xml>Tried to ToJson in FromJson!</xml>,
+ FromJson = rFrom}).FromJson s
+ in
+ (Rec x, s')
+ end
+
+ val json_r = {ToJson = rTo, FromJson = rFrom}
+end
diff --git a/lib/ur/json.urs b/lib/ur/json.urs
new file mode 100644
index 00000000..b4bd6350
--- /dev/null
+++ b/lib/ur/json.urs
@@ -0,0 +1,31 @@
+(** The JSON text-based serialization format *)
+
+class json
+
+val toJson : a ::: Type -> json a -> a -> string
+val fromJson : a ::: Type -> json a -> string -> a
+val fromJson' : a ::: Type -> json a -> string -> a * string
+
+val mkJson : a ::: Type -> {ToJson : a -> string,
+ FromJson : string -> a * string} -> json a
+
+val json_string : json string
+val json_int : json int
+val json_float : json float
+val json_bool : json bool
+val json_option : a ::: Type -> json a -> json (option a)
+val json_list : a ::: Type -> json a -> json (list a)
+
+val json_record : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json $ts
+val json_variant : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json (variant ts)
+
+val json_unit : json unit
+
+functor Recursive (M : sig
+ con t :: Type -> Type
+ val json_t : a ::: Type -> json a -> json (t a)
+ end) : sig
+ datatype r = Rec of M.t r
+
+ val json_r : json r
+end
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 6c6c896c..02567917 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -179,6 +179,13 @@ fun mapUX [tf :: Type] [ctx :: {Unit}]
<xml>{f [nm] [rest] r}{acc}</xml>)
<xml/>
+fun mapUX_rev [tf :: Type] [ctx :: {Unit}]
+ (f : nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => tf -> xml ctx [] []) =
+ @@foldR [fn _ => tf] [fn _ => xml ctx [] []]
+ (fn [nm :: Name] [u :: Unit] [rest :: {Unit}] [[nm] ~ rest] r acc =>
+ <xml>{acc}{f [nm] [rest] r}</xml>)
+ <xml/>
+
fun mapX [K] [tf :: K -> Type] [ctx :: {Unit}]
(f : nm :: Name -> t :: K -> rest :: {K}
-> [[nm] ~ rest] =>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 8273db0c..ec098955 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -126,6 +126,10 @@ val mapUX : tf :: Type -> ctx :: {Unit}
-> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] =>
tf -> xml ctx [] [])
-> r ::: {Unit} -> folder r -> $(mapU tf r) -> xml ctx [] []
+val mapUX_rev : tf :: Type -> ctx :: {Unit}
+ -> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] =>
+ tf -> xml ctx [] [])
+ -> r ::: {Unit} -> folder r -> $(mapU tf r) -> xml ctx [] []
(* Generate some XML by mapping over a heterogenously-typed record *)
val mapX : K --> tf :: (K -> Type) -> ctx :: {Unit}
diff --git a/src/c/Makefile.am b/src/c/Makefile.am
index d117d018..f4d9bef8 100644
--- a/src/c/Makefile.am
+++ b/src/c/Makefile.am
@@ -8,9 +8,14 @@ liburweb_static_la_SOURCES = static.c
AM_CPPFLAGS = -I$(srcdir)/../../include/urweb $(OPENSSL_INCLUDES)
AM_CFLAGS = -Wimplicit -Wall -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS)
-liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS)
+liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \
+ -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)'
liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS)
liburweb_http_la_LIBADD = liburweb.la
+liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)'
liburweb_cgi_la_LIBADD = liburweb.la
+liburweb_cgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)'
liburweb_fastcgi_la_LIBADD = liburweb.la
+liburweb_fastcgi_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)'
liburweb_static_la_LIBADD = liburweb.la
+liburweb_static_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)'
diff --git a/src/c/http.c b/src/c/http.c
index 9059746f..d186e209 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -314,7 +314,7 @@ static void *worker(void *data) {
}
static void help(char *cmd) {
- printf("Usage: %s [-p <port>] [-a <IP address>] [-t <thread count>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\n", cmd);
+ printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-t <thread count>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\n", cmd);
}
static void sigint(int signum) {
@@ -325,19 +325,18 @@ static void sigint(int signum) {
int main(int argc, char *argv[]) {
// The skeleton for this function comes from Beej's sockets tutorial.
int sockfd; // listen on sock_fd
- struct sockaddr_in my_addr;
- struct sockaddr_in their_addr; // connector's address information
+ struct sockaddr_in6 my_addr;
+ struct sockaddr_in6 their_addr; // connector's address information
socklen_t sin_size;
- int yes = 1, uw_port = 8080, nthreads = 1, i, *names, opt;
+ int yes = 1, no = 0, uw_port = 8080, nthreads = 1, i, *names, opt;
int recv_timeout_sec = 5;
signal(SIGINT, sigint);
signal(SIGPIPE, SIG_IGN);
- my_addr.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP
- memset(my_addr.sin_zero, '\0', sizeof my_addr.sin_zero);
+ my_addr.sin6_addr = in6addr_any; // auto-fill with my IP
- while ((opt = getopt(argc, argv, "hp:a:t:kqT:")) != -1) {
+ while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:")) != -1) {
switch (opt) {
case '?':
fprintf(stderr, "Unknown command-line option\n");
@@ -358,8 +357,21 @@ int main(int argc, char *argv[]) {
break;
case 'a':
- if (!inet_pton(AF_INET, optarg, &my_addr.sin_addr)) {
- fprintf(stderr, "Invalid IP address\n");
+ {
+ char *buf = alloca(strlen(optarg) + 8);
+ strcpy(buf, "::FFFF:");
+ strcpy(buf + 7, optarg);
+ if (!inet_pton(AF_INET6, buf, &my_addr.sin6_addr)) {
+ fprintf(stderr, "Invalid IPv4 address\n");
+ help(argv[0]);
+ return 1;
+ }
+ }
+ break;
+
+ case 'A':
+ if (!inet_pton(AF_INET6, optarg, &my_addr.sin6_addr)) {
+ fprintf(stderr, "Invalid IPv6 address\n");
help(argv[0]);
return 1;
}
@@ -401,7 +413,7 @@ int main(int argc, char *argv[]) {
names = calloc(nthreads, sizeof(int));
- sockfd = socket(PF_INET, SOCK_STREAM, 0); // do some error checking!
+ sockfd = socket(AF_INET6, SOCK_STREAM, 0); // do some error checking!
if (sockfd < 0) {
fprintf(stderr, "Listener socket creation failed\n");
@@ -413,8 +425,13 @@ int main(int argc, char *argv[]) {
return 1;
}
- my_addr.sin_family = AF_INET; // host byte order
- my_addr.sin_port = htons(uw_port); // short, network byte order
+ if (setsockopt(sockfd, IPPROTO_IPV6, IPV6_V6ONLY, &no, sizeof(int)) < 0) {
+ fprintf(stderr, "Listener IPV6_V6ONLY option resetting failed\n");
+ return 1;
+ }
+
+ my_addr.sin6_family = AF_INET6; // host byte order
+ my_addr.sin6_port = htons(uw_port); // short, network byte order
if (bind(sockfd, (struct sockaddr *)&my_addr, sizeof my_addr) < 0) {
fprintf(stderr, "Listener socket bind failed\n");
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index b2c85a54..688b3e4d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -55,6 +55,8 @@ structure CM = BinaryMapFn(struct
val debug = ref false
+val app_js = ref ""
+
val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan)
val ident = String.translate (fn #"'" => "PRIME"
@@ -2509,9 +2511,15 @@ fun p_decl env (dAll as (d, loc) : decl) =
| DDatabase _ => box []
| DPreparedStatements _ => box []
- | DJavaScript s => box [string "static char jslib[] = \"",
- string (Prim.toCString s),
- string "\";"]
+ | DJavaScript s =>
+ let
+ val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
+ file = "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"}
+ in
+ box [string "static char jslib[] = \"",
+ string (Prim.toCString s),
+ string "\";"]
+ end
| DCookie s => box [string "/*",
space,
string "cookie",
@@ -2948,15 +2956,11 @@ fun p_file env (ds, ps) =
newline]
end
- val timestamp = LargeInt.toString (Time.toMilliseconds (Time.now ()))
- val app_js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
- file = "app." ^ timestamp ^ ".js"}
-
- val allScripts =
+ fun allScripts () =
foldl (fn (x, scripts) =>
scripts
^ "<script type=\\\"text/javascript\\\" src=\\\"" ^ x ^ "\\\"></script>\\n")
- "" (Settings.getScripts () @ [app_js])
+ "" (Settings.getScripts () @ [!app_js])
fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) =
let
@@ -3098,7 +3102,7 @@ fun p_file env (ds, ps) =
val scripts =
case side of
ServerOnly => ""
- | _ => allScripts
+ | _ => allScripts ()
in
string scripts
end,
@@ -3306,8 +3310,7 @@ fun p_file env (ds, ps) =
val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
- val now = Time.now ()
- val nowD = Date.fromTimeUniv now
+ val lastMod = Date.fromTimeUniv (FileIO.mostRecentModTime ())
val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT"
fun hexifyByte (b : Word8.word) : string =
@@ -3496,26 +3499,26 @@ fun p_file env (ds, ps) =
string "static void uw_handle(uw_context ctx, char *request) {",
newline,
- string "if (!strcmp(request, \"",
- string app_js,
- string "\")) {",
+ string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
newline,
- box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");",
- newline,
- string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"),
- newline,
- box [string "uw_clear_headers(ctx);",
- newline,
- string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");",
- newline,
- string "return;",
- newline],
- string "}",
+ string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt lastMod ^ "\")) {"),
+ newline,
+ box [string "uw_clear_headers(ctx);",
newline,
+ string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");",
newline,
- string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");",
+ string "return;",
+ newline],
+ string "}",
+ newline,
+ newline,
+ string "if (!strcmp(request, \"",
+ string (!app_js),
+ string "\")) {",
+ newline,
+ box [string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");",
newline,
- string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"),
+ string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt lastMod ^ "\\r\\n\");"),
newline,
string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"),
newline,
@@ -3538,7 +3541,7 @@ fun p_file env (ds, ps) =
string (String.toCString ct),
string "\\r\\n\");",
newline]),
- string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt (Date.fromTimeUniv (#LastModified r)) ^ "\\r\\n\");"),
+ string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt lastMod ^ "\\r\\n\");"),
newline,
string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"),
newline,
@@ -3634,7 +3637,7 @@ fun p_file env (ds, ps) =
newline,
if !hasJs then
box [string "uw_set_script_header(ctx, \"",
- string allScripts,
+ string (allScripts ()),
string "\");",
newline]
else
diff --git a/src/compiler.sml b/src/compiler.sml
index dccda06d..4fe2dfd5 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -212,7 +212,7 @@ val parseUrs =
val fname = OS.FileSys.tmpName ()
val outf = TextIO.openOut fname
val () = TextIO.output (outf, "sig\n")
- val inf = TextIO.openIn filename
+ val inf = FileIO.txtOpenIn filename
fun loop () =
case TextIO.inputLine inf of
NONE => ()
@@ -225,7 +225,7 @@ val parseUrs =
val () = (ErrorMsg.resetErrors ();
ErrorMsg.resetPositioning filename;
Lex.UserDeclarations.initialize ())
- val file = TextIO.openIn fname
+ val file = FileIO.txtOpenIn fname
fun get _ = TextIO.input file
fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
@@ -251,7 +251,7 @@ val parseUr = {
val () = (ErrorMsg.resetErrors ();
ErrorMsg.resetPositioning filename;
Lex.UserDeclarations.initialize ())
- val file = TextIO.openIn filename
+ val file = FileIO.txtOpenIn filename
fun get _ = TextIO.input file
fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s
val lexer = LrParser.Stream.streamify (Lex.makeLexer get)
@@ -478,13 +478,15 @@ fun parseUrp' accLibs fname =
val thisPath = OS.Path.dir filename
val dir = OS.Path.dir filename
- fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
+ fun opener () = FileIO.txtOpenIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"})
val inf = opener ()
fun hasSpaceLine () =
case inputCommentableLine inf of
Content s => s = "debug" orelse s = "profile"
+ orelse s = "html5" orelse s = "xhtml"
+ orelse s = "noMangleSql" orelse s = "lessSafeFfi"
orelse CharVector.exists (fn ch => ch = #" " orelse ch = #"\t") s orelse hasSpaceLine ()
| EndOfFile => false
| OnlyComment => hasSpaceLine ()
@@ -890,6 +892,7 @@ fun parseUrp' accLibs fname =
| "timeFormat" => Settings.setTimeFormat arg
| "noMangleSql" => Settings.setMangleSql false
| "html5" => Settings.setIsHtml5 true
+ | "xhtml" => Settings.setIsHtml5 false
| "lessSafeFfi" => Settings.setLessSafeFfi true
| "file" =>
diff --git a/src/demo.sml b/src/demo.sml
index 0d9f0f4f..47d22395 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -33,7 +33,7 @@ fun make' {prefix, dirname, guided} =
let
val prose = OS.Path.joinDirFile {dir = dirname,
file = "prose"}
- val inf = TextIO.openIn prose
+ val inf = FileIO.txtOpenIn prose
val outDir = OS.Path.concat (dirname, "out")
@@ -351,7 +351,7 @@ fun make' {prefix, dirname, guided} =
SOME "urp" =>
doit (fn (src, html) =>
let
- val inf = TextIO.openIn src
+ val inf = FileIO.txtOpenIn src
val out = TextIO.openOut html
fun loop () =
diff --git a/src/elab_err.sml b/src/elab_err.sml
index 33daa118..385caca3 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -275,7 +275,7 @@ fun p_decl env d =
fun readFromFile () =
let
- val inf = TextIO.openIn fname
+ val inf = FileIO.txtOpenIn fname
fun loop acc =
case TextIO.inputLine inf of
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index d1eec2a1..69b0e23c 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -281,7 +281,7 @@ See doc for the variable `urweb-mode-info'."
"Face name to use for SQL keywords.")
(defface font-lock-cvariable-face
- '((t (:foreground "dark blue")))
+ '((t (:inherit font-lock-type-face)))
"Font Lock mode face used to highlight capitalized identifiers."
:group 'font-lock-highlighting-faces)
(defvar font-lock-cvariable-face 'font-lock-cvariable-face
diff --git a/src/fileio.sig b/src/fileio.sig
new file mode 100644
index 00000000..37b3b529
--- /dev/null
+++ b/src/fileio.sig
@@ -0,0 +1,9 @@
+signature FILE_IO = sig
+
+ (* When was a source file last modified (excluding files produced after [getResetTime])? *)
+ val mostRecentModTime : unit -> Time.time
+
+ val txtOpenIn : string -> TextIO.instream
+ val binOpenIn : string -> BinIO.instream
+
+end
diff --git a/src/fileio.sml b/src/fileio.sml
new file mode 100644
index 00000000..cab9d8a3
--- /dev/null
+++ b/src/fileio.sml
@@ -0,0 +1,39 @@
+structure FileIO :> FILE_IO = struct
+
+val mostRecentModTimeRef = ref (Time.zeroTime)
+
+fun checkFileModTime fname =
+ let
+ val mtime = OS.FileSys.modTime fname
+ val mostRecentMod = !mostRecentModTimeRef
+ val resetTime = Globals.getResetTime ()
+ fun lessThan (a, b) = LargeInt.compare (Time.toSeconds a, Time.toSeconds b) = LESS
+ infix lessThan
+ in
+ if mostRecentMod lessThan mtime andalso mtime lessThan resetTime
+ then mostRecentModTimeRef := mtime
+ else ()
+ end
+
+fun mostRecentModTime () =
+ if Time.compare (!mostRecentModTimeRef, Time.zeroTime) = EQUAL
+ then Globals.getResetTime ()
+ else !mostRecentModTimeRef
+
+fun txtOpenIn fname =
+ let
+ val inf = TextIO.openIn fname
+ val () = checkFileModTime fname
+ in
+ inf
+ end
+
+fun binOpenIn fname =
+ let
+ val inf = BinIO.openIn fname
+ val () = checkFileModTime fname
+ in
+ inf
+ end
+
+end
diff --git a/src/globals.sig b/src/globals.sig
new file mode 100644
index 00000000..0cff65b5
--- /dev/null
+++ b/src/globals.sig
@@ -0,0 +1,7 @@
+signature GLOBALS = sig
+
+ (* When was the Ur/Web compiler started or reset? *)
+ val setResetTime : unit -> unit
+ val getResetTime : unit -> Time.time
+
+end
diff --git a/src/globals.sml b/src/globals.sml
new file mode 100644
index 00000000..fafc0438
--- /dev/null
+++ b/src/globals.sml
@@ -0,0 +1,7 @@
+structure Globals :> GLOBALS = struct
+
+val resetTime = ref (Time.zeroTime)
+fun setResetTime () = resetTime := Time.now ()
+fun getResetTime () = !resetTime
+
+end
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 65a0fa3a..dedcb554 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -1334,7 +1334,7 @@ fun process (file : file) =
maxName = U.File.maxName file + 1}
(#1 file)
- val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"})
+ val inf = FileIO.txtOpenIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"})
fun lines acc =
case TextIO.inputLine inf of
NONE => String.concat (rev acc)
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 6d368106..fb1a1723 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -254,7 +254,8 @@ fun send (sock, s) =
send (sock, String.extract (s, n, NONE))
end
-val () = case CommandLine.arguments () of
+val () = (Globals.setResetTime ();
+ case CommandLine.arguments () of
["daemon", "start"] =>
(case Posix.Process.fork () of
SOME _ => ()
@@ -376,4 +377,4 @@ val () = case CommandLine.arguments () of
else
(OS.FileSys.remove socket;
raise OS.SysErr ("", NONE))
- end handle OS.SysErr _ => OS.Process.exit (oneRun args)
+ end handle OS.SysErr _ => OS.Process.exit (oneRun args))
diff --git a/src/settings.sig b/src/settings.sig
index dd135bda..05ab5e23 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -302,4 +302,5 @@ signature SETTINGS = sig
val addJsFile : string (* filename *) -> unit
val listJsFiles : unit -> {Filename : string, Content : string} list
+
end
diff --git a/src/settings.sml b/src/settings.sml
index b72789df..70ea1861 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -290,7 +290,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
("attrifyInt", "ts"),
("attrifyFloat", "ts"),
("attrifyBool", "bs"),
- ("boolToString", "ts"),
+ ("boolToString", "bs"),
("str1", "id"),
("strsub", "sub"),
("strsuffix", "suf"),
@@ -818,7 +818,7 @@ fun mangleSqlCatalog s =
else
lowercase s
-val html5 = ref false
+val html5 = ref true
fun setIsHtml5 b = html5 := b
fun getIsHtml5 () = !html5
@@ -844,7 +844,7 @@ fun noMime () =
fun readMimeTypes () =
let
- val inf = TextIO.openIn "/etc/mime.types"
+ val inf = FileIO.txtOpenIn "/etc/mime.types"
fun loop m =
case TextIO.inputLine inf of
@@ -914,7 +914,7 @@ fun addFile {Uri, LoadFromFilename} =
ErrorMsg.error ("Two different files requested for URI " ^ Uri ^ " ( " ^ path' ^ " vs. " ^ path ^ ")")
| NONE =>
let
- val inf = BinIO.openIn path
+ val inf = FileIO.binOpenIn path
in
files := SM.insert (!files,
Uri,
@@ -937,7 +937,7 @@ val jsFiles = ref (SM.empty : {Filename : string, Content : string} SM.map)
fun addJsFile LoadFromFilename =
let
val path = OS.Path.concat (!filePath, LoadFromFilename)
- val inf = TextIO.openIn path
+ val inf = FileIO.txtOpenIn path
in
jsFiles := SM.insert (!jsFiles,
path,
@@ -952,7 +952,8 @@ fun addJsFile LoadFromFilename =
fun listJsFiles () = SM.listItems (!jsFiles)
fun reset () =
- (urlPrefixFull := "/";
+ (Globals.setResetTime ();
+ urlPrefixFull := "/";
urlPrefix := "/";
urlPrePrefix := "";
timeout := 0;
diff --git a/src/sha1.sig b/src/sha1.sig
new file mode 100644
index 00000000..7fda97f5
--- /dev/null
+++ b/src/sha1.sig
@@ -0,0 +1,31 @@
+
+(* Implementation the SHA-1 hash function.
+ Written by Tom 7 in 2004; code in the public domain. *)
+
+signature SHA1 =
+sig
+
+ (* Perform the SHA-1 hash function on a message.
+ Returns the 160 bit (20 byte) hash.
+
+ recall that string = CharVector.vector.
+ The input string may contain non-ascii data;
+ the output certainly will. *)
+
+ val hash : string -> string
+
+ (* pass in a stream as stateful function that returns
+ SOME s for some non-empty prefix of the remainder of
+ the stream, or NONE when the stream has ended. *)
+ val hash_stream : (unit -> string option) -> string
+
+ (* XXX move to hashutil *)
+ (* convert a binary string to one built of hex digits *)
+ val bintohex : string -> string
+
+ (* Parse a hexadecimal SHA-1 string. Uppercase and lowercase
+ are permitted. If the string is not the right length or
+ contains invalid characters, returns NONE. *)
+ val parse_hex : string -> string option
+
+end
diff --git a/src/sha1.sml b/src/sha1.sml
new file mode 100644
index 00000000..d962c4e0
--- /dev/null
+++ b/src/sha1.sml
@@ -0,0 +1,264 @@
+
+(* RFC-3174 (SHA-1) hashing function.
+ By Tom 7, 2004: Code placed in the public domain.
+*)
+
+structure SHA1 :> SHA1 =
+struct
+ exception Unimplemented
+
+ val xorb = Word32.xorb
+ val andb = Word32.andb
+ val orb = Word32.orb
+ val << = Word32.<<
+ val >> = Word32.>>
+ val notb = Word32.notb
+ val ++ = Word32.+
+
+ type w32 = word
+ infix xorb andb orb << >> ++
+
+ (* workaround for andb bug in MLton 20010706 *)
+ fun mkbyte w = Word32.mod (w, 0w256)
+
+ fun ROL(X, N : Word.word) = (X << N) orb (X >> (0w32-N))
+
+ fun wc hi lo = (hi << 0w16) orb lo
+
+ fun w2b w = map chr
+ [Word32.toInt (mkbyte (w >> 0w24)),
+ Word32.toInt (mkbyte (w >> 0w16)),
+ Word32.toInt (mkbyte (w >> 0w8)),
+ Word32.toInt (mkbyte w)]
+
+ (* the length (arg in bytes, output in bits)
+ as a 64-bit quantity, big-endian *)
+ fun lenbits l =
+ implode (List.tabulate (4, fn _ => chr 0)) ^
+ implode (w2b (Word32.fromInt (l * 8)))
+
+
+ (* executes f for each index lo..hi-1 inclusive *)
+ fun for lo hi f =
+ if lo >= hi then ()
+ else (ignore (f lo); for (lo + 1) hi f)
+
+ fun ford lo hi b f =
+ if lo >= hi then b
+ else
+ let
+ val b = f (lo, b)
+ in
+ (ford (lo + 1) hi b f)
+ end
+
+ fun doblock (aa, bb, cc, dd, ee) msg =
+ let
+ val K0 = wc 0wx5A82 0wx7999
+ val K1 = wc 0wx6ED9 0wxEBA1
+ val K2 = wc 0wx8F1B 0wxBCDC
+ val K3 = wc 0wxCA62 0wxC1D6
+
+ fun mb n = Word32.fromInt (ord (CharVector.sub(msg, n)))
+
+ val W = Array.array(80, 0w0)
+ fun Ws x = Array.sub(W, x)
+
+ val _ =
+ for 0 16
+ (fn t =>
+ let in
+ Array.update(W, t,
+ (mb (t * 4 ) << 0w24) orb
+ (mb (t * 4 + 1) << 0w16) orb
+ (mb (t * 4 + 2) << 0w8) orb
+ (mb (t * 4 + 3)))
+ end)
+
+ val _ =
+ for 16 80
+ (fn t =>
+ let
+ val n =
+ Ws (t-3) xorb
+ Ws (t-8) xorb
+ Ws (t-14) xorb
+ Ws (t-16)
+ val zz = ROL(n, 0w1)
+ in
+ Array.update(W, t, zz)
+ end)
+
+
+ val (A, B, C, D, E) = (aa, bb, cc, dd, ee)
+
+
+ fun round lo hi f k ctxt =
+ ford lo hi ctxt
+ (fn (t, ctxt as (A, B, C, D, E)) =>
+ let
+ val temp = ROL(A, 0w5) ++ (f ctxt) ++ E ++ Ws t ++ k
+ val E = D;
+ val D = C;
+ val C = ROL(B, 0w30)
+ val B = A
+ val A = temp
+ in
+ (A, B, C, D, E)
+ end)
+
+ val (A, B, C, D, E) =
+ round 0 20 (fn (A, B, C, D, E) =>
+ ((B andb C) orb ((notb B) andb D)))
+ K0 (A, B, C, D, E)
+
+ val (A, B, C, D, E) =
+ round 20 40 (fn (A, B, C, D, E) =>
+ (B xorb C xorb D))
+ K1 (A, B, C, D, E)
+
+ val (A, B, C, D, E) =
+ round 40 60 (fn (A, B, C, D, E) =>
+ ((B andb C) orb (B andb D) orb (C andb D)))
+ K2 (A, B, C, D, E)
+
+ val (A, B, C, D, E) =
+ round 60 80 (fn (A, B, C, D, E) =>
+ (B xorb C xorb D))
+ K3 (A, B, C, D, E)
+
+ in
+ (aa ++ A, bb ++ B, cc ++ C, dd ++ D, ee ++ E)
+ end
+
+ datatype 'a stream =
+ Cons of ('a * (unit -> 'a stream))
+ | Nil
+
+ (* turn a stream of oddly chunked strings into
+ one with 512-bit blocks *)
+ fun chunk_512 s =
+ let
+
+ (* the padding required to make a message of length l (bytes)
+ a proper SHA-1 input. Returns either one or two Cons cells.
+ tail is the end of the input (63 bytes or less)
+ l is the total length of the input, *including* the length of the
+ tail end *)
+ fun padding tail l =
+ let val v = l mod 64 in
+ if v < 56 then
+ let val p = 56 - v
+ val padding = implode (List.tabulate (p - 1, fn _ => chr 0))
+ in Cons (tail ^ str (chr 0x80) ^ padding ^ lenbits l,
+ fn _ => Nil)
+ end
+ else if v < 64 then
+ let val p = 64 - v
+ val padding1 = implode (List.tabulate (p - 1, fn _ => chr 0))
+ val padding2 = implode (List.tabulate (56, fn _ => chr 0))
+ in Cons (tail ^ str (chr 0x80) ^ padding1,
+ fn _ => Cons (padding2 ^ lenbits l, fn _ => Nil))
+ end
+ else raise Unimplemented (* Impossible? *)
+ end
+
+ (* n is the bytes we've already output.
+ cur is a string (of 64 bytes or less) that will
+ be our next chunk.
+ rest,sofar is a string and index indicating the
+ next bit of data. *)
+ (* PERF Could be more efficient by using an
+ accumulating array instead of a string for cur *)
+ fun ch n cur sofar startat () =
+ (* if we already have 64 bytes, return it *)
+ if size cur = 64
+ then
+ let in
+ Cons(cur, ch (n + 64) "" sofar startat)
+ end
+ else
+ (* do we have any in 'sofar'? *)
+ if startat < size sofar
+ then let
+ val get = Int.min(size sofar - startat,
+ 64 - size cur)
+ in
+ (* be eager, since we need to return something now *)
+ ch n (cur ^ String.substring(sofar, startat, get))
+ sofar (startat + get) ()
+ end
+ else
+ (* sofar has been exhausted,
+ so get some from input stream *)
+ (case s () of
+ (* eager, again *)
+ SOME ss => ch n cur ss 0 ()
+ | NONE =>
+ (* no more data. *)
+ padding cur (n + size cur))
+ in
+ ch 0 "" "" 0
+ end
+
+ fun hash_stream orig_stream =
+ let
+
+ val stream512 = chunk_512 orig_stream
+
+ (* gets hash context, length of string so far (bytes),
+ and tail of stream *)
+ fun hash_rest stream ctxt =
+ (case stream() of
+ Cons (s, stream) =>
+ let val ctxt = doblock ctxt s
+ in hash_rest stream ctxt
+ end
+ | Nil => ctxt)
+
+ val init =
+ (wc 0wx6745 0wx2301,
+ wc 0wxefcd 0wxab89,
+ wc 0wx98ba 0wxdcfe,
+ wc 0wx1032 0wx5476,
+ wc 0wxc3d2 0wxe1f0)
+
+ val (a, b, c, d, e) = hash_rest stream512 init
+ in
+ implode (w2b a @ w2b b @ w2b c @ w2b d @ w2b e)
+ end
+
+ fun hash m =
+ hash_stream
+ (let val r = ref true
+ in (fn () =>
+ if !r
+ then (r := false; SOME m)
+ else NONE)
+ end)
+
+ val digits = "0123456789ABCDEF"
+ fun bintohex s =
+ String.translate (fn c =>
+ implode [CharVector.sub (digits, ord c div 16),
+ CharVector.sub (digits, ord c mod 16)]) s
+
+ (* ASCII trick: (ch | 4400) % 55 *)
+ fun hexvalue ch =
+ SysWord.toInt (SysWord.orb(SysWord.fromInt(ord ch), SysWord.fromInt 4400)) mod 55
+
+ fun parse_hex s =
+ if size s <> 40
+ orelse not (CharVector.all (fn c => (ord c >= ord #"0" andalso
+ ord c <= ord #"9") orelse
+ (ord c >= ord #"a" andalso
+ ord c <= ord #"f") orelse
+ (ord c >= ord #"A" andalso
+ ord c <= ord #"F")) s)
+ then NONE
+ else SOME (CharVector.tabulate(20,
+ (fn i =>
+ chr(hexvalue (String.sub(s, i * 2)) * 16 +
+ hexvalue (String.sub(s, i * 2 + 1))))))
+
+end
diff --git a/src/sources b/src/sources
index 1a09e7e8..52b1bdd7 100644
--- a/src/sources
+++ b/src/sources
@@ -1,6 +1,9 @@
$(SRC)/config.sig
config.sml
+$(SRC)/globals.sig
+$(SRC)/globals.sml
+
$(SRC)/search.sig
$(SRC)/search.sml
@@ -16,6 +19,9 @@ $(SRC)/errormsg.sml
$(SRC)/print.sig
$(SRC)/print.sml
+$(SRC)/fileio.sig
+$(SRC)/fileio.sml
+
$(SRC)/settings.sig
$(SRC)/settings.sml
@@ -227,6 +233,9 @@ $(SRC)/sigcheck.sml
$(SRC)/mono_inline.sml
+$(SRC)/sha1.sig
+$(SRC)/sha1.sml
+
$(SRC)/cjr.sml
$(SRC)/postgres.sig
diff --git a/src/tag.sml b/src/tag.sml
index 6fef50d1..94e5d44f 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -38,6 +38,38 @@ structure SM = BinaryMapFn(struct
val compare = String.compare
end)
+structure UnionFind :> sig
+ type t
+ val empty : t
+ val equate : t * int * int -> t
+ val equal : t * int * int -> bool
+ val rep : t * int -> int
+ end = struct
+
+type t = int IM.map
+
+val empty = IM.empty
+
+fun rep (t, n) =
+ case IM.find (t, n) of
+ NONE => n
+ | SOME n' => rep (t, n')
+
+fun equate (t, n1, n2) =
+ let
+ val r1 = rep (t, n1)
+ val r2 = rep (t, n2)
+ in
+ if r1 = r2 then
+ t
+ else
+ IM.insert (t, r1, r2)
+ end
+
+fun equal (t, n1, n2) = rep (t, n1) = rep (t, n2)
+
+end
+
fun kind (k, s) = (k, s)
fun con (c, s) = (c, s)
@@ -45,7 +77,7 @@ fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for multip
TextIO.output (TextIO.stdErr,
"Make sure that the signature of the containing module hides any form/RPC handlers.\n"))
-fun exp env (e, s) =
+fun exp uf env (e, s) =
let
fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) =
let
@@ -74,13 +106,15 @@ fun exp env (e, s) =
(e, (count, tags, byTag, newTags))
else
let
+ val f = UnionFind.rep (uf, f)
+
val (cn, count, tags, newTags) =
case IM.find (tags, f) of
NONE =>
(count, count + 1, IM.insert (tags, f, count),
(ek, f, count) :: newTags)
| SOME cn => (cn, count, tags, newTags)
-
+
val (_, _, _, s) = E.lookupENamed env f
val byTag = case SM.find (byTag, s) of
@@ -217,20 +251,20 @@ fun tag file =
let
val count = U.File.maxName file
- fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
+ fun doDecl (d as (d', loc), (env, count, tags, byTag, uf)) =
case d' of
DExport (ek, n, _) =>
let
val (_, _, _, s) = E.lookupENamed env n
in
case SM.find (byTag, s) of
- NONE => ([d], (env, count, tags, byTag))
+ NONE => ([d], (env, count, tags, byTag, uf))
| SOME (ek', n') =>
(if ek = ek' then
()
else
both (loc, s);
- ([], (env, count, tags, byTag)))
+ ([], (env, count, tags, byTag, uf)))
end
| _ =>
let
@@ -242,7 +276,7 @@ fun tag file =
val (d, (count, tags, byTag, newTags)) =
U.Decl.foldMap {kind = kind,
con = con,
- exp = exp env'',
+ exp = exp uf env'',
decl = decl}
(count, tags, byTag, []) d
@@ -306,11 +340,15 @@ fun tag file =
val ds = case d of
(DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
| _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
+
+ val uf = case d' of
+ DVal (_, n1, _, (ENamed n2, _), _) => UnionFind.equate (uf, n1, n2)
+ | _ => uf
in
- (ds @ newExports, (env, count, tags, byTag))
+ (ds @ newExports, (env, count, tags, byTag, uf))
end
- val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
+ val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty, UnionFind.empty) file
in
file
end
diff --git a/src/tutorial.sml b/src/tutorial.sml
index dd2d3f7d..0c2f908f 100644
--- a/src/tutorial.sml
+++ b/src/tutorial.sml
@@ -38,7 +38,7 @@ fun readAll inf =
before TextIO.closeIn inf
end
-val readAllFile = readAll o TextIO.openIn
+val readAllFile = readAll o FileIO.txtOpenIn
fun fixupFile (fname, title) =
let
@@ -154,7 +154,7 @@ fun fixupFile (fname, title) =
fun doUr fname =
let
- val inf = TextIO.openIn fname
+ val inf = FileIO.txtOpenIn fname
val title = case TextIO.inputLine inf of
NONE => raise Fail ("No title comment at start of " ^ fname)
diff --git a/tests/crud1.html b/tests/crud1.html
index 7ed26d30..92cd1942 100644
--- a/tests/crud1.html
+++ b/tests/crud1.html
@@ -1,6 +1,4 @@
-<?xml version="1.0" encoding="utf-8" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"><head></head><body>
+<!DOCTYPE html><html><head></head><body>
<p>Inserted with ID 1.</p>
<table border="1">
diff --git a/tests/hello.html b/tests/hello.html
index 9c249df0..4fb6f910 100644
--- a/tests/hello.html
+++ b/tests/hello.html
@@ -1,6 +1,4 @@
-<?xml version="1.0" encoding="utf-8" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+<!DOCTYPE html><html>
<head>
<title>Hello world!</title>
</head>
diff --git a/tests/jsonTest.ur b/tests/jsonTest.ur
new file mode 100644
index 00000000..97898de8
--- /dev/null
+++ b/tests/jsonTest.ur
@@ -0,0 +1,6 @@
+open Json
+
+fun main () : transaction page = return <xml><body>
+ {[fromJson "[1, 2, 3]" : list int]}<br/>
+ {[toJson ("hi" :: "bye\"" :: "hehe" :: [])]}
+</body></xml>
diff --git a/tests/jsonTest.urp b/tests/jsonTest.urp
new file mode 100644
index 00000000..0b606fa3
--- /dev/null
+++ b/tests/jsonTest.urp
@@ -0,0 +1,7 @@
+rewrite all JsonTest/*
+
+$/char
+$/string
+$/list
+$/json
+jsonTest
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-23 15:08:49 +0000