diff options
96 files changed, 1724 insertions, 321 deletions
@@ -76,3 +76,8 @@ libtool include/urweb/config.h include/urweb/config.h.in include/urweb/stamp-h1 + +# python files +# Byte-compiled / optimized / DLL files +__pycache__/ +*.py[cod] @@ -1,4 +1,19 @@ ======== +20180616 +======== + +- New feature to cache files stored in the database as blobs, via the + 'filecache' .urp directive +- New .urp directives: 'mimeTypes' and 'file' (new long form) +- New HTML pseudo-tag: <cradio> +- New HTML tag attributes: 'oninput', 'onscroll', 'title', 'size' +- New standard-library functions: 'List.findM' and 'List.existsM' +- New '-help' command-line option for compiler +- Remove insecure function 'Basis.crypt' (which didn't seem to have any users) +- Selenium-based automatic testing +- Bug fixes and improvements to documentation and error messages + +======== 20170720 ======== @@ -19,3 +19,42 @@ Ur/Web is Ur plus a special standard library and associated rules for parsing an This type safety is just the foundation of the Ur/Web methodology. It is also possible to use metaprogramming to build significant application pieces by analysis of type structure. For instance, the demo includes an ML-style functor for building an admin interface for an arbitrary SQL table. The type system guarantees that the admin interface sub-application that comes out will always be free of the above-listed bugs, no matter which well-typed table description is given as input. The Ur/Web compiler also produces very efficient object code that does not use garbage collection. These compiled programs will often be even more efficient than what most programmers would bother to write in C. For example, the standalone web server generated for the demo uses less RAM than the bash shell. The compiler also generates JavaScript versions of client-side code, with no need to write those parts of applications in a different language. + +# Simple Invocation + +Here's a simple example of compiling, running, and accessing an application included with the Ur/Web distribution. + +```sh +urweb demo/hello +demo/hello.exe & +wget http://localhost:8080/Hello/main -O - +``` + +# Simple Installation + +The normal UNIX-style build and installation procedure works (where the `make` program needs to be GNU Make, and where `./autogen.sh` must be run first only if starting from a Git checkout rather than a release tarball). + +```sh +./configure +make +sudo make install +``` + +However, some popular platforms have standard packages for Ur/Web, making installation and uninstallation even easier. + +## In Debian, Ubuntu, and Other Related Linux Distributions + +```sh +apt-get install urweb +``` + +## In Homebrew for Mac OS + +```sh +brew install urweb +``` + +# For More Detail + +See [the reference manual](http://www.impredicative.com/ur/manual.pdf). +Links to packages for other platforms also appear on [the project home page](http://www.impredicative.com/ur/). diff --git a/configure.ac b/configure.ac index 5786c582..44c6873f 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20170720]) +AC_INIT([urweb], [20180616]) WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS diff --git a/demo/more/prose b/demo/more/prose index 9c267ca0..1f1d5a49 100644 --- a/demo/more/prose +++ b/demo/more/prose @@ -1,8 +1,8 @@ -<p>These are some extra demo applications written in <a href="http://www.impredicative.com/ur/">Ur/Web</a>. See <a href="http://www.impredicative.com/ur/demo/">the main demo</a> for a more tutorial-like progression through language and library features.</p> +<p>These are some extra demo applications written in <a target="_top" href="http://www.impredicative.com/ur/">Ur/Web</a>. See <a target="_top" href="http://www.impredicative.com/ur/demo/">the main demo</a> for a more tutorial-like progression through language and library features.</p> dragList.urp -<p>This is an Ur/Web version of the "draggable lists" <a href="http://groups.inf.ed.ac.uk/links/examples/">demo program from Links</a>.</p> +<p>This is an Ur/Web version of the "draggable lists" <a target="_top" href="http://groups.inf.ed.ac.uk/links/examples/">demo program from Links</a>.</p> grid1.urp @@ -1,6 +1,6 @@ -<p><b>Ur/Web</b> is a domain-specific language for programming web applications backed by SQL databases. It is (strongly) statically typed (like ML and Haskell) and purely functional (like Haskell). <b>Ur</b> is the base language, and the web-specific features of Ur/Web (mostly) come only in the form of special rules for parsing and optimization. The Ur core looks a lot like <a href="http://sml.sourceforge.net/">Standard ML</a>, with a few <a href="http://www.haskell.org/">Haskell</a>-isms added, and kinder, gentler versions added of many features from dependently typed languages like the logic behind <a href="http://coq.inria.fr/">Coq</a>. The type system is much more expressive than in ML and Haskell, such that well-typed web applications cannot "go wrong," not just in handling single HTTP requests, but across their entire lifetimes of interacting with HTTP clients. Beyond that, Ur is unusual in using ideas from dependent typing to enable very effective metaprogramming, or programming with explicit analysis of type structure. Many common web application components can be built by Ur/Web functions that operate on types, where it seems impossible to achieve similar code re-use in more established statically typed languages.</p> +<p><b>Ur/Web</b> is a domain-specific language for programming web applications backed by SQL databases. It is (strongly) statically typed (like ML and Haskell) and purely functional (like Haskell). <b>Ur</b> is the base language, and the web-specific features of Ur/Web (mostly) come only in the form of special rules for parsing and optimization. The Ur core looks a lot like <a target="_top" href="http://sml.sourceforge.net/">Standard ML</a>, with a few <a target="_top" href="http://www.haskell.org/">Haskell</a>-isms added, and kinder, gentler versions added of many features from dependently typed languages like the logic behind <a target="_top" href="http://coq.inria.fr/">Coq</a>. The type system is much more expressive than in ML and Haskell, such that well-typed web applications cannot "go wrong," not just in handling single HTTP requests, but across their entire lifetimes of interacting with HTTP clients. Beyond that, Ur is unusual in using ideas from dependent typing to enable very effective metaprogramming, or programming with explicit analysis of type structure. Many common web application components can be built by Ur/Web functions that operate on types, where it seems impossible to achieve similar code re-use in more established statically typed languages.</p> -<p>The page you are currently reading is a part of the demo included with the Ur/Web sources and supporting files available from <a href="https://github.com/urweb/urweb">GitHub</a>. The following steps will build a local instance of the demo if you're lucky (and running a Debian-based Linux OS, which actually tend to have Ur/Web packages built in these days). If you're not lucky, you can consult the beginning of <a href="http://www.impredicative.com/ur/manual.pdf">the manual</a> for more detailed instructions.</p> +<p>The page you are currently reading is a part of the demo included with the Ur/Web sources and supporting files available from <a target="_top" href="https://github.com/urweb/urweb">GitHub</a>. The following steps will build a local instance of the demo if you're lucky (and running a Debian-based Linux OS, which actually tend to have Ur/Web packages built in these days). If you're not lucky, you can consult the beginning of <a target="_top" href="http://www.impredicative.com/ur/manual.pdf">the manual</a> for more detailed instructions.</p> <h6>Install System Dependencies</h6> @@ -23,10 +23,10 @@ sudo make install <h6>Compile the Demo the Easy Way</h6> -<p><blockquote><pre>$ urweb -dbms sqlite -db /path_to_db.sqlite -demo /Demo demo +<p><blockquote><pre>$ urweb -dbms sqlite -db /path_to_db.sqlite -demo /Demo -noEmacs demo </blockquote></pre></p> -<p>The <tt>-dbms sqlite</tt> flag indicates that instead of using the default database management system (<a href="https://www.postgresql.org/">PostgreSQL</a>), we wish to use <a href="https://sqlite.org/">SQLite</a> (usually unsuited for production). The <tt>-db</tt> flag allows us to specify the file-system path to our SQLite database. The <tt>-demo /Demo</tt> parameter indicates that we want to build a demo application that expects its URIs to begin with <tt>/Demo</tt>. The final argument <tt>demo</tt> gives the path to a directory housing Ur/Web source files (<tt>.ur</tt>, <tt>.urp</tt>, <tt>.urs</tt>, etc.). +<p>The <tt>-dbms sqlite</tt> flag indicates that instead of using the default database management system (<a target="_top" href="https://www.postgresql.org/">PostgreSQL</a>), we wish to use <a target="_top" href="https://sqlite.org/">SQLite</a> (usually unsuited for production). The <tt>-db</tt> flag allows us to specify the file-system path to our SQLite database. The <tt>-demo /Demo</tt> parameter indicates that we want to build a demo application that expects its URIs to begin with <tt>/Demo</tt>, while the <tt>-noEmacs</tt> parameter disables invocation of Emacs to syntax-highlight source files for HTML rendering. The final argument <tt>demo</tt> gives the path to a directory housing Ur/Web source files (<tt>.ur</tt>, <tt>.urp</tt>, <tt>.urs</tt>, etc.). </p> <p> @@ -88,7 +88,7 @@ hello.urp <p>We must, of course, begin with "Hello World."</p> -<p>The project file justs list one filename prefix, <tt>hello</tt>. This causes both <tt>hello.urs</tt> and <tt>hello.ur</tt> to be pulled into the project. <tt>.urs</tt> files are like <a href="http://caml.inria.fr/ocaml/">OCaml</a> <tt>.mli</tt> files, and <tt>.ur</tt> files are like OCaml <tt>.ml</tt> files. That is, <tt>.urs</tt> files provide interfaces, and <tt>.ur</tt> files provide implementations. <tt>.urs</tt> files may be omitted for <tt>.ur</tt> files, in which case most permissive interfaces are inferred.</p> +<p>The project file justs list one filename prefix, <tt>hello</tt>. This causes both <tt>hello.urs</tt> and <tt>hello.ur</tt> to be pulled into the project. <tt>.urs</tt> files are like <a target="_top" href="http://caml.inria.fr/ocaml/">OCaml</a> <tt>.mli</tt> files, and <tt>.ur</tt> files are like OCaml <tt>.ml</tt> files. That is, <tt>.urs</tt> files provide interfaces, and <tt>.ur</tt> files provide implementations. <tt>.urs</tt> files may be omitted for <tt>.ur</tt> files, in which case most permissive interfaces are inferred.</p> <p>Ur/Web features a module system very similar to those found in SML and OCaml. Like in OCaml, interface files are treated as module system signatures, and they are ascribed to structures built from implementation files. <tt>hello.urs</tt> tells us that we only export a function named <tt>main</tt>, taking no arguments and running a transaction that results in an HTML page. <tt>transaction</tt> is a monad in the spirit of the Haskell IO monad, with the intent that every operation performable in <tt>transaction</tt> can be undone. By design, Ur/Web does not provide a less constrained way of running side-effecting actions. This particular example application will employ no side effects, but the compiler requires that all pages be generated by transactions.</p> @@ -114,7 +114,7 @@ form.urp nested.urp -<p>Here is an implementation of the tiny challenge problem from <a href="http://www.accursoft.co.uk/web/">this web framework comparison</a>. Using nested function definitions, it is easy to persist state across clicks.</p> +<p>Here is an implementation of the tiny challenge problem from <a target="_top" href="http://www.accursoft.co.uk/web/">this web framework comparison</a>. Using nested function definitions, it is easy to persist state across clicks.</p> cookie.urp @@ -207,7 +207,7 @@ view.urp cookieSec.urp -<p>Ur/Web guarantees that compiled applications are immune to certain kinds of <a href="http://www.owasp.org/index.php/Top_10_2007-A5">cross site request forgery</a>. For instance, a "phisher" might send many e-mails linking to a form that he has set up to look like your web site. The form is connected to your web site, where it might, say, transfer money from your bank account to the phisher's account. The phisher doesn't know your username, but, if that username is stored in a cookie, it will be sent automatically by your browser. Ur/Web automatically signs cookie values cryptographically, with the signature included as a POST parameter and not part of a cookie, to prevent such attacks.</p> +<p>Ur/Web guarantees that compiled applications are immune to certain kinds of <a target="_top" href="http://www.owasp.org/index.php/Top_10_2007-A5">cross site request forgery</a>. For instance, a "phisher" might send many e-mails linking to a form that he has set up to look like your web site. The form is connected to your web site, where it might, say, transfer money from your bank account to the phisher's account. The phisher doesn't know your username, but, if that username is stored in a cookie, it will be sent automatically by your browser. Ur/Web automatically signs cookie values cryptographically, with the signature included as a POST parameter and not part of a cookie, to prevent such attacks.</p> <p>This demo shows a simple mock-up of a situation where such an attack is often possible with traditional web frameworks. You can set an arbitrary username for yourself in a cookie, and you can modify the database in a way that depends on the current cookie value. Try getting the latter action to succeed without first setting your desired username in the cookie. This should be roughly as impossible as cracking the particular cryptographic hash function that is used.</p> diff --git a/doc/manual.tex b/doc/manual.tex index eaf7aab5..857539db 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -150,6 +150,8 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{effectful Module.ident} registers an FFI function or transaction as having side effects. The optimizer avoids removing, moving, or duplicating calls to such functions. This is the default behavior for \texttt{transaction}-based types. \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{file URI FILENAME MIME-TYPE} works like the simpler form of \texttt{file}, but the proper MIME type for the file is given directly. +\item \texttt{filecache PATH} sets a path to a directory to use for caching files stored in the SQL database. It can be expensive to schlep files back and forth between the database and an Ur/Web application, since database engines don't tend to be optimized for transferring large files. Ur/Web will still store the files in the database, as the ``version of record'' for your whole, consistent data set, but the application will try to query the database only in terms of cryptographic hashes, from which files can be retrieved from the cache. (This feature is currently only available for PostgreSQL, with the module \texttt{pgcrypto} installed, to drive SHA512 hashing. It would defeat the purpose to run the hashing operation in the application rather than the database engine!) \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} 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. @@ -176,6 +178,7 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \end{itemize} \item \texttt{link FILENAME} adds \texttt{FILENAME} to the list of files to be passed to the linker at the end of compilation. This is most useful for importing extra libraries needed by new FFI modules. \item \texttt{linker CMD} sets \texttt{CMD} as the command line prefix to use for linking C object files. The command line will be completed with a space-separated list of \texttt{.o} and \texttt{.a} files, \texttt{-L} and \texttt{-l} flags, and finally with a \texttt{-o} flag to set the location where the executable should be written. +\item \texttt{mimeTypes PATH} sets the name of the file from which the MIME-type database is read, as a substitute for the usual \texttt{/etc/mime.types} on UNIX systems. \item \texttt{minHeap NUMBYTES} sets the initial size for thread-local heaps used in handling requests. These heaps grow automatically as needed (up to any maximum set with \texttt{limit}), but each regrow requires restarting the request handling process. \item \texttt{monoInline TREESIZE} sets how many nodes the AST of a function definition may have before the optimizer stops trying hard to inline calls to that function. (This is one of two options for one of two intermediate languages within the compiler.) \item \texttt{neverInline PATH} requests that no call to the referenced function be inlined. Section \ref{structure} explains how functions are assigned path strings. @@ -2235,7 +2238,7 @@ $$\begin{array}{l} \subsubsection{Asynchronous Message-Passing} -To support asynchronous, ``server push'' delivery of messages to clients, any client that might need to receive an asynchronous message is assigned a unique ID. These IDs may be retrieved both on the client and on the server, during execution of code related to a client. +To support asynchronous, ``server push'' delivery of messages to clients, any client that might need to receive an asynchronous message is assigned a unique ID. These IDs may be retrieved only on the server, during execution of code related to a client. $$\begin{array}{l} \mt{type} \; \mt{client} \\ diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h index 2fa473ac..0c546d1c 100644 --- a/include/urweb/types_cpp.h +++ b/include/urweb/types_cpp.h @@ -105,6 +105,7 @@ typedef struct { uw_Basis_string time_format; int is_html5; + char *file_cache; } uw_app; typedef struct { diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 0d5f5e0e..5f1144b8 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -358,8 +358,6 @@ uw_Basis_string uw_Basis_timef(struct uw_context *, const char *fmt, uw_Basis_ti uw_Basis_time uw_Basis_stringToTimef(struct uw_context *, const char *fmt, uw_Basis_string); uw_Basis_time uw_Basis_stringToTimef_error(struct uw_context *, const char *fmt, uw_Basis_string); -uw_Basis_string uw_Basis_crypt(struct uw_context *, uw_Basis_string key, uw_Basis_string salt); - uw_Basis_bool uw_Basis_eq_time(struct uw_context *, uw_Basis_time, uw_Basis_time); uw_Basis_bool uw_Basis_lt_time(struct uw_context *, uw_Basis_time, uw_Basis_time); uw_Basis_bool uw_Basis_le_time(struct uw_context *, uw_Basis_time, uw_Basis_time); @@ -432,4 +430,8 @@ void *uw_Sqlcache_flush(struct uw_context *, uw_Sqlcache_Cache *, char **); int strcmp_nullsafe(const char *, const char *); +uw_unit uw_Basis_cache_file(struct uw_context *, uw_Basis_blob contents); +uw_Basis_blob uw_Basis_check_filecache(struct uw_context *, uw_Basis_string hash); +uw_Basis_bool uw_Basis_filecache_missed(struct uw_context *); + #endif diff --git a/lib/js/urweb.js b/lib/js/urweb.js index ebe192ca..99b45ec9 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1205,6 +1205,19 @@ function time(s, name) { return inpt("time", s, name); } +function crad(s) { + if (suspendScripts) + return; + + var x = input(document.createElement("input"), s, + function(x) { return function(v) { x.checked = (x.value === v); }; }, "radio"); + x.onclick = x.onkeyup = x.oninput = x.onchange = x.onpropertychange = function() { sv(s, x.value) }; + setTimeout(function() { + x.defaultChecked = x.checked = (s.data === x.value); + }, 10); + + return x; +} function selectValue(x) { if (x.options.length == 0) @@ -1286,11 +1299,12 @@ function dynClass(pnode, html, s_class, s_style) { if (pnode == "table" && html.tagName == "TBODY") { html = html.firstChild; } - addNode(html); - runScripts(html); + + var x = null; + var y = null; if (s_class) { - var x = document.createElement("script"); + x = document.createElement("script"); x.dead = false; x.signal = s_class; x.sources = null; @@ -1305,13 +1319,12 @@ function dynClass(pnode, html, s_class, s_style) { x.closures = concat(cls.v, htmlCls); } - html.appendChild(x); populate(x); } if (s_style) { var htmlCls2 = s_class ? null : htmlCls; - var y = document.createElement("script"); + y = document.createElement("script"); y.dead = false; y.signal = s_style; y.sources = null; @@ -1326,9 +1339,16 @@ function dynClass(pnode, html, s_class, s_style) { y.closures = concat(cls.v, htmlCls2); } - html.appendChild(y); populate(y); } + + addNode(html); + runScripts(html); + + if (x) + html.appendChild(x); + if (y) + html.appendChild(y); } function bodyDynClass(s_class, s_style) { @@ -1389,6 +1409,14 @@ function addOnChange(x, f) { x.onchange = function() { old(); f(); }; } +function addOnInput(x, f) { + var old = x.oninput; + if (old == null) + x.oninput = f; + else + x.oninput = function() { old(); f(); }; +} + function addOnKeyUp(x, f) { var old = x.onkeyup; if (old == null) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 89a48d59..66cc0e50 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -192,11 +192,6 @@ val datetimeSecond : time -> int val datetimeDayOfWeek : time -> int -(** * Encryption *) - -val crypt : string -> string -> string - - (** HTTP operations *) con http_cookie :: Type -> Type @@ -830,7 +825,7 @@ val data_attrs : data_attr -> data_attr -> data_attr val head : unit -> tag [Data = data_attr] html head [] [] val title : unit -> tag [Data = data_attr] head [] [] [] -val link : unit -> tag [Data = data_attr, Id = id, Rel = string, Typ = string, Href = url, Media = string, Integrity = string, Crossorigin = string] head [] [] [] +val link : unit -> tag [Data = data_attr, Id = id, Rel = string, Title = string, Typ = string, Href = url, Media = string, Integrity = string, Crossorigin = string, Sizes = string] head [] [] [] val meta : unit -> tag [Nam = meta, Content = string, Id = id] head [] [] [] datatype mouseButton = Left | Right | Middle @@ -842,14 +837,26 @@ type mouseEvent = { ScreenX : int, ScreenY : int, ClientX : int, ClientY : int, con mouseEvents = map (fn _ :: Unit => mouseEvent -> transaction unit) [Onclick, Oncontextmenu, Ondblclick, Onmousedown, Onmouseenter, Onmouseleave, Onmousemove, Onmouseout, Onmouseover, Onmouseup] +(* Key arguments are character codes. *) type keyEvent = { KeyCode : int, CtrlKey : bool, ShiftKey : bool, AltKey : bool, MetaKey : bool } con keyEvents = map (fn _ :: Unit => keyEvent -> transaction unit) [Onkeydown, Onkeypress, Onkeyup] -val body : unit -> tag ([Data = data_attr, Onload = transaction unit, Onresize = transaction unit, Onunload = transaction unit, Onhashchange = transaction unit] - ++ mouseEvents ++ keyEvents) +con focusEvents = [Onblur = transaction unit, Onfocus = transaction unit] + +con resizeEvents = [Onresize = transaction unit] +con scrollEvents = [Onscroll = transaction unit] + +con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents ++ scrollEvents +con tableEvents = focusEvents ++ mouseEvents ++ keyEvents + +con boxAttrs = [Data = data_attr, Id = id, Title = string, Role = string, Align = string] ++ boxEvents +con tableAttrs = [Data = data_attr, Id = id, Title = string, Align = string] ++ tableEvents + +val body : unit -> tag ([Data = data_attr, Id = id, Title = string, Onload = transaction unit, Onunload = transaction unit, Onhashchange = transaction unit] + ++ boxEvents) html body [] [] con bodyTag = fn (attrs :: {Type}) => @@ -863,19 +870,6 @@ con bodyTagStandalone = fn (attrs :: {Type}) => val br : bodyTagStandalone [Data = data_attr, Id = id] -con focusEvents = [Onblur = transaction unit, Onfocus = transaction unit] - - -(* Key arguments are character codes. *) -con resizeEvents = [Onresize = transaction unit] -con scrollEvents = [Onscroll = transaction unit] - -con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents ++ scrollEvents -con tableEvents = focusEvents ++ mouseEvents ++ keyEvents - -con boxAttrs = [Data = data_attr, Id = id, Title = string, Role = string, Align = string] ++ boxEvents -con tableAttrs = [Data = data_attr, Id = id, Title = string, Align = string] ++ tableEvents - val span : bodyTag boxAttrs val div : bodyTag boxAttrs @@ -975,21 +969,20 @@ con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => nm :: Name -> unit -> tag attrs ([Form] ++ ctx) inner [] [nm = ty] -con inputAttrs = [Required = bool, Autofocus = bool] - +con inputAttrs' = [Required = bool, Autofocus = bool, + Onchange = transaction unit] +con inputAttrs = inputAttrs' ++ [Oninput = transaction unit] val hidden : formTag string [] [Data = data_attr, Id = string, Value = string] -val textbox : formTag string [] ([Value = string, Size = int, Placeholder = string, Source = source string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) -val password : formTag string [] ([Value = string, Size = int, Placeholder = string, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val textarea : formTag string [] ([Rows = int, Cols = int, Placeholder = string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) +val textbox : formTag string [] ([Value = string, Size = int, Placeholder = string, Source = source string] ++ boxAttrs ++ inputAttrs) +val password : formTag string [] ([Value = string, Size = int, Placeholder = string] ++ boxAttrs ++ inputAttrs) +val textarea : formTag string [] ([Rows = int, Cols = int, Placeholder = string] ++ boxAttrs ++ inputAttrs) -val checkbox : formTag bool [] ([Checked = bool, Onchange = transaction unit] ++ boxAttrs) +val checkbox : formTag bool [] ([Checked = bool] ++ boxAttrs ++ inputAttrs') (* HTML5 widgets galore! *) -type textWidget = formTag string [] ([Value = string, Size = int, Placeholder = string, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) +type textWidget = formTag string [] ([Value = string, Size = int, Placeholder = string] ++ boxAttrs ++ inputAttrs) val email : textWidget val search : textWidget @@ -997,14 +990,14 @@ val url_ : textWidget val tel : textWidget val color : textWidget -val number : formTag float [] ([Value = float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val range : formTag float [] ([Value = float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val date : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val datetime : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val datetime_local : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val month : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val week : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) -val timeInput : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) +val number : formTag float [] ([Value = float, Min = float, Max = float, Step = float, Size = int] ++ boxAttrs ++ inputAttrs) +val range : formTag float [] ([Value = float, Min = float, Max = float, Size = int] ++ boxAttrs ++ inputAttrs) +val date : formTag string [] ([Value = string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) +val datetime : formTag string [] ([Value = string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) +val datetime_local : formTag string [] ([Value = string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) +val month : formTag string [] ([Value = string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) +val week : formTag string [] ([Value = string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) +val timeInput : formTag string [] ([Value = string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) @@ -1034,10 +1027,10 @@ val remainingFields : postField -> string con radio = [Body, Radio] val radio : formTag (option string) radio [Data = data_attr, Id = id] -val radioOption : unit -> tag ([Value = string, Checked = bool, Onchange = transaction unit] ++ boxAttrs) radio [] [] [] +val radioOption : unit -> tag ([Value = string, Checked = bool] ++ boxAttrs ++ inputAttrs') radio [] [] [] con select = [Select] -val select : formTag string select ([Onchange = transaction unit] ++ boxAttrs) +val select : formTag string select (boxAttrs ++ inputAttrs') val option : unit -> tag [Data = data_attr, Value = string, Selected = bool] select [] [] [] val submit : ctx ::: {Unit} -> use ::: {Type} @@ -1065,8 +1058,7 @@ con cformTag = fn (attrs :: {Type}) (inner :: {Unit}) => -> [[Body] ~ ctx] => [[Body] ~ inner] => unit -> tag attrs ([Body] ++ ctx) ([Body] ++ inner) [] [] -type ctext = cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, - Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] +type ctext = cformTag ([Value = string, Size = int, Source = source string, Placeholder = string] ++ boxAttrs ++ inputAttrs) [] val ctextbox : ctext val cpassword : ctext @@ -1076,23 +1068,25 @@ val curl : ctext val ctel : ctext val ccolor : ctext -val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] -val crange : cformTag ([Source = source (option 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 cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int] ++ boxAttrs ++ inputAttrs) [] +val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int] ++ boxAttrs ++ inputAttrs) [] +val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] +val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] +val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] +val cmonth : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] +val cweek : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] +val ctime : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val button : cformTag ([Value = string, Disabled = bool] ++ boxAttrs) [] -val ccheckbox : cformTag ([Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] +val ccheckbox : cformTag ([Size = int, Source = source bool] ++ boxAttrs ++ inputAttrs') [] + +val cradio : cformTag ([Source = source (option string), Value = string] ++ boxAttrs ++ inputAttrs') [] -val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) [Cselect] +val cselect : cformTag ([Source = source string] ++ boxAttrs ++ inputAttrs') [Cselect] val coption : unit -> tag [Value = string, Selected = bool] [Cselect, Body] [] [] [] -val ctextarea : cformTag ([Rows = int, Cols = int, Placeholder = string, Source = source string, Onchange = transaction unit, +val ctextarea : cformTag ([Rows = int, Cols = int, Placeholder = string, Source = source string, Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] (*** Tables *) diff --git a/lib/ur/json.ur b/lib/ur/json.ur index 9288a6dd..817ec16e 100644 --- a/lib/ur/json.ur +++ b/lib/ur/json.ur @@ -46,10 +46,16 @@ fun escape s = let val ch = String.sub s 0 in - (if ch = #"\"" || ch = #"\\" then - "\\" ^ String.str ch - else - String.str ch) ^ esc (String.suffix s 1) + (case ch of + #"\n" => "\\n" + | #"\r" => "\\r" + | #"\t" => "\\t" + | #"\"" => "\\\"" + | #"\'" => "\\\'" + | #"\\" => "\\\\" + | #"/" => "\\/" + | x => String.str ch + ) ^ esc (String.suffix s 1) end in "\"" ^ esc s @@ -90,7 +96,17 @@ fun unescape s = 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) + (case String.sub s (i+1) of + #"n" => "\n" + | #"r" => "\r" + | #"t" => "\t" + | #"\"" => "\"" + | #"\'" => "\'" + | #"\\" => "\\" + | #"/" => "/" + | x => error <xml>JSON unescape: Bad escape char: {[x]}</xml>) + ^ + unesc (i+2) | _ => String.str ch ^ unesc (i+1) end in diff --git a/lib/ur/list.ur b/lib/ur/list.ur index cc533676..95d6fbc8 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -204,6 +204,21 @@ fun exists [a] f = ex end +fun existsM [m] (_ : monad m) [a] f = + let + fun ex ls = + case ls of + [] => return False + | x :: ls => + b <- f x; + if b then + return True + else + ex ls + in + ex + end + fun foldlMap [a] [b] [c] f = let fun fold ls' st ls = @@ -240,6 +255,21 @@ fun find [a] f = find' end +fun findM [m] (_ : monad m) [a] f = + let + fun find' ls = + case ls of + [] => return None + | x :: ls => + b <- f x; + if b then + return (Some x) + else + find' ls + in + find' + end + fun search [a] [b] f = let fun search' ls = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index fd56679d..fe730152 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -42,6 +42,8 @@ val filter : a ::: Type -> (a -> bool) -> t a -> t a val exists : a ::: Type -> (a -> bool) -> t a -> bool +val existsM : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m bool) -> t a -> m bool + val foldlM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> b -> m b) -> b -> t a -> m b @@ -58,6 +60,8 @@ val mem : a ::: Type -> eq a -> a -> t a -> bool val find : a ::: Type -> (a -> bool) -> t a -> option a +val findM : m ::: (Type -> Type) -> monad m -> a ::: Type -> (a -> m bool) -> t a -> m (option a) + val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b val all : a ::: Type -> (a -> bool) -> t a -> bool diff --git a/src/c/Makefile.am b/src/c/Makefile.am index f4d9bef8..58f5153c 100644 --- a/src/c/Makefile.am +++ b/src/c/Makefile.am @@ -7,7 +7,7 @@ liburweb_fastcgi_la_SOURCES = fastcgi.c fastcgi.h 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) +AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecated-declarations -U_FORTIFY_SOURCE $(PTHREAD_CFLAGS) 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) diff --git a/src/c/cgi.c b/src/c/cgi.c index d060532c..4d0f82b0 100644 --- a/src/c/cgi.c +++ b/src/c/cgi.c @@ -17,6 +17,8 @@ static char *uppercased; static size_t uppercased_len; static char *get_header(void *data, const char *h) { + (void)data; + size_t len = strlen(h); char *s, *r; const char *saved_h = h; @@ -41,16 +43,21 @@ static char *get_header(void *data, const char *h) { } static char *get_env(void *data, const char *name) { + (void)data; return getenv(name); } -static void on_success(uw_context ctx) { } +static void on_success(uw_context ctx) { + (void)ctx; +} static void on_failure(uw_context ctx) { uw_write_header(ctx, "Status: 500 Internal Server Error\r\n"); } static void log_error(void *data, const char *fmt, ...) { + (void)data; + va_list ap; va_start(ap, fmt); @@ -58,11 +65,16 @@ static void log_error(void *data, const char *fmt, ...) { } static void log_debug(void *data, const char *fmt, ...) { + (void)data; + (void)fmt; } static uw_loggers ls = {NULL, log_error, log_debug}; int main(int argc, char *argv[]) { + (void)argc; + (void)argv; + uw_context ctx = uw_request_new_context(0, &uw_application, &ls); uw_request_context rc = uw_new_request_context(); request_result rr; @@ -130,12 +142,17 @@ void *uw_init_client_data() { } void uw_free_client_data(void *data) { + (void)data; } void uw_copy_client_data(void *dst, void *src) { + (void)dst; + (void)src; } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + (void)data; + uw_ensure_transaction(ctx); uw_get_app(ctx)->expunger(ctx, cli); @@ -144,6 +161,8 @@ void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { } void uw_post_expunge(uw_context ctx, void *data) { + (void)ctx; + (void)data; } int uw_supports_direct_status = 0; diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c index c37debf7..196b3d51 100644 --- a/src/c/fastcgi.c +++ b/src/c/fastcgi.c @@ -127,7 +127,9 @@ static FCGI_Record *fastcgi_recv(FCGI_Input *i) { } } -static void on_success(uw_context ctx) { } +static void on_success(uw_context ctx) { + (void)ctx; +} static void on_failure(uw_context ctx) { uw_write_header(ctx, "Status: 500 Internal Server Error\r\n"); @@ -554,6 +556,7 @@ static void help(char *cmd) { } static void sigint(int signum) { + (void)signum; printf("Exiting....\n"); exit(0); } @@ -674,12 +677,17 @@ void *uw_init_client_data() { } void uw_free_client_data(void *data) { + (void)data; } void uw_copy_client_data(void *dst, void *src) { + (void)dst; + (void)src; } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + (void)data; + uw_ensure_transaction(ctx); uw_get_app(ctx)->expunger(ctx, cli); @@ -688,6 +696,8 @@ void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { } void uw_post_expunge(uw_context ctx, void *data) { + (void)ctx; + (void)data; } int uw_supports_direct_status = 0; diff --git a/src/c/http.c b/src/c/http.c index 21ad809f..72685508 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -46,6 +46,7 @@ static char *get_header(void *data, const char *h) { } static char *get_env(void *data, const char *name) { + (void)data; return getenv(name); } @@ -58,6 +59,8 @@ static void on_failure(uw_context ctx) { } static void log_error(void *data, const char *fmt, ...) { + (void)data; + va_list ap; va_start(ap, fmt); @@ -65,6 +68,8 @@ static void log_error(void *data, const char *fmt, ...) { } static void log_debug(void *data, const char *fmt, ...) { + (void)data; + if (!quiet) { va_list ap; va_start(ap, fmt); @@ -332,6 +337,7 @@ static void help(char *cmd) { } static void sigint(int signum) { + (void)signum; printf("Exiting....\n"); exit(0); } @@ -542,12 +548,17 @@ void *uw_init_client_data() { } void uw_free_client_data(void *data) { + (void)data; } void uw_copy_client_data(void *dst, void *src) { + (void)dst; + (void)src; } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + (void)data; + uw_ensure_transaction(ctx); uw_get_app(ctx)->expunger(ctx, cli); @@ -556,6 +567,8 @@ void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { } void uw_post_expunge(uw_context ctx, void *data) { + (void)ctx; + (void)data; } int uw_supports_direct_status = 1; diff --git a/src/c/request.c b/src/c/request.c index a7f23851..3e7ac34c 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -78,6 +78,8 @@ uw_context uw_request_new_context(int id, uw_app *app, uw_loggers *ls) { } static void *ticker(void *data) { + (void)data; + while (1) { usleep(100000); ++uw_time; @@ -133,6 +135,8 @@ static unsigned long long stackSize; int pthread_create_big(pthread_t *outThread, void *foo, void *threadFunc, void *arg) { + (void)foo; + if (stackSize > 0) { int err; pthread_attr_t stackSizeAttribute; diff --git a/src/c/static.c b/src/c/static.c index d70881e2..76fe4129 100644 --- a/src/c/static.c +++ b/src/c/static.c @@ -8,6 +8,8 @@ extern uw_app uw_application; static void log_(void *data, const char *fmt, ...) { + (void)data; + va_list ap; va_start(ap, fmt); @@ -17,6 +19,8 @@ static void log_(void *data, const char *fmt, ...) { static uw_loggers loggers = {NULL, log_, log_}; static char *get_header(void *data, const char *h) { + (void)data; + (void)h; return NULL; } @@ -56,15 +60,23 @@ void *uw_init_client_data() { } void uw_free_client_data(void *data) { + (void)data; } void uw_copy_client_data(void *dst, void *src) { + (void)dst; + (void)src; } void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) { + (void)ctx; + (void)cli; + (void)data; } void uw_post_expunge(uw_context ctx, void *data) { + (void)ctx; + (void)data; } int uw_supports_direct_status = 0; diff --git a/src/c/urweb.c b/src/c/urweb.c index 6f2dde38..e7efae38 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -13,8 +13,8 @@ #include <stdint.h> #include <sys/types.h> #include <sys/socket.h> -#include <openssl/des.h> #include <openssl/rand.h> +#include <openssl/sha.h> #include <time.h> #include <math.h> @@ -514,6 +514,11 @@ struct uw_context { uw_Sqlcache_Unlock *cacheUnlock; int remoteSock; + + int file_cache_missed; + // Set if we are recovering from a miss in the file cache in handling an SQL + // query that only returns hashes of files. If so, this time around we will + // run queries to return actual file contents instead. }; size_t uw_headers_max = SIZE_MAX; @@ -608,6 +613,8 @@ uw_context uw_init(int id, uw_loggers *lg) { ctx->cacheUnlock = NULL; + ctx->file_cache_missed = 0; + return ctx; } @@ -1519,6 +1526,7 @@ uw_Basis_string uw_Basis_maybe_onunload(uw_context ctx, uw_Basis_string s) { } const char *uw_Basis_get_settings(uw_context ctx, uw_unit u) { + (void)u; if (ctx->client == NULL) { if (ctx->needs_sig) { char *sig = ctx->app->cookie_sig(ctx); @@ -1847,6 +1855,7 @@ char *uw_Basis_attrifyChar(uw_context ctx, uw_Basis_char c) { } char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) { + (void)ctx; return s; } @@ -1973,6 +1982,7 @@ char *uw_Basis_urlifyString(uw_context ctx, uw_Basis_string s) { } char *uw_Basis_urlifyBool(uw_context ctx, uw_Basis_bool b) { + (void)ctx; if (b == uw_Basis_False) return "0"; else @@ -2093,6 +2103,8 @@ static char *uw_unurlify_advance(char *s) { } uw_Basis_int uw_Basis_unurlifyInt(uw_context ctx, char **s) { + (void)ctx; + char *new_s = uw_unurlify_advance(*s); uw_Basis_int r; @@ -2102,6 +2114,8 @@ uw_Basis_int uw_Basis_unurlifyInt(uw_context ctx, char **s) { } uw_Basis_float uw_Basis_unurlifyFloat(uw_context ctx, char **s) { + (void)ctx; + char *new_s = uw_unurlify_advance(*s); uw_Basis_float r; @@ -2165,6 +2179,8 @@ static uw_Basis_string uw_unurlifyString_to(int fromClient, uw_context ctx, char } uw_Basis_bool uw_Basis_unurlifyBool(uw_context ctx, char **s) { + (void)ctx; + char *new_s = uw_unurlify_advance(*s); uw_Basis_bool r; @@ -2192,6 +2208,7 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context ctx, char **s) { } uw_Basis_unit uw_Basis_unurlifyUnit(uw_context ctx, char **s) { + (void)ctx; *s = uw_unurlify_advance(*s); return uw_unit_v; } @@ -2345,6 +2362,7 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { } uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) { + (void)ctx; if (b == uw_Basis_False) return "False"; else @@ -2428,10 +2446,13 @@ uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_i } uw_Basis_int uw_Basis_strlen(uw_context ctx, uw_Basis_string s) { + (void)ctx; return strlen(s); } uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int n) { + (void)ctx; + while (n > 0) { if (*s == 0) return uw_Basis_False; @@ -2444,10 +2465,12 @@ uw_Basis_bool uw_Basis_strlenGe(uw_context ctx, uw_Basis_string s, uw_Basis_int } uw_Basis_string uw_Basis_strchr(uw_context ctx, uw_Basis_string s, uw_Basis_char ch) { + (void)ctx; return strchr(s, ch); } uw_Basis_int uw_Basis_strcspn(uw_context ctx, uw_Basis_string s, uw_Basis_string chs) { + (void)ctx; return strcspn(s, chs); } @@ -2794,6 +2817,7 @@ uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) { } char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) { + (void)ctx; if (b == uw_Basis_False) return "FALSE"; else @@ -2914,6 +2938,7 @@ uw_Basis_string uw_Basis_charToString(uw_context ctx, uw_Basis_char ch) { } uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) { + (void)ctx; if (b == uw_Basis_False) return "False"; else @@ -2979,6 +3004,7 @@ uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) { } uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) { + (void)ctx; static uw_Basis_bool true = uw_Basis_True; static uw_Basis_bool false = uw_Basis_False; @@ -3353,6 +3379,8 @@ static delta *allocate_delta(uw_context ctx, unsigned client) { } uw_Basis_channel uw_Basis_new_channel(uw_context ctx, uw_unit u) { + (void)u; + if (ctx->client == NULL) uw_error(ctx, FATAL, "Attempt to create channel on request not associated with a persistent connection"); @@ -3622,6 +3650,8 @@ int uw_commit(uw_context ctx) { } } + ctx->file_cache_missed = 0; + return 0; } @@ -3929,37 +3959,45 @@ int uw_streq(uw_Basis_string s1, uw_Basis_string s2) { } uw_Basis_string uw_Basis_sigString(uw_context ctx, uw_unit u) { + (void)u; ctx->usedSig = 1; return ctx->app->cookie_sig(ctx); } uw_Basis_string uw_Basis_fileName(uw_context ctx, uw_Basis_file f) { + (void)ctx; return f.name; } uw_Basis_string uw_Basis_fileMimeType(uw_context ctx, uw_Basis_file f) { + (void)ctx; return f.type; } uw_Basis_int uw_Basis_blobSize(uw_context ctx, uw_Basis_blob b) { + (void)ctx; return b.size; } uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { + (void)ctx; uw_Basis_blob b = {strlen(s), s}; return b; } uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { + (void)ctx; return f.data; } uw_Basis_string uw_Basis_postType(uw_context ctx, uw_Basis_postBody pb) { + (void)ctx; return pb.type; } uw_Basis_string uw_Basis_postData(uw_context ctx, uw_Basis_postBody pb) { + (void)ctx; return pb.data; } @@ -4156,24 +4194,29 @@ uw_Basis_string uw_Basis_mstrcat(uw_context ctx, ...) { const uw_Basis_time uw_Basis_minTime = {}; uw_Basis_time uw_Basis_now(uw_context ctx) { + (void)ctx; uw_Basis_time r = { time(NULL) }; return r; } uw_Basis_time uw_Basis_addSeconds(uw_context ctx, uw_Basis_time tm, uw_Basis_int n) { + (void)ctx; tm.seconds += n; return tm; } uw_Basis_int uw_Basis_diffInSeconds(uw_context ctx, uw_Basis_time tm1, uw_Basis_time tm2) { + (void)ctx; return difftime(tm2.seconds, tm1.seconds); } uw_Basis_int uw_Basis_toMilliseconds(uw_context ctx, uw_Basis_time tm) { + (void)ctx; return tm.seconds * 1000 + tm.microseconds / 1000; } uw_Basis_time uw_Basis_fromMilliseconds(uw_context ctx, uw_Basis_int n) { + (void)ctx; uw_Basis_time tm = {n / 1000, n % 1000 * 1000}; return tm; } @@ -4183,10 +4226,12 @@ uw_Basis_int uw_Basis_diffInMilliseconds(uw_context ctx, uw_Basis_time tm1, uw_B } uw_Basis_int uw_Basis_toSeconds(uw_context ctx, uw_Basis_time tm) { + (void)ctx; return tm.seconds; } uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_int month, uw_Basis_int day, uw_Basis_int hour, uw_Basis_int minute, uw_Basis_int second) { + (void)ctx; struct tm tm = { .tm_year = year - 1900, .tm_mon = month, .tm_mday = day, .tm_hour = hour, .tm_min = minute, .tm_sec = second, .tm_isdst = -1 }; @@ -4195,42 +4240,49 @@ uw_Basis_time uw_Basis_fromDatetime(uw_context ctx, uw_Basis_int year, uw_Basis_ } uw_Basis_int uw_Basis_datetimeYear(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_year + 1900; } uw_Basis_int uw_Basis_datetimeMonth(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_mon; } uw_Basis_int uw_Basis_datetimeDay(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_mday; } uw_Basis_int uw_Basis_datetimeHour(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_hour; } uw_Basis_int uw_Basis_datetimeMinute(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_min; } uw_Basis_int uw_Basis_datetimeSecond(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_sec; } uw_Basis_int uw_Basis_datetimeDayOfWeek(uw_context ctx, uw_Basis_time time) { + (void)ctx; struct tm tm; localtime_r(&time.seconds, &tm); return tm.tm_wday; @@ -4272,66 +4324,82 @@ void uw_set_global(uw_context ctx, char *name, void *data, void (*free)(void*)) } uw_Basis_bool uw_Basis_isalnum(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isalnum((int)c); } uw_Basis_bool uw_Basis_isalpha(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isalpha((int)c); } uw_Basis_bool uw_Basis_isblank(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isblank((int)c); } uw_Basis_bool uw_Basis_iscntrl(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!iscntrl((int)c); } uw_Basis_bool uw_Basis_isdigit(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isdigit((int)c); } uw_Basis_bool uw_Basis_isgraph(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isgraph((int)c); } uw_Basis_bool uw_Basis_islower(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!islower((int)c); } uw_Basis_bool uw_Basis_isprint(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isprint((int)c); } uw_Basis_bool uw_Basis_ispunct(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!ispunct((int)c); } uw_Basis_bool uw_Basis_isspace(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isspace((int)c); } uw_Basis_bool uw_Basis_isupper(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isupper((int)c); } uw_Basis_bool uw_Basis_isxdigit(uw_context ctx, uw_Basis_char c) { + (void)ctx; return !!isxdigit((int)c); } uw_Basis_char uw_Basis_tolower(uw_context ctx, uw_Basis_char c) { + (void)ctx; return tolower((int)c); } uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) { + (void)ctx; return toupper((int)c); } uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) { + (void)ctx; return (unsigned char)c; } uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) { + (void)ctx; return n; } @@ -4431,16 +4499,13 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) { return r; } -uw_Basis_string uw_Basis_crypt(uw_context ctx, uw_Basis_string key, uw_Basis_string salt) { - char buf[14]; - return uw_strdup(ctx, DES_fcrypt(key, salt, buf)); -} - uw_Basis_bool uw_Basis_eq_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) { + (void)ctx; return !!(t1.seconds == t2.seconds && t1.microseconds == t2.microseconds); } uw_Basis_bool uw_Basis_lt_time(uw_context ctx, uw_Basis_time t1, uw_Basis_time t2) { + (void)ctx; return !!(t1.seconds < t2.seconds || (t1.seconds == t2.seconds && t1.microseconds < t2.microseconds)); } @@ -4505,66 +4570,82 @@ uw_Basis_string uw_Basis_fresh(uw_context ctx) { } uw_Basis_float uw_Basis_floatFromInt(uw_context ctx, uw_Basis_int n) { + (void)ctx; return n; } uw_Basis_int uw_Basis_ceil(uw_context ctx, uw_Basis_float n) { + (void)ctx; return ceil(n); } uw_Basis_int uw_Basis_trunc(uw_context ctx, uw_Basis_float n) { + (void)ctx; return trunc(n); } uw_Basis_int uw_Basis_round(uw_context ctx, uw_Basis_float n) { + (void)ctx; return round(n); } uw_Basis_int uw_Basis_floor(uw_context ctx, uw_Basis_float n) { + (void)ctx; return floor(n); } uw_Basis_float uw_Basis_pow(uw_context ctx, uw_Basis_float n, uw_Basis_float m) { + (void)ctx; return pow(n,m); } uw_Basis_float uw_Basis_sqrt(uw_context ctx, uw_Basis_float n) { + (void)ctx; return sqrt(n); } uw_Basis_float uw_Basis_sin(uw_context ctx, uw_Basis_float n) { + (void)ctx; return sin(n); } uw_Basis_float uw_Basis_cos(uw_context ctx, uw_Basis_float n) { + (void)ctx; return cos(n); } uw_Basis_float uw_Basis_log(uw_context ctx, uw_Basis_float n) { + (void)ctx; return log(n); } uw_Basis_float uw_Basis_exp(uw_context ctx, uw_Basis_float n) { + (void)ctx; return exp(n); } uw_Basis_float uw_Basis_asin(uw_context ctx, uw_Basis_float n) { + (void)ctx; return asin(n); } uw_Basis_float uw_Basis_acos(uw_context ctx, uw_Basis_float n) { + (void)ctx; return acos(n); } uw_Basis_float uw_Basis_atan(uw_context ctx, uw_Basis_float n) { + (void)ctx; return atan(n); } uw_Basis_float uw_Basis_atan2(uw_context ctx, uw_Basis_float n, uw_Basis_float m) { + (void)ctx; return atan2(n, m); } uw_Basis_float uw_Basis_abs(uw_context ctx, uw_Basis_float n) { + (void)ctx; return fabs(n); } @@ -4612,14 +4693,17 @@ uw_Basis_string uw_Basis_property(uw_context ctx, uw_Basis_string s) { } uw_Basis_string uw_Basis_fieldName(uw_context ctx, uw_Basis_postField f) { + (void)ctx; return f.name; } uw_Basis_string uw_Basis_fieldValue(uw_context ctx, uw_Basis_postField f) { + (void)ctx; return f.value; } uw_Basis_string uw_Basis_remainingFields(uw_context ctx, uw_Basis_postField f) { + (void)ctx; return f.remaining; } @@ -4754,6 +4838,7 @@ static char *uw_Sqlcache_keyCopy(char *buf, char *key) { // The NUL-terminated prefix of [key] below always looks something like "_k1_k2_k3..._kn". uw_Sqlcache_Value *uw_Sqlcache_check(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) { + (void)ctx; int doBump = random() % 1024 == 0; if (doBump) { pthread_rwlock_wrlock(&cache->lockIn); @@ -4836,6 +4921,8 @@ static void uw_Sqlcache_storeCommitOne(uw_Sqlcache_Cache *cache, char **keys, uw } static void uw_Sqlcache_flushCommitOne(uw_Sqlcache_Cache *cache, char **keys) { + (void)cache; + (void)keys; } static void uw_Sqlcache_commit(void *data) { @@ -4854,6 +4941,7 @@ static void uw_Sqlcache_commit(void *data) { } static void uw_Sqlcache_free(void *data, int dontCare) { + (void)dontCare; uw_context ctx = (uw_context)data; uw_Sqlcache_Update *update = ctx->cacheUpdate; while (update) { @@ -4929,6 +5017,7 @@ void uw_Sqlcache_store(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys, uw } void uw_Sqlcache_flush(uw_context ctx, uw_Sqlcache_Cache *cache, char **keys) { + (void)ctx; // A flush has to happen immediately so that subsequent stores in the same transaction fail. // This is safe to do because we will always call [uw_Sqlcache_wlock] earlier. // If the transaction fails, the only harm done is a few extra cache misses. @@ -4978,3 +5067,118 @@ int strcmp_nullsafe(const char *str1, const char *str2) { else return 1; } + +static int is_valid_hash(uw_Basis_string hash) { + for (; *hash; ++hash) + if (!isxdigit(*hash)) + return 0; + + return 1; +} + +uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) { + char *dir = ctx->app->file_cache, path[1024], tempfile[1024]; + unsigned char *res, *hash; + char *hash_encoded; + int fd, len, i; + ssize_t written_so_far = 0; + + if (!dir) + return uw_unit_v; + + hash = uw_malloc(ctx, SHA512_DIGEST_LENGTH); + res = SHA512((unsigned char *)contents.data, contents.size, hash); + if (!res) + uw_error(ctx, FATAL, "Can't hash file contents"); + + hash_encoded = uw_malloc(ctx, SHA512_DIGEST_LENGTH * 2 + 1); + for (i = 0; i < SHA512_DIGEST_LENGTH; ++i) + sprintf(hash_encoded + 2 * i, "%02x", (int)hash[i]); + hash_encoded[SHA512_DIGEST_LENGTH * 2] = 0; + + len = snprintf(tempfile, sizeof tempfile, "%s/tmpXXXXXX", dir); + if (len < 0 || len >= sizeof tempfile) + uw_error(ctx, FATAL, "Error assembling file path for cache (temporary)"); + + fd = mkstemp(tempfile); + if (fd < 0) + uw_error(ctx, FATAL, "Error creating temporary file for cache"); + + while (written_so_far < contents.size) { + ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far); + if (written_just_now <= 0) { + close(fd); + uw_error(ctx, FATAL, "Error writing all bytes to cached file"); + } + written_so_far += written_just_now; + } + + close(fd); + + len = snprintf(path, sizeof path, "%s/%s", dir, hash_encoded); + if (len < 0 || len >= sizeof path) + uw_error(ctx, FATAL, "Error assembling file path for cache"); + + if (rename(tempfile, path)) + uw_error(ctx, FATAL, "Error renaming temporary file into cache"); + + return uw_unit_v; +} + +uw_Basis_blob uw_Basis_check_filecache(uw_context ctx, uw_Basis_string hash) { + char path[1024], *dir = ctx->app->file_cache, *filedata; + int len; + long size, read_so_far = 0; + FILE *fp; + uw_Basis_blob res; + + // Hashes come formatted for printing by Postgres, which means they start with + // two extra characters. Let's remove them. + if (!hash[0] || !hash[1]) + uw_error(ctx, FATAL, "Hash to check against file cache came in not in Postgres format: %s", hash); + hash += 2; + + if (!dir) + uw_error(ctx, FATAL, "Checking file cache when no directory is set"); + + if (!is_valid_hash(hash)) + uw_error(ctx, FATAL, "Checking file cache with invalid hash %s", hash); + + len = snprintf(path, sizeof path, "%s/%s", dir, hash); + if (len < 0 || len >= sizeof path) + uw_error(ctx, FATAL, "Error assembling file path for cache"); + + fp = fopen(path, "r"); + if (!fp) { + ctx->file_cache_missed = 1; + uw_error(ctx, UNLIMITED_RETRY, "Missed in the file cache for hash %s", hash); + } + uw_push_cleanup(ctx, (void (*)(void *))fclose, fp); + + if (fseek(fp, 0L, SEEK_END)) + uw_error(ctx, FATAL, "Error seeking to end of cached file"); + + size = ftell(fp); + if (size < 0) + uw_error(ctx, FATAL, "Error getting size of cached file"); + + rewind(fp); + filedata = uw_malloc(ctx, size); + + while (read_so_far < size) { + size_t just_read = fread(filedata + read_so_far, 1, size - read_so_far, fp); + if (just_read <= 0) + uw_error(ctx, FATAL, "Error reading all bytes of cached file"); + read_so_far += just_read; + } + + uw_pop_cleanup(ctx); + + res.size = size; + res.data = filedata; + return res; +} + +uw_Basis_bool uw_Basis_filecache_missed(uw_context ctx) { + return !!(ctx->file_cache_missed); +} diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 53587ff7..87d2576c 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -482,6 +482,11 @@ fun isFile (t : typ) = TFfi ("Basis", "file") => true | _ => false +fun isString (t : typ) = + case #1 t of + TFfi ("Basis", "string") => true + | _ => false + fun p_sql_type t = string (Settings.p_sql_ctype t) fun getPargs (e, _) = @@ -654,7 +659,16 @@ fun unurlify fromClient env (t, loc) = doEm rest, string ")"] in - doEm xncs + box [string "(", + string request, + string "[0] == '/' ? ++", + string request, + string " : ", + string request, + string ",", + newline, + doEm xncs, + string ")"] end | TDatatype (Option, i, xncs) => @@ -2181,6 +2195,25 @@ and p_exp' par tail env (e, loc) = string ";"]) inputs, newline, + case Settings.getFileCache () of + NONE => box [] + | SOME _ => + p_list_sepi newline + (fn i => fn (_, t) => + case t of + Settings.Blob => + box [string "uw_Basis_cache_file(ctx, arg", + string (Int.toString (i + 1)), + string ");"] + | Settings.Nullable Settings.Blob => + box [string "if (arg", + string (Int.toString (i + 1)), + string ") uw_Basis_cache_file(ctx, arg", + string (Int.toString (i + 1)), + string ");"] + | _ => box []) + inputs, + newline, string "uw_ensure_transaction(ctx);", newline, newline, @@ -2789,7 +2822,7 @@ fun p_file env (ds, ps) = string "}"] end - fun getInput (x, t) = + fun getInput includesFile (x, t) = let val n = case SM.find (fnums, x) of NONE => raise Fail ("CjrPrint: Can't find " ^ x ^ " in fnums") @@ -2839,7 +2872,7 @@ fun p_file env (ds, ps) = xts, newline, p_list_sep (box []) (fn (x, t) => - box [getInput (x, t), + box [getInput includesFile (x, t), string "result.__uwf_", string x, space, @@ -2902,7 +2935,7 @@ fun p_file env (ds, ps) = xts, newline, p_list_sep (box []) (fn (x, t) => - box [getInput (x, t), + box [getInput includesFile (x, t), string "result->__uwf_1.__uwf_", string x, space, @@ -2955,7 +2988,10 @@ fun p_file env (ds, ps) = space, string "=", space, - unurlify true env t, + if includesFile andalso isString t then + string "request" + else + unurlify true env t, string ";", newline] end @@ -2975,6 +3011,7 @@ fun p_file env (ds, ps) = (TRecord i, _) => let val xts = E.lookupStruct env i + val includesFile = List.exists (fn (_, t) => isFile t) xts in (List.take (ts, length ts - 2), box [box (map (fn (x, t) => box [p_typ env t, @@ -2984,7 +3021,7 @@ fun p_file env (ds, ps) = string ";", newline]) xts), newline, - box (map getInput xts), + box (map (getInput includesFile) xts), case i of 0 => string "uw_unit uw_inputs;" | _ => box [string "struct __uws_", @@ -3665,7 +3702,10 @@ fun p_file env (ds, ps) = "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar", "uw_check_meta", case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics", "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"", - if Settings.getIsHtml5 () then "1" else "0"], + if Settings.getIsHtml5 () then "1" else "0", + (case Settings.getFileCache () of + NONE => "NULL" + | SOME s => "\"" ^ Prim.toCString s ^ "\"")], string "};", newline] end diff --git a/src/compiler.sig b/src/compiler.sig index 952c7070..bcf69fd4 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -60,9 +60,11 @@ signature COMPILER = sig protocol : string option, dbms : string option, sigFile : string option, + fileCache : string option, safeGets : string list, onError : (string * string list * string) option, - minHeap : int + minHeap : int, + mimeTypes : string option } val compile : string -> bool val compiler : string -> unit @@ -124,6 +126,7 @@ signature COMPILER = sig val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val sigcheck : (Mono.file, Mono.file) phase + val filecache : (Mono.file, Mono.file) phase val sqlcache : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase @@ -190,6 +193,7 @@ signature COMPILER = sig val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toSigcheck : (string, Mono.file) transform + val toFilecache : (string, Mono.file) transform val toSqlcache : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index c13de304..f724bf56 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -64,9 +64,11 @@ type job = { protocol : string option, dbms : string option, sigFile : string option, + fileCache : string option, safeGets : string list, onError : (string * string list * string) option, - minHeap : int + minHeap : int, + mimeTypes : string option } type ('src, 'dst) phase = { @@ -386,7 +388,9 @@ fun institutionalizeJob (job : job) = Settings.setSafeGets (#safeGets job); Settings.setOnError (#onError job); Settings.setMinHeap (#minHeap job); - Settings.setSigFile (#sigFile job)) + Settings.setSigFile (#sigFile job); + Settings.setFileCache (#fileCache job); + Settings.setMimeFilePath (Option.getOpt (#mimeTypes job, "/etc/mime.types"))) datatype commentableLine = EndOfFile @@ -465,9 +469,11 @@ fun parseUrp' accLibs fname = protocol = NONE, dbms = NONE, sigFile = NONE, + fileCache = NONE, safeGets = [], onError = NONE, - minHeap = 0} + minHeap = 0, + mimeTypes = NONE} in institutionalizeJob job; {Job = job, Libs = []} @@ -598,9 +604,11 @@ fun parseUrp' accLibs fname = val protocol = ref NONE val dbms = ref NONE val sigFile = ref (Settings.getSigFile ()) + val fileCache = ref (Settings.getFileCache ()) val safeGets = ref [] val onError = ref NONE val minHeap = ref 0 + val mimeTypes = ref NONE fun finish sources = let @@ -636,9 +644,11 @@ fun parseUrp' accLibs fname = protocol = !protocol, dbms = !dbms, sigFile = !sigFile, + fileCache = !fileCache, safeGets = rev (!safeGets), onError = !onError, - minHeap = !minHeap + minHeap = !minHeap, + mimeTypes = !mimeTypes } fun mergeO f (old, new) = @@ -697,9 +707,11 @@ fun parseUrp' accLibs fname = protocol = mergeO #2 (#protocol old, #protocol new), dbms = mergeO #2 (#dbms old, #dbms new), sigFile = mergeO #2 (#sigFile old, #sigFile new), + fileCache = mergeO #2 (#fileCache old, #fileCache new), safeGets = #safeGets old @ #safeGets new, onError = mergeO #2 (#onError old, #onError new), - minHeap = Int.max (#minHeap old, #minHeap new) + minHeap = Int.max (#minHeap old, #minHeap new), + mimeTypes = mergeO #2 (#mimeTypes old, #mimeTypes new) } in if accLibs then @@ -784,6 +796,10 @@ fun parseUrp' accLibs fname = (case !sigFile of NONE => sigFile := SOME arg | SOME _ => ()) + | "filecache" => + (case !fileCache of + NONE => fileCache := SOME arg + | SOME _ => ()) | "exe" => (case !exe of NONE => exe := SOME (relify arg) @@ -914,13 +930,20 @@ fun parseUrp' accLibs fname = | "html5" => Settings.setIsHtml5 true | "xhtml" => Settings.setIsHtml5 false | "lessSafeFfi" => Settings.setLessSafeFfi true + | "mimeTypes" => Settings.setMimeFilePath (relify arg) | "file" => (case String.fields Char.isSpace arg of - [uri, fname] => (Settings.setFilePath thisPath; - Settings.addFile {Uri = uri, - LoadFromFilename = fname}; - url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url) + uri :: fname :: rest => + (Settings.setFilePath thisPath; + Settings.addFile {Uri = uri, + LoadFromFilename = fname, + MimeType = case rest of + [] => NONE + | [ty] => SOME ty + | _ => (ErrorMsg.error "Bad 'file' arguments"; + NONE)}; + url := {action = Settings.Allow, kind = Settings.Exact, pattern = uri} :: !url) | _ => ErrorMsg.error "Bad 'file' arguments") | "jsFile" => @@ -1500,6 +1523,13 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck +val filecache = { + func = FileCache.instrument, + print = MonoPrint.p_file MonoEnv.empty +} + +val toFilecache = transform filecache "filecache" o toSigcheck + val sqlcache = { func = (fn file => if Settings.getSqlcache () @@ -1508,7 +1538,7 @@ val sqlcache = { print = MonoPrint.p_file MonoEnv.empty } -val toSqlcache = transform sqlcache "sqlcache" o toSigcheck +val toSqlcache = transform sqlcache "sqlcache" o toFilecache val cjrize = { func = Cjrize.cjrize, diff --git a/src/css.sml b/src/css.sml index 9e50686f..17ec01d5 100644 --- a/src/css.sml +++ b/src/css.sml @@ -104,6 +104,7 @@ val tags = [("span", inline), ("cpassword", replaced), ("button", replaced), ("ccheckbox", replaced), + ("cradio", replaced), ("cselect", replaced), ("ctextarea", replaced), ("tabl", table), diff --git a/src/demo.sml b/src/demo.sml index 62b9037a..1e58e2f8 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -123,9 +123,11 @@ fun make' {prefix, dirname, guided} = protocol = mergeWith #2 (#protocol combined, #protocol urp), dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), + fileCache = mergeWith #2 (#fileCache combined, #fileCache urp), safeGets = #safeGets combined @ #safeGets urp, onError = NONE, - minHeap = 0 + minHeap = 0, + mimeTypes = mergeWith #2 (#mimeTypes combined, #mimeTypes urp) } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") diff --git a/src/elab_env.sml b/src/elab_env.sml index 8402bcba..0474bf7c 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1663,7 +1663,7 @@ fun declBinds env (d, loc) = | DVal (x, n, t, _) => pushENamedAs env x n t | DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis | DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn - | DStr (x, n, sgn, _) => pushStrNamedAs' false env x n sgn + | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn | DFfiStr (x, n, sgn) => pushStrNamedAs' false env x n sgn | DConstraint _ => env | DExport _ => env diff --git a/src/elaborate.sml b/src/elaborate.sml index 4a04d4bf..51d00bd8 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -4046,7 +4046,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | L.PAnnot (p', _) => singleVar p' | _ => NONE in - unifyCons env loc et pt; + (unifyCons env loc et pt + handle CUnify (c1, c2, env', err) => expError env (Unify (e', c1, c2, env', err))); (case exhaustive (env, et, [p'], loc) of NONE => () diff --git a/src/filecache.sig b/src/filecache.sig new file mode 100644 index 00000000..db57135f --- /dev/null +++ b/src/filecache.sig @@ -0,0 +1,35 @@ +(* Copyright (c) 2013, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Instrument to check a cache in the file system, to reconsitute blobs without + * silly shipping over an SQL connection. *) + +signature FILE_CACHE = sig + + val instrument : Mono.file -> Mono.file + +end diff --git a/src/filecache.sml b/src/filecache.sml new file mode 100644 index 00000000..e2291c10 --- /dev/null +++ b/src/filecache.sml @@ -0,0 +1,230 @@ +(* Copyright (c) 2013, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure FileCache :> FILE_CACHE = struct + +open Mono + +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +val hasBlob = + MonoUtil.Typ.exists (fn TFfi ("Basis", "blob") => true + | _ => false) + +val unBlob = + MonoUtil.Typ.map (fn TFfi ("Basis", "blob") => TFfi ("Basis", "string") + | t => t) + +fun nodups (exps : (string * typ) list, tables : (string * (string * typ) list) list) = + let + val cols = map #1 exps @ ListUtil.mapConcat (map #1 o #2) tables + + val (_, good) = + foldl (fn (name, (names, good)) => + if SS.member(names, name) then + (names, false) + else + (SS.add (names, name), good)) (SS.empty, true) cols + in + good + end + +fun instrument file = + let + fun exp e = + case e of + EQuery {exps, tables, state, query, body, initial} => + if (List.exists (hasBlob o #2) exps + orelse List.exists (List.exists (hasBlob o #2) o #2) tables) + andalso nodups (exps, tables) then + let + val exps = ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) + exps + val tables = ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) + tables + val tables = map (fn (x, xts) => + (x, ListMergeSort.sort + (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) + xts)) tables + + val loc = #2 query + + fun wrapCol (name, t) = + case #1 t of + TFfi ("Basis", "blob") => + "DIGEST(" ^ name ^ ", 'sha512')" + | TOption t' => wrapCol (name, t') + | _ => name + + val mangle = Settings.mangleSql + + val cols = map (fn (name, t) => (mangle name, t)) exps + @ ListUtil.mapConcat (fn (_, cols) => + map (fn (name, t) => + (mangle name, + t)) cols) tables + + val prequery = + "SELECT " + ^ String.concatWith ", " (map wrapCol cols) + ^ " FROM (" + + val postquery = + ") AS Wrap" + + val wrapped_query = + (EStrcat ((EPrim (Prim.String (Prim.Normal, prequery)), loc), + (EStrcat (query, + (EPrim (Prim.String (Prim.Normal, postquery)), loc)), loc)), loc) + val wrapped_query = MonoOpt.optExp wrapped_query + + val exps' = map (fn (name, t) => (name, unBlob t)) exps + val tables' = map (fn (name, cols) => + (name, + map (fn (cname, t) => (cname, unBlob t)) cols)) tables + + val blob = (TFfi ("Basis", "blob"), loc) + val string = (TFfi ("Basis", "string"), loc) + + fun trycache (name, e, t : typ) = + (name, + case #1 t of + TFfi ("Basis", "blob") => + (EFfiApp ("Basis", + "check_filecache", + [(e, string)]), loc) + | TOption (TFfi ("Basis", "blob"), _) => + (ECase (e, + [((PNone string, loc), + (ENone blob, loc)), + ((PSome (string, (PVar ("hash", string), loc)), loc), + (ESome (blob, + (EFfiApp ("Basis", + "check_filecache", + [((ERel 0, loc), string)]), loc)), loc))], + {disc = (TOption string, loc), + result = (TOption blob, loc)}), loc) + | _ => e, + t) + + val wrapped_body_trycache = + (ELet ("uncached", + (TRecord (exps @ map (fn (name, cols) => + (name, (TRecord cols, loc))) tables), + loc), + (ERecord (map (fn (name, t) => + trycache (name, + (EField ((ERel 1, loc), + name), loc), + t)) exps + @ map (fn (tname, cols) => + (tname, + (ERecord (map (fn (name, t) => + trycache (name, + (EField ((EField ((ERel 1, loc), tname), loc), name), loc), + t)) cols), loc), + (TRecord cols, loc))) tables), loc), + MonoEnv.subExpInExp (2, (ERel 0, loc)) + + + (MonoEnv.liftExpInExp 0 body)), loc) + + fun maybeadd (e, t, acc) = + case #1 t of + TFfi ("Basis", "blob") => + (ESeq ((EFfiApp ("Basis", + "cache_file", + [(e, blob)]), loc), + acc), loc) + | TOption (TFfi ("Basis", "blob"), _) => + (ESeq ((ECase (e, + [((PNone blob, loc), + (ERecord [], loc)), + ((PSome (blob, (PVar ("blob", blob), loc)), loc), + (EFfiApp ("Basis", + "cache_file", + [((ERel 0, loc), blob)]), loc))], + {disc = t, + result = (TRecord [], loc)}), loc), + acc), loc) + | _ => acc + + val wrapped_body_addtocache = + foldl (fn ((name, t), e) => + maybeadd ((EField ((ERel 1, loc), name), loc), + t, e)) + (foldl (fn ((tname, cols), e) => + foldl (fn ((name, t), e) => + maybeadd ((EField ((EField ((ERel 1, loc), tname), loc), name), loc), + t, e)) e cols) body tables) + exps + in + ECase ((EFfiApp ("Basis", "filecache_missed", []), loc), + [((PCon (Enum, + PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, + NONE), loc), + (EQuery {exps = exps', + tables = tables', + state = state, + query = wrapped_query, + body = wrapped_body_trycache, + initial = initial}, loc)), + ((PCon (Enum, + PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, + NONE), loc), + (EQuery {exps = exps, + tables = tables, + state = state, + query = query, + body = wrapped_body_addtocache, + initial = initial}, loc))], + {disc = (TFfi ("Basis", "bool"), loc), + result = state}) + end + else + e + | _ => e + in + case Settings.getFileCache () of + NONE => file + | SOME _ => MonoUtil.File.map {typ = fn t => t, + exp = exp, + decl = fn d => d} file + end + +end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 2caa43f8..1229d552 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -27,15 +27,79 @@ val socket = ".urweb_daemon" -(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) - exception Code of OS.Process.status +datatype flag_arity = + ZERO of (unit -> unit) + | ONE of string * (string -> unit) + | TWO of string * string * (string * string -> unit) + +fun parse_flags flag_info args = + let + fun search_pred flag0 = + (* Remove preceding "-". *) + let val flag0 = String.extract (flag0, 1, NONE) + in + fn (flag1, _, _) => flag0 = flag1 + end + + fun loop [] : string list = [] + | loop (arg :: args) = + if String.isPrefix "-" arg then + case List.find (search_pred arg) flag_info of + NONE => raise Fail ("Unknown flag "^arg^", see -help") + | SOME x => exec x args + else + arg :: loop args + + and exec (_, ZERO f, _) args = + (f (); loop args) + | exec (_, ONE (_, f), _) (x :: args) = + (f x; loop args) + | exec (_, TWO (_, _, f), _) (x :: y :: args) = + (f (x, y); loop args) + | exec (flag, ONE _, _) [] = + raise Fail ("Flag "^flag^" is missing an argument, see -help") + | exec (flag, TWO _, _) [] = + raise Fail ("Flag "^flag^" is missing two arguments, see -help") + | exec (flag, TWO _, _) [_] = + raise Fail ("Flag "^flag^" is missing an argument, see -help") + in + loop args + end + +fun usage flag_info = + let + val name = CommandLine.name () + + fun print_desc NONE = print "\n" + | print_desc (SOME s) = (print " : "; print s; print "\n") + + fun print_args (ZERO _) = () + | print_args (ONE (x, _)) = print (" " ^ x) + | print_args (TWO (x, y, _)) = print (" " ^ x ^ " " ^ y) + + fun print_flag (flag, args, desc) = + (print (" -" ^ flag); + print_args args; + print_desc desc) + in + print "usage: \n"; + print (" " ^ name ^ " daemon [stop|start]\n"); + print (" " ^ name ^ " [flag ...] project-name\n"); + print "Supported flags are:\n"; + app print_flag flag_info; + raise Code OS.Process.success + end + + + +(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) + fun oneRun args = let val timing = ref false val tc = ref false - val sources = ref ([] : string list) val demo = ref (NONE : (string * bool) option) val tutorial = ref false val css = ref false @@ -52,162 +116,143 @@ fun oneRun args = val () = Compiler.beforeC := MLton.GC.pack - fun printVersion () = (print (Config.versionString ^ "\n"); - raise Code OS.Process.success) - fun printNumericVersion () = (print (Config.versionNumber ^ "\n"); - raise Code OS.Process.success) - fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n"); - raise Code OS.Process.success) - fun printCInclude () = (print (Config.includ ^ "\n"); - raise Code OS.Process.success) - - fun doArgs args = - case args of - [] => () - | "-version" :: rest => - printVersion () - | "-numeric-version" :: rest => - printNumericVersion () - | "-css" :: rest => - (css := true; - doArgs rest) - | "-print-ccompiler" :: rest => - printCCompiler () - | "-print-cinclude" :: rest => - printCInclude () - | "-ccompiler" :: ccomp :: rest => - (Settings.setCCompiler ccomp; - doArgs rest) - | "-demo" :: prefix :: rest => - (demo := SOME (prefix, false); - doArgs rest) - | "-guided-demo" :: prefix :: rest => - (demo := SOME (prefix, true); - doArgs rest) - | "-tutorial" :: rest => - (tutorial := true; - doArgs rest) - | "-protocol" :: name :: rest => - (Settings.setProtocol name; - doArgs rest) - | "-prefix" :: prefix :: rest => - (Settings.setUrlPrefix prefix; - doArgs rest) - | "-db" :: s :: rest => - (Settings.setDbstring (SOME s); - doArgs rest) - | "-dbms" :: name :: rest => - (Settings.setDbms name; - doArgs rest) - | "-debug" :: rest => - (Settings.setDebug true; - doArgs rest) - | "-verbose" :: rest => - (Compiler.debug := true; - Elaborate.verbose := true; - doArgs rest) - | "-timing" :: rest => - (timing := true; - doArgs rest) - | "-tc" :: rest => - (tc := true; - doArgs rest) - | "-dumpTypes" :: rest => - (Elaborate.dumpTypes := true; - doArgs rest) - | "-dumpTypesOnError" :: rest => - (Elaborate.dumpTypesOnError := true; - doArgs rest) - | "-unifyMore" :: rest => - (Elaborate.unifyMore := true; - doArgs rest) - | "-dumpSource" :: rest => - (Compiler.dumpSource := true; - doArgs rest) - | "-dumpVerboseSource" :: rest => - (Compiler.dumpSource := true; - ElabPrint.debug := true; - ExplPrint.debug := true; - CorePrint.debug := true; - MonoPrint.debug := true; - doArgs rest) - | "-output" :: s :: rest => - (Settings.setExe (SOME s); - doArgs rest) - | "-js" :: s :: rest => - (Settings.setOutputJsFile (SOME s); - doArgs rest) - | "-sql" :: s :: rest => - (Settings.setSql (SOME s); - doArgs rest) - | "-static" :: rest => - (Settings.setStaticLinking true; - doArgs rest) - | "-stop" :: phase :: rest => - (Compiler.setStop phase; - doArgs rest) - | "-path" :: name :: path :: rest => - (Compiler.addPath (name, path); - doArgs rest) - | "-root" :: name :: root :: rest => - (Compiler.addModuleRoot (root, name); - doArgs rest) - | "-boot" :: rest => - (Compiler.enableBoot (); - Settings.setBootLinking true; - doArgs rest) - | "-sigfile" :: name :: rest => - (Settings.setSigFile (SOME name); - doArgs rest) - | "-iflow" :: rest => - (Compiler.doIflow := true; - doArgs rest) - | "-sqlcache" :: rest => - (Settings.setSqlcache true; - doArgs rest) - | "-heuristic" :: h :: rest => - (Sqlcache.setHeuristic h; - doArgs rest) - | "-moduleOf" :: fname :: _ => - (print (Compiler.moduleOf fname ^ "\n"); - raise Code OS.Process.success) - | "-noEmacs" :: rest => - (Demo.noEmacs := true; - doArgs rest) - | "-limit" :: class :: num :: rest => - (case Int.fromString num of - NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") - | SOME n => - if n < 0 then - raise Fail ("Invalid limit number '" ^ num ^ "'") - else - Settings.addLimit (class, n); - doArgs rest) - | "-explainEmbed" :: rest => - (JsComp.explainEmbed := true; - doArgs rest) - | arg :: rest => - (if size arg > 0 andalso String.sub (arg, 0) = #"-" then - raise Fail ("Unknown flag " ^ arg) + fun print_and_exit msg () = + (print msg; print "\n"; + raise Code OS.Process.success) + + val printVersion = print_and_exit Config.versionString + val printNumericVersion = print_and_exit Config.versionNumber + fun printCCompiler () = print_and_exit (Settings.getCCompiler ()) () + val printCInclude = print_and_exit Config.includ + + fun printModuleOf fname = + print_and_exit (Compiler.moduleOf fname) () + + fun add_class (class, num) = + case Int.fromString num of + NONE => raise Fail ("Invalid limit number '" ^ num ^ "'") + | SOME n => + if n < 0 then + raise Fail ("Invalid limit number '" ^ num ^ "'") else - sources := arg :: !sources; - doArgs rest) + Settings.addLimit (class, n) + + fun set_true flag = ZERO (fn () => flag := true) + fun call_true f = ZERO (fn () => f true) + + (* This is a function, and not simply a value, because it + * is recursive in the help-flag. *) + fun flag_info () = [ + ("help", ZERO (fn () => usage (flag_info ())), + SOME "print this overview"), + ("version", ZERO printVersion, + SOME "print version number and exit"), + ("numeric-version", ZERO printNumericVersion, + SOME "print numeric version number and exit"), + ("css", set_true css, + SOME "print categories of CSS properties"), + ("print-ccompiler", ZERO printCCompiler, + SOME "print C compiler and exit"), + ("print-cinclude", ZERO printCInclude, + SOME "print directory of C headers and exit"), + ("ccompiler", ONE ("<program>", Settings.setCCompiler), + SOME "set the C compiler to <program>"), + ("demo", ONE ("<prefix>", fn prefix => + demo := SOME (prefix, false)), + NONE), + ("guided-demo", ONE ("<prefix>", fn prefix => + demo := SOME (prefix, true)), + NONE), + ("tutorial", set_true tutorial, + NONE), + ("protocol", ONE ("[http|cgi|fastcgi|static]", + Settings.setProtocol), + SOME "set server protocol"), + ("prefix", ONE ("<prefix>", Settings.setUrlPrefix), + SOME "set prefix used before all URI's"), + ("db", ONE ("<string>", Settings.setDbstring o SOME), + SOME "database connection information"), + ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms), + SOME "select database engine"), + ("debug", call_true Settings.setDebug, + NONE), + ("verbose", ZERO (fn () => + (Compiler.debug := true; + Elaborate.verbose := true)), + NONE), + ("timing", set_true timing, + SOME "time compilation phases"), + ("tc", set_true tc, + SOME "stop after type checking"), + ("dumpTypes", set_true Elaborate.dumpTypes, + SOME "print kinds and types"), + ("dumpTypesOnError", set_true Elaborate.dumpTypesOnError, + SOME "print kinds and types if there is an error"), + ("unifyMore", set_true Elaborate.unifyMore, + SOME "continue unification before reporting type error"), + ("dumpSource", set_true Compiler.dumpSource, + NONE), + ("dumpVerboseSource", ZERO (fn () => + (Compiler.dumpSource := true; + ElabPrint.debug := true; + ExplPrint.debug := true; + CorePrint.debug := true; + MonoPrint.debug := true)), + NONE), + ("output", ONE ("<file>", Settings.setExe o SOME), + SOME "output executable as <file>"), + ("js", ONE ("<file>", Settings.setOutputJsFile o SOME), + SOME "serve JavaScript as <file>"), + ("sql", ONE ("<file>", Settings.setSql o SOME), + SOME "output sql script as <file>"), + ("static", call_true Settings.setStaticLinking, + SOME "enable static linking"), + ("stop", ONE ("<phase>", Compiler.setStop), + SOME "stop compilation after <phase>"), + ("path", TWO ("<name>", "<path>", Compiler.addPath), + NONE), + ("root", TWO ("<name>", "<path>", + (fn (name, path) => + Compiler.addModuleRoot (path, name))), + NONE), + ("boot", ZERO (fn () => + (Compiler.enableBoot (); + Settings.setBootLinking true)), + NONE), + ("sigfile", ONE ("<file>", Settings.setSigFile o SOME), + NONE), + ("iflow", set_true Compiler.doIflow, + NONE), + ("sqlcache", call_true Settings.setSqlcache, + NONE), + ("heuristic", ONE ("<h>", Sqlcache.setHeuristic), + NONE), + ("moduleOf", ONE ("<file>", printModuleOf), + SOME "print module name of <file> and exit"), + ("noEmacs", set_true Demo.noEmacs, + NONE), + ("limit", TWO ("<class>", "<num>", add_class), + NONE), + ("explainEmbed", set_true JsComp.explainEmbed, + SOME ("explain errors about embedding of server-side "^ + "values in client code")) + ] val () = case args of ["daemon", "stop"] => OS.Process.exit OS.Process.success | _ => () - val () = doArgs args + val sources = parse_flags (flag_info ()) args val job = - case !sources of + case sources of [file] => file + | [] => + raise Fail "No project specified, see -help" | files => - if List.exists (fn s => s <> "-version") args then - raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: " - ^ String.concatWith ", " files) - else - printVersion () + raise Fail ("Multiple projects specified;"^ + " only one is allowed.\nSpecified projects: "^ + String.concatWith ", " files) in case (!css, !demo, !tutorial) of (true, _, _) => diff --git a/src/mono_util.sml b/src/mono_util.sml index fc1a2bcb..fdf48d20 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -107,16 +107,16 @@ fun mapfold fc = | TOption t => S.map2 (mft t, fn t' => - (TOption t, loc)) + (TOption t', loc)) | TList t => S.map2 (mft t, fn t' => - (TList t, loc)) + (TList t', loc)) | TSource => S.return2 cAll | TSignal t => S.map2 (mft t, fn t' => - (TSignal t, loc)) + (TSignal t', loc)) in mft end diff --git a/src/monoize.sml b/src/monoize.sml index ddf6cd4c..11c6ea31 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1792,18 +1792,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE), loc), str "")], {disc = b, result = s}), loc), - strcatComma (map (fn (x, t) => - strcat [ - (L'.EField (gf "SelectExps", x), loc), - str (" AS " ^ Settings.mangleSql x) - ]) sexps - @ map (fn (x, xts) => - strcatComma - (map (fn (x', _) => - str ("T_" ^ x - ^ "." - ^ Settings.mangleSql x')) - xts)) stables), + if List.null sexps andalso List.all (List.null o #2) stables then + str "0" + else + strcatComma (map (fn (x, t) => + strcat [ + (L'.EField (gf "SelectExps", x), loc), + str (" AS " ^ Settings.mangleSql x) + ]) sexps + @ map (fn (x, xts) => + strcatComma + (map (fn (x', _) => + str ("T_" ^ x + ^ "." + ^ Settings.mangleSql x')) + xts)) stables), (L'.ECase (gf "From", [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), @@ -3067,7 +3070,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => (attrs, NONE) - val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] + val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cradio", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] fun isSome (e, _) = case e of @@ -3281,6 +3284,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = SOME (strcat [str "addOnChange(d,exec(", (L'.EJavaScript (L'.Script, e), loc), str "));"]) + | ("Oninput", e, _) => + SOME (strcat [str "addOnInput(d,exec(", + (L'.EJavaScript (L'.Script, e), loc), + str "));"]) | (x, e, (L'.TFun ((L'.TRecord [], _), _), _)) => SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("), (L'.EJavaScript (L'.Script, e), loc), @@ -3553,6 +3560,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "ctime" => cinput ("time", "time") | "ccheckbox" => cinput ("checkbox", "chk") + | "cradio" => cinput ("radio", "crad") + | "cselect" => (case List.find (fn ("Source", _, _) => true | _ => false) attrs of NONE => diff --git a/src/mysql.sml b/src/mysql.sml index 52e4921e..e7cad84e 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1609,6 +1609,7 @@ val () = addDbms {name = "mysql", onlyUnion = true, nestedRelops = false, windowFunctions = false, - supportsIsDistinctFrom = true} + supportsIsDistinctFrom = true, + supportsSHA512 = false} end diff --git a/src/postgres.sml b/src/postgres.sml index 404384d2..2b6bee8c 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -612,6 +612,13 @@ fun p_getcol {loc, wontLeakStrings, col = i, typ = t} = getter t end +(* We turn 0-output queries into 1-output queries to satisfy SQL. + * This function adjusts our length expectations. *) +fun bumpedLength ls = + case ls of + [] => 1 + | _ => length ls + fun queryCommon {loc, query, cols, doCols} = box [string "int n, i;", newline, @@ -658,7 +665,7 @@ fun queryCommon {loc, query, cols, doCols} = newline, string "if (PQnfields(res) != ", - string (Int.toString (length cols)), + string (Int.toString (bumpedLength cols)), string ") {", newline, box [string "int nf = PQnfields(res);", @@ -668,7 +675,7 @@ fun queryCommon {loc, query, cols, doCols} = string "uw_error(ctx, FATAL, \"", string (ErrorMsg.spanToString loc), string ": Query returned %d columns instead of ", - string (Int.toString (length cols)), + string (Int.toString (bumpedLength cols)), string ":\\n%s\\n%s\", nf, ", query, string ", PQerrorMessage(conn));", @@ -1146,7 +1153,8 @@ val () = addDbms {name = "postgres", onlyUnion = false, nestedRelops = true, windowFunctions = true, - supportsIsDistinctFrom = true} + supportsIsDistinctFrom = true, + supportsSHA512 = true} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index 256a12b5..986d6ed7 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -219,7 +219,8 @@ signature SETTINGS = sig onlyUnion : bool, nestedRelops : bool, windowFunctions : bool, - supportsIsDistinctFrom : bool + supportsIsDistinctFrom : bool, + supportsSHA512 : bool } val addDbms : dbms -> unit @@ -253,6 +254,9 @@ signature SETTINGS = sig val setSigFile : string option -> unit val getSigFile : unit -> string option + val setFileCache : string option -> unit + val getFileCache : unit -> string option + (* Which GET-able functions should be allowed to have side effects? *) val setSafeGets : string list -> unit val isSafeGet : string -> bool @@ -298,7 +302,7 @@ signature SETTINGS = sig val setFilePath : string -> unit (* Sets the directory where we look for files being added below. *) - val addFile : {Uri : string, LoadFromFilename : string} -> unit + val addFile : {Uri : string, LoadFromFilename : string, MimeType : string option} -> unit val listFiles : unit -> {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector} list val addJsFile : string (* filename *) -> unit @@ -306,4 +310,7 @@ signature SETTINGS = sig val setOutputJsFile : string option (* filename *) -> unit val getOutputJsFile : unit -> string option + + val setMimeFilePath : string -> unit + (* Set unusual location for /etc/mime.types. *) end diff --git a/src/settings.sml b/src/settings.sml index a3263c06..cfbe98a5 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -646,7 +646,8 @@ type dbms = { onlyUnion : bool, nestedRelops : bool, windowFunctions: bool, - supportsIsDistinctFrom : bool + supportsIsDistinctFrom : bool, + supportsSHA512 : bool } val dbmses = ref ([] : dbms list) @@ -679,7 +680,8 @@ val curDb = ref ({name = "", onlyUnion = false, nestedRelops = false, windowFunctions = false, - supportsIsDistinctFrom = false} : dbms) + supportsIsDistinctFrom = false, + supportsSHA512 = false} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = @@ -724,6 +726,15 @@ val sigFile = ref (NONE : string option) fun setSigFile v = sigFile := v fun getSigFile () = !sigFile +val fileCache = ref (NONE : string option) +fun setFileCache v = + (if Option.isSome v andalso not (#supportsSHA512 (currentDbms ())) then + ErrorMsg.error "The selected database engine is incompatible with file caching." + else + (); + fileCache := v) +fun getFileCache () = !fileCache + structure SS = BinarySetFn(struct type ord_key = string val compare = String.compare @@ -843,14 +854,17 @@ structure SM = BinaryMapFn(struct val noMimeFile = ref false +val mimeFilePath = ref "/etc/mime.types" +fun setMimeFilePath file = mimeFilePath := file + fun noMime () = - (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n"); + (TextIO.output (TextIO.stdErr, "WARNING: Error opening " ^ !mimeFilePath ^ ". Static files will be served with no suggested MIME types.\n"); noMimeFile := true; SM.empty) fun readMimeTypes () = let - val inf = FileIO.txtOpenIn "/etc/mime.types" + val inf = FileIO.txtOpenIn (!mimeFilePath) fun loop m = case TextIO.inputLine inf of @@ -908,9 +922,10 @@ val filePath = ref "." fun setFilePath path = filePath := path -fun addFile {Uri, LoadFromFilename} = +fun addFile {Uri, LoadFromFilename, MimeType} = let val path = OS.Path.concat (!filePath, LoadFromFilename) + handle Path => LoadFromFilename in case SM.find (!files, Uri) of SOME (path', _) => @@ -926,7 +941,9 @@ fun addFile {Uri, LoadFromFilename} = Uri, (path, {Uri = Uri, - ContentType = mimeTypeOf path, + ContentType = case MimeType of + NONE => mimeTypeOf path + | _ => MimeType, LastModified = OS.FileSys.modTime path, Bytes = BinIO.inputAll inf})); BinIO.closeIn inf diff --git a/src/sources b/src/sources index 52b1bdd7..5c0b2a84 100644 --- a/src/sources +++ b/src/sources @@ -231,6 +231,9 @@ $(SRC)/sidecheck.sml $(SRC)/sigcheck.sig $(SRC)/sigcheck.sml +$(SRC)/filecache.sig +$(SRC)/filecache.sml + $(SRC)/mono_inline.sml $(SRC)/sha1.sig diff --git a/src/sqlite.sml b/src/sqlite.sml index a9b6389d..db7052d1 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -273,6 +273,11 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = string "\"Can't open SQLite database.\");", newline, newline, + string "if (sqlite3_exec(sqlite, \"PRAGMA foreign_keys = ON\", NULL, NULL, NULL) != SQLITE_OK)", + newline, + box [string "uw_error(ctx, FATAL, \"Can't enable foreign_keys for SQLite database\");", + newline], + newline, string "if (uw_database_max < SIZE_MAX) {", newline, box [string "char buf[100];", @@ -843,13 +848,14 @@ val () = addDbms {name = "sqlite", textKeysNeedLengths = false, supportsNextval = false, supportsNestedPrepared = false, - sqlPrefix = "", + sqlPrefix = "PRAGMA foreign_keys = ON;\nPRAGMA journal_mode = WAL;\n\n", supportsOctetLength = false, trueString = "1", falseString = "0", onlyUnion = false, nestedRelops = false, windowFunctions = false, - supportsIsDistinctFrom = false} + supportsIsDistinctFrom = false, + supportsSHA512 = false} end diff --git a/tests/DynChannel.py b/tests/DynChannel.py new file mode 100644 index 00000000..7af5ea78 --- /dev/null +++ b/tests/DynChannel.py @@ -0,0 +1,20 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('DynChannel/main') + + # initial state: only Register is visible + reg = self.xpath('button') + reg.click() + # and we get two another state: either Register or Send visible + send = self.xpath('span/button') + send.click() + alert = self.driver.switch_to.alert + self.assertEqual("Got something from the channel", alert.text) + alert.accept() + # we got the message back + span = self.xpath('span/span') + self.assertEqual("blabla", span.text) diff --git a/tests/Makefile b/tests/Makefile index 5313d12d..ecf5557b 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -2,3 +2,29 @@ all: test.o test.o: test.c gcc -c test.c -o test.o +### + +simple:: + ./driver.sh aborter2 + ./driver.sh aborter + ./driver.sh activeBlock + ./driver.sh activeFocus + ./driver.sh active + ./driver.sh agg + ./driver.sh ahead + ./driver.sh alert + ./driver.sh align + ./driver.sh appjs + ./driver.sh ascdesc + echo ./driver.sh attrMangle + ./driver.sh attrs_escape + echo ./driver.sh attrs + ./driver.sh autocomp + ./driver.sh babySpawn + ./driver.sh bindpat + ./driver.sh DynChannel + ./driver.sh jsonTest + ./driver.sh entities + ./driver.sh fact + ./driver.sh filter + ./driver.sh jsbspace diff --git a/tests/aborter.py b/tests/aborter.py new file mode 100644 index 00000000..8379c656 --- /dev/null +++ b/tests/aborter.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Aborter/main') + self.assertEqual("Fatal Error", self.driver.title) + txt = self.body_text() + self.assertEqual("Fatal error: :0:0-0:0: No way, Jose!", txt) + diff --git a/tests/aborter.urp b/tests/aborter.urp index fc1925ae..8c971440 100644 --- a/tests/aborter.urp +++ b/tests/aborter.urp @@ -1,4 +1,5 @@ database dbname=aborter sql aborter.sql +safeGet Aborter/main aborter diff --git a/tests/aborter2.py b/tests/aborter2.py new file mode 100644 index 00000000..c3f1e10e --- /dev/null +++ b/tests/aborter2.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Aborter2/main') + self.assertEqual("", self.driver.title) + txt = self.body_text() + self.assertEqual("Result: 0", txt) + diff --git a/tests/active.py b/tests/active.py new file mode 100644 index 00000000..08846ac5 --- /dev/null +++ b/tests/active.py @@ -0,0 +1,14 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + b1 = self.xpath('span[1]/button') + b2 = self.xpath('span[2]/button') + for _ in range(3): + b1.click() + for _ in range(5): + b2.click() + self.assertEqual("3\n5", self.body_text()) diff --git a/tests/activeBlock.py b/tests/activeBlock.py new file mode 100644 index 00000000..d0e43fdb --- /dev/null +++ b/tests/activeBlock.py @@ -0,0 +1,20 @@ +import unittest +import base +import time + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + alert = self.driver.switch_to.alert + self.assertEqual("Error: May not 'sleep' in main thread of 'code' for <active>", alert.text) + alert.accept() + time.sleep(0.1) + alert = self.driver.switch_to.alert + self.assertEqual("Hi!", alert.text) + alert.accept() + button = self.xpath('span[1]/button') + button.click() + txt = self.body_text() + self.assertEqual("Hi! Click me! Success", txt) + diff --git a/tests/activeBlock.ur b/tests/activeBlock.ur index 5560edda..bced4af3 100644 --- a/tests/activeBlock.ur +++ b/tests/activeBlock.ur @@ -1,7 +1,7 @@ fun main () : transaction page = return <xml><body> <active code={s <- source ""; return <xml> <dyn signal={s <- signal s; return (txt s)}/> - <button onclick={fn _ => set s "Hi!"}/> + <button onclick={fn _ => set s "Hi!"}>Click me!</button> </xml>}/> <active code={sleep 1; return <xml>Hi!</xml>}/> diff --git a/tests/activeEmpty.py b/tests/activeEmpty.py new file mode 100644 index 00000000..8872833a --- /dev/null +++ b/tests/activeEmpty.py @@ -0,0 +1,12 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + alert = self.driver.switch_to.alert + self.assertEqual("Howdy, neighbor!", alert.text) + alert.accept() + txt = self.body_text() + self.assertEqual("This one ain't empty.", txt) diff --git a/tests/activeFocus.py b/tests/activeFocus.py new file mode 100644 index 00000000..47b9a921 --- /dev/null +++ b/tests/activeFocus.py @@ -0,0 +1,18 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + uw0 = self.xpath('input[2]') + active = self.driver.switch_to.active_element + self.assertEqual(uw0, active) + def test_2(self): + """Test case 2""" + self.start('dynamic') + btn = self.xpath('button') + btn.click() + uw1 = self.xpath('span/input[2]') + active = self.driver.switch_to.active_element + self.assertEqual(uw1, active) diff --git a/tests/activeFocus.ur b/tests/activeFocus.ur index 94d465e9..82d2c0c9 100644 --- a/tests/activeFocus.ur +++ b/tests/activeFocus.ur @@ -14,5 +14,5 @@ fun dynamic () : transaction page = <ctextbox/> <ctextbox id={i}/> <active code={giveFocus i; return <xml>Done</xml>}/> - </xml>}/> + </xml>}>Click</button> </body></xml> diff --git a/tests/agg.py b/tests/agg.py new file mode 100644 index 00000000..0b421d37 --- /dev/null +++ b/tests/agg.py @@ -0,0 +1,8 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Agg/main') + self.assertEqual("0;1;2;\na, 50;", self.body_text()) diff --git a/tests/agg.ur b/tests/agg.ur index 19a8644b..2d8eed43 100644 --- a/tests/agg.ur +++ b/tests/agg.ur @@ -1,13 +1,23 @@ table t1 : {A : int, B : string, C : float} table t2 : {A : float, D : int, E : option string} -val q1 : sql_query [] _ _ = (SELECT COUNT( * ) FROM t1) -val q2 : sql_query [] _ _ = (SELECT AVG(t1.A) FROM t1) -val q3 : sql_query [] _ _ = (SELECT SUM(t1.C) FROM t1) -val q4 : sql_query [] _ _ = (SELECT MIN(t1.B), MAX(t1.A) FROM t1) -val q5 : sql_query [] _ _ = (SELECT SUM(t1.A) FROM t1 GROUP BY t1.B) +val q1 : sql_query [] [] _ _ = (SELECT COUNT( * ) FROM t1) +val q2 : sql_query [] [] _ _ = (SELECT AVG(t1.A) FROM t1) +val q3 : sql_query [] [] _ _ = (SELECT SUM(t1.C) FROM t1) +val q4 : sql_query [] [] _ _ = (SELECT MIN(t1.B), MAX(t1.A) FROM t1) +val q5 : sql_query [] [] _ _ = (SELECT SUM(t1.A) FROM t1 GROUP BY t1.B) val q6 = (SELECT COUNT(t2.E) FROM t2 GROUP BY t2.D) +task initialize = fn () => + dml (INSERT INTO t1 (A, B, C) VALUES (1, 'a', 1.0)); + dml (INSERT INTO t1 (A, B, C) VALUES (2, 'b', 2.0)); + dml (INSERT INTO t1 (A, B, C) VALUES (50, 'c', 99.0)); + dml (INSERT INTO t2 (A, D, E) VALUES (1.0, 1, NULL)); + dml (INSERT INTO t2 (A, D, E) VALUES (1.0, 2, {[Some "a"]})); + dml (INSERT INTO t2 (A, D, E) VALUES (1.0, 3, NULL)); + dml (INSERT INTO t2 (A, D, E) VALUES (1.0, 3, {[Some "b"]})); + dml (INSERT INTO t2 (A, D, E) VALUES (1.0, 3, {[Some "c"]})) + fun main () : transaction page = xml <- queryX q6 (fn r => <xml>{[r.1]};</xml>); xml2 <- queryX q4 (fn r => <xml>{[r.1]}, {[r.2]};</xml>); diff --git a/tests/ahead.py b/tests/ahead.py new file mode 100644 index 00000000..6e767948 --- /dev/null +++ b/tests/ahead.py @@ -0,0 +1,15 @@ +import unittest +import base +import time + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + alert = self.driver.switch_to.alert + self.assertEqual("Hi!", alert.text) + alert.accept() + time.sleep(0.1) + alert = self.driver.switch_to.alert + self.assertEqual("Bye!", alert.text) + alert.accept() diff --git a/tests/alert.py b/tests/alert.py new file mode 100644 index 00000000..4b783d50 --- /dev/null +++ b/tests/alert.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + el = self.xpath('a') + el.click() + alert = self.driver.switch_to.alert + self.assertEqual("You clicked it! That's some fancy shooting!", alert.text) diff --git a/tests/alert.ur b/tests/alert.ur index 3fe68d75..7a290921 100644 --- a/tests/alert.ur +++ b/tests/alert.ur @@ -1,3 +1,3 @@ fun main () : transaction page = return <xml><body> - <a onclick={alert "You clicked it! That's some fancy shooting!"}>Click Me!</a> + <a onclick={fn _ => alert "You clicked it! That's some fancy shooting!"}>Click Me!</a> </body></xml> diff --git a/tests/align.py b/tests/align.py new file mode 100644 index 00000000..525ab4e6 --- /dev/null +++ b/tests/align.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + el = self.xpath('p[@align="left"]') + self.assertEqual("Left", el.text) + el = self.xpath('p[@align="right"]') + self.assertEqual("Right", el.text) diff --git a/tests/appjs.py b/tests/appjs.py new file mode 100644 index 00000000..02ac2193 --- /dev/null +++ b/tests/appjs.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + el = self.xpath('button') + el.click() + alert = self.driver.switch_to.alert + self.assertEqual("3", alert.text) diff --git a/tests/appjs.ur b/tests/appjs.ur index 01e9f345..403b0b4e 100644 --- a/tests/appjs.ur +++ b/tests/appjs.ur @@ -1,5 +1,5 @@ fun id n = if n = 0 then 0 else 1 + id (n - 1) fun main () : transaction page = return <xml><body> - <button onclick={alert (show (id 3))}/> + <button onclick={fn _ => alert (show (id 3))}/> </body></xml> diff --git a/tests/ascdesc.py b/tests/ascdesc.py new file mode 100644 index 00000000..6b514f4e --- /dev/null +++ b/tests/ascdesc.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Ascdesc/main') + el = self.xpath('p[1]') + self.assertEqual("1; 2; 3;", el.text) + el = self.xpath('p[2]') + self.assertEqual("3; 2; 1;", el.text) diff --git a/tests/ascdesc.ur b/tests/ascdesc.ur index 59dd0169..fadac27d 100644 --- a/tests/ascdesc.ur +++ b/tests/ascdesc.ur @@ -4,7 +4,15 @@ fun sortEm b = queryX1 (SELECT * FROM t ORDER BY t.A {if b then sql_asc else sql_desc}) (fn r => <xml>{[r.A]}; </xml>) -fun main () : transaction page = return <xml><body> - <a link={sortEm True}>Ascending</a><br/> - <a link={sortEm False}>Descending</a> +task initialize = fn () => + dml (INSERT INTO t (A) VALUES (1)); + dml (INSERT INTO t (A) VALUES (2)); + dml (INSERT INTO t (A) VALUES (3)) + +fun main () : transaction page = + p1 <- sortEm True; + p2 <- sortEm False; + return <xml><body> + <p>{p1}</p> + <p>{p2}</p> </body></xml> diff --git a/tests/ascdesc.urp b/tests/ascdesc.urp index 3e0b075d..a1c4124e 100644 --- a/tests/ascdesc.urp +++ b/tests/ascdesc.urp @@ -1,4 +1,3 @@ -database dbname=test -sql ascdesc.sql +database dbname=ascdesc ascdesc
\ No newline at end of file diff --git a/tests/attrMangle.py b/tests/attrMangle.py new file mode 100644 index 00000000..d3b24244 --- /dev/null +++ b/tests/attrMangle.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + el = self.xpath('goofy[@name eq "beppo" and @data-role eq "excellence"]') + el.click() + alert = self.driver.switch_to.alert + self.assertEqual("You clicked it! That's some fancy shooting!", alert.text) diff --git a/tests/attrs_escape.py b/tests/attrs_escape.py new file mode 100644 index 00000000..fc9f91b5 --- /dev/null +++ b/tests/attrs_escape.py @@ -0,0 +1,10 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + el = self.xpath('form/input') + val = el.get_attribute('value') + self.assertEqual("\"Well hey\"\nWow", val) diff --git a/tests/attrs_escape.ur b/tests/attrs_escape.ur index 12de101e..87d554fe 100644 --- a/tests/attrs_escape.ur +++ b/tests/attrs_escape.ur @@ -1,4 +1,6 @@ -val main = fn () => <html><body> - <font face="\"Well hey\" -Wow">Welcome</font> -</body></html> +fun main () : transaction page = return <xml><body> +<form> + <submit value="\"Well hey\" +Wow"/> +</form> +</body></xml> diff --git a/tests/autocomp.py b/tests/autocomp.py new file mode 100644 index 00000000..28c3b7d2 --- /dev/null +++ b/tests/autocomp.py @@ -0,0 +1,15 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + txt = self.xpath('div') + self.assertEqual('/', txt.text) + inp = self.xpath('/input') + inp.send_keys('hello there') + self.assertEqual('hello there /', txt.text) + btn = self.xpath('button') + btn.click() + self.assertEqual("hello there / hello there", txt.text) diff --git a/tests/autocomp.ur b/tests/autocomp.ur index d4e6a287..753318f7 100644 --- a/tests/autocomp.ur +++ b/tests/autocomp.ur @@ -2,10 +2,10 @@ fun main () : transaction page = a <- source ""; b <- source ""; return <xml><body> - <form> - <textbox{#A} source={a}/> - <button onclick={x <- get a; set b x}/> + <ctextbox source={a}/> + <button onclick={fn _ => x <- get a; set b x}>click me</button> + <div> <dyn signal={v <- signal a; return <xml>{[v]}</xml>}/> / <dyn signal={v <- signal b; return <xml>{[v]}</xml>}/> - </form> + </div> </body></xml> diff --git a/tests/babySpawn.py b/tests/babySpawn.py new file mode 100644 index 00000000..6693e969 --- /dev/null +++ b/tests/babySpawn.py @@ -0,0 +1,12 @@ +import unittest +import base +import time + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + btn = self.xpath('button') + btn.click() + alert = self.driver.switch_to.alert + self.assertEqual("Hi", alert.text) diff --git a/tests/base.py b/tests/base.py new file mode 100644 index 00000000..b9a026f2 --- /dev/null +++ b/tests/base.py @@ -0,0 +1,29 @@ +# use pip install selenium first +# ensure you have both chome driver & chrome installed + +import unittest +from selenium import webdriver +from selenium.common.exceptions import NoSuchElementException + +class Base(unittest.TestCase): + """Include test cases on a given url""" + + def start(self, path='main'): + self.driver.get('http://localhost:8080/' + path) + def xpath(self, path): + return self.driver.find_element_by_xpath('/html/body/'+path) + def body_text(self): + return self.driver.find_element_by_xpath('/html/body').text + + def setUp(self): + """Start web driver""" + chrome_options = webdriver.ChromeOptions() + chrome_options.add_argument('--no-sandbox') + chrome_options.add_argument('--headless') + chrome_options.add_argument('--disable-gpu') + self.driver = webdriver.Chrome(options=chrome_options) + self.driver.implicitly_wait(10) + + def tearDown(self): + """Stop web driver""" + self.driver.quit() diff --git a/tests/bindpat.py b/tests/bindpat.py new file mode 100644 index 00000000..6c33f52f --- /dev/null +++ b/tests/bindpat.py @@ -0,0 +1,9 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.driver.get('http://localhost:8080/main') + el = self.driver.find_element_by_xpath('/html/body') + self.assertEqual("1, 2, hi, 2.34, 8, 9", el.text) diff --git a/tests/bindpat.ur b/tests/bindpat.ur index bca4bd41..8fd6eb39 100644 --- a/tests/bindpat.ur +++ b/tests/bindpat.ur @@ -1,6 +1,9 @@ fun main () : transaction page = (a, b) <- return (1, 2); {C = c, ...} <- return {C = "hi", D = False}; - d <- return 2.34; - {1 = e, 2 = f} <- return (8, 9); + let + val d = 2.34 + val {1 = e, 2 = f} = (8, 9) + in return <xml>{[a]}, {[b]}, {[c]}, {[d]}, {[e]}, {[f]}</xml> + end
\ No newline at end of file diff --git a/tests/cradio.py b/tests/cradio.py new file mode 100644 index 00000000..cc075593 --- /dev/null +++ b/tests/cradio.py @@ -0,0 +1,33 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start("Cradio/main") + txt = self.xpath('div[1]').text + self.assertEqual("Hello, I'm B. I'll be your waiter for this evening.", txt) + txt2 = self.xpath('div[2]').text + self.assertEqual('Value:', txt2) + el1 = self.xpath('label[1]/input') + el2 = self.xpath('label[2]/input') + self.assertEqual(False, el1.is_selected()) + self.assertEqual(True, el2.is_selected()) + el1.click() + alert = self.driver.switch_to.alert + self.assertEqual("Now it's A", alert.text) + alert.accept() + self.assertEqual(True, el1.is_selected()) + self.assertEqual(False, el2.is_selected()) + txt = self.xpath('div[1]').text + self.assertEqual("Hello, I'm A. I'll be your waiter for this evening.", txt) + txt2 = self.xpath('div[2]').text + self.assertEqual('Value:', txt2) + # now check that the second radio group works as well + el3 = self.xpath('label[4]/input') + el3.click() + alert = self.driver.switch_to.alert + alert.accept() + txt2 = self.xpath('div[2]').text + self.assertEqual('Value: Y', txt2) + self.assertEqual("Hello, I'm A. I'll be your waiter for this evening.", txt) diff --git a/tests/cradio.ur b/tests/cradio.ur new file mode 100644 index 00000000..48c04f1e --- /dev/null +++ b/tests/cradio.ur @@ -0,0 +1,26 @@ +fun main () = +s <- source (Some "B"); +r <- source None; +let + val onc = v <- get s; alert ("Now it's " ^ show v) + val onc_r = v <- get r; alert ("Changed to " ^ show v) +in + return <xml><body> + <h1>First group</h1> + + <label>Wilbur <cradio source={s} value="A" onchange={onc}/></label> + <label>Walbur <cradio source={s} value="B" onchange={onc}/></label> + + <div> + Hello, I'm <dyn signal={s <- signal s; return <xml>{[s]}</xml>}/>. I'll be your waiter for this evening. + </div> + + <h1>Second group</h1> + + <label>X <cradio source={r} value="X" onchange={onc_r}/></label> + <label>Y <cradio source={r} value="Y" onchange={onc_r}/></label> + <label>Z <cradio source={r} value="Z" onchange={onc_r}/></label> + + <div>Value: <dyn signal={r <- signal r; return <xml>{[r]}</xml>}/></div> + </body></xml> +end diff --git a/tests/alert.urp b/tests/cradio.urp index 3976e9b0..0681ab21 100644 --- a/tests/alert.urp +++ b/tests/cradio.urp @@ -1,3 +1,3 @@ debug -alert +cradio diff --git a/tests/cradio.urs b/tests/cradio.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/cradio.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/tests/dbupload.urp b/tests/dbupload.urp index dd8417d1..daa68e2c 100644 --- a/tests/dbupload.urp +++ b/tests/dbupload.urp @@ -2,5 +2,6 @@ database dbname=dbupload sql dbupload.sql allow mime * rewrite all Dbupload/* +filecache /tmp/files dbupload diff --git a/tests/dbuploadOpt.ur b/tests/dbuploadOpt.ur new file mode 100644 index 00000000..466b49f3 --- /dev/null +++ b/tests/dbuploadOpt.ur @@ -0,0 +1,27 @@ +table t : { Id : int, Blob : option blob, MimeType : string } +sequence s + +fun getImage id : transaction page = + r <- oneRow1 (SELECT t.Blob, t.MimeType + FROM t + WHERE t.Id = {[id]}); + case r.Blob of + None => error <xml>Oh no!</xml> + | Some blob => returnBlob blob (blessMime r.MimeType) + +fun main () : transaction page = + let + fun handle r = + id <- nextval s; + dml (INSERT INTO t (Id, Blob, MimeType) + VALUES ({[id]}, {[if fileMimeType r.File = "image/jpeg" then Some (fileData r.File) else None]}, {[fileMimeType r.File]})); + main () + in + x <- queryX1 (SELECT t.Id FROM t) + (fn r => <xml><img src={url (getImage r.Id)}/><br/></xml>); + return <xml><body> + <form><upload{#File}/> <submit action={handle}/></form> + <hr/> + {x} + </body></xml> + end diff --git a/tests/dbuploadOpt.urp b/tests/dbuploadOpt.urp new file mode 100644 index 00000000..816bcea1 --- /dev/null +++ b/tests/dbuploadOpt.urp @@ -0,0 +1,7 @@ +database dbname=dbuploadOpt +sql dbuploadOpt.sql +allow mime * +rewrite all DbuploadOpt/* +filecache /tmp/files + +dbuploadOpt diff --git a/tests/driver.sh b/tests/driver.sh new file mode 100755 index 00000000..879c093d --- /dev/null +++ b/tests/driver.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +if [[ $# -eq 0 ]] ; then + echo 'Supply at least one argument' + exit 1 +fi + +TESTDB=/tmp/$1.db +TESTSQL=/tmp/$1.sql +TESTPID=/tmp/$1.pid +TESTSRV=./$1.exe + +rm -f $TESTDB $TESTSQL $TESTPID $TESTSRV +../bin/urweb -debug -boot -noEmacs -dbms sqlite -db $TESTDB -sql $TESTSQL "$1" || exit 1 + +if [ -e $TESTSQL ] +then + sqlite3 $TESTDB < $TESTSQL +fi + +$TESTSRV -q -a 127.0.0.1 & +echo $! >> $TESTPID +sleep 1 +python3 -m unittest $1.py +kill `cat $TESTPID` diff --git a/tests/entities.py b/tests/entities.py new file mode 100644 index 00000000..d9087cbf --- /dev/null +++ b/tests/entities.py @@ -0,0 +1,14 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + p = self.xpath('p[1]') + self.assertEqual('Hello world! & so on, © me today (8 €)', p.text) + p = self.xpath('p[2]') + self.assertEqual('♠ ♣ ♥ ♦', p.text) + p = self.xpath('p[3]') + self.assertEqual('† DANGER †', p.text) + diff --git a/tests/entities.ur b/tests/entities.ur index 8b78edbc..1f45520d 100644 --- a/tests/entities.ur +++ b/tests/entities.ur @@ -1,5 +1,5 @@ fun main () : transaction page = return <xml><body> - Hello world! & so on, © me today (8 €)<br/> - ♠ ♣ ♥ ♦<br/> - † DANGER † + <p>Hello world! & so on, © me today (8 €)</p> + <p>♠ ♣ ♥ ♦</p> + <p>† DANGER †</p> </body></xml> diff --git a/tests/fact.py b/tests/fact.py new file mode 100644 index 00000000..3dcd6f71 --- /dev/null +++ b/tests/fact.py @@ -0,0 +1,10 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + b = self.driver.find_element_by_xpath('/html/body') + self.assertEqual('3628800, 3628800', b.text) + diff --git a/tests/fake_types b/tests/fake_types new file mode 100644 index 00000000..405e9d1d --- /dev/null +++ b/tests/fake_types @@ -0,0 +1,2 @@ +horrible_idea/blorpapalooza txt +whoa/yowza html diff --git a/tests/filter.py b/tests/filter.py new file mode 100644 index 00000000..f68f8f88 --- /dev/null +++ b/tests/filter.py @@ -0,0 +1,9 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start('Filter/main') + tx = self.body_text() + self.assertEqual("4, 4; 44, 4.4;", tx) diff --git a/tests/filter.ur b/tests/filter.ur index efd326c3..2691a939 100644 --- a/tests/filter.ur +++ b/tests/filter.ur @@ -1,9 +1,16 @@ -fun filter [fs ::: {Type}] [ks] (t : sql_table fs ks) (p : sql_exp [T = fs] [] [] bool) - : sql_query [T = fs] [] = +fun filter [fs ::: {Type}] [ks] (t : sql_table fs ks) (p : sql_exp [T = fs] [] [] bool) = (SELECT * FROM t WHERE {p}) table t : { A : int, B : float } -fun main () = - queryX (filter t (WHERE t.A > 3)) - (fn r => <xml>{[r.T.A]}, {[r.T.B]}</xml>) +task initialize = fn () => + dml (INSERT INTO t (A, B) VALUES (1, 2.0)); + dml (INSERT INTO t (A, B) VALUES (2, 1.0)); + dml (INSERT INTO t (A, B) VALUES (3, 3.0)); + dml (INSERT INTO t (A, B) VALUES (4, 4.0)); + dml (INSERT INTO t (A, B) VALUES (44, 4.4)) + +fun main () : transaction page = + r <- queryX (filter t (WHERE t.A > 3)) + (fn r => <xml>{[r.T.A]}, {[r.T.B]}; </xml>); + return <xml><body>{r}</body></xml> diff --git a/tests/jsbspace.py b/tests/jsbspace.py new file mode 100644 index 00000000..b29d44b9 --- /dev/null +++ b/tests/jsbspace.py @@ -0,0 +1,11 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + el = self.xpath('button') + el.click() + alert = self.driver.switch_to.alert + self.assertEqual('Some \btext', alert.text) diff --git a/tests/jsbspace.ur b/tests/jsbspace.ur new file mode 100644 index 00000000..bf4b824f --- /dev/null +++ b/tests/jsbspace.ur @@ -0,0 +1,12 @@ +fun main () : transaction page = +let + fun onclick (): transaction unit = + (* this function runs on the client *) + alert "Some \btext" +in +return <xml> + <body> + <button onclick={fn _ => onclick()}>Click me!</button> + </body> +</xml> +end
\ No newline at end of file diff --git a/tests/jsonTest.py b/tests/jsonTest.py new file mode 100644 index 00000000..d9147511 --- /dev/null +++ b/tests/jsonTest.py @@ -0,0 +1,16 @@ +import unittest +import base + +class Suite(base.Base): + def test_1(self): + """Test case 1""" + self.start() + + pre = self.xpath('pre[1]') + self.assertEqual('line 1\nline 2', pre.text) + + pre = self.xpath('pre[2]') + self.assertEqual('1 :: 2 :: 3 :: []', pre.text) + + pre = self.xpath('pre[3]') + self.assertEqual('["hi","bye\\"","hehe"]', pre.text) diff --git a/tests/jsonTest.ur b/tests/jsonTest.ur index 97898de8..bce269bd 100644 --- a/tests/jsonTest.ur +++ b/tests/jsonTest.ur @@ -1,6 +1,7 @@ open Json fun main () : transaction page = return <xml><body> - {[fromJson "[1, 2, 3]" : list int]}<br/> - {[toJson ("hi" :: "bye\"" :: "hehe" :: [])]} + <pre>{[ fromJson "\"\\\\line \/ 1\\nline 2\"" : string ]}</pre><br/> + <pre>{[fromJson "[1, 2, 3]" : list int]}</pre><br/> + <pre>{[toJson ("hi" :: "bye\"" :: "hehe" :: [])]}</pre> </body></xml> diff --git a/tests/listGroupBy.ur b/tests/listGroupBy.ur new file mode 100644 index 00000000..c2419ce1 --- /dev/null +++ b/tests/listGroupBy.ur @@ -0,0 +1,13 @@ +fun lister () = List.tabulateM (fn _ => n <- rand; return (n % 100)) 8 + +fun main () : transaction page = + inp <- source []; + return <xml><body> + <button value="Compute" onclick={fn _ => + ls <- rpc (lister ()); + set inp ls}/> + + <dyn signal={inp <- signal inp; return (txt inp)}/> + -> + <dyn signal={inp <- signal inp; return (txt (List.groupBy (fn n m => n % 2 = m % 2) inp))}/> + </body></xml> diff --git a/tests/listGroupBy.urp b/tests/listGroupBy.urp new file mode 100644 index 00000000..1a63a89d --- /dev/null +++ b/tests/listGroupBy.urp @@ -0,0 +1,4 @@ +rewrite all ListGroupBy/* + +$/list +listGroupBy
\ No newline at end of file diff --git a/tests/mimeTypesDirective.ur b/tests/mimeTypesDirective.ur new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/mimeTypesDirective.ur diff --git a/tests/mimeTypesDirective.urp b/tests/mimeTypesDirective.urp new file mode 100644 index 00000000..43f06a00 --- /dev/null +++ b/tests/mimeTypesDirective.urp @@ -0,0 +1,6 @@ +mimeTypes fake_types +file /hello.txt hello.txt +file /hello.html hello.html +file /hello2.txt hello.txt gadzooks/yippie + +mimeTypesDirective diff --git a/tests/pairUnify.ur b/tests/pairUnify.ur new file mode 100644 index 00000000..1c9f9759 --- /dev/null +++ b/tests/pairUnify.ur @@ -0,0 +1,6 @@ +datatype a = A +datatype b = B + +val x : a * b = (A, B) + +val y : b = x diff --git a/tests/slashform.ur b/tests/slashform.ur new file mode 100644 index 00000000..63591886 --- /dev/null +++ b/tests/slashform.ur @@ -0,0 +1,9 @@ +fun handler f = return <xml>{[f.F1]} {[f.F2]} {[f.F3]}</xml> + +val main = return <xml><body><form> + <textbox{#F1}/> + <textarea{#F2}/> + <checkbox{#F3}/> + <upload{#File}/> + <submit action={handler}/> +</form></body></xml> diff --git a/tests/slashform.urs b/tests/slashform.urs new file mode 100644 index 00000000..61778b87 --- /dev/null +++ b/tests/slashform.urs @@ -0,0 +1 @@ +val main : transaction page diff --git a/tests/unurlify2.ur b/tests/unurlify2.ur new file mode 100644 index 00000000..2e82928d --- /dev/null +++ b/tests/unurlify2.ur @@ -0,0 +1,16 @@ +datatype bugged = Nothing | Something of int +datatype myDt = One | Two +type myRecord = {Bugged: bugged + , MyDt : myDt} + +fun rpcTarget (t: myRecord) = return () + +val good = {Bugged = Something 4, MyDt = One} +val bad = {Bugged = Nothing, MyDt = One} + +fun main () : transaction page = return <xml> + <body> + <button onclick={fn _ => rpc (rpcTarget good)}>rpc with good</button> + <button onclick={fn _ => rpc (rpcTarget bad)}>rpc with bad</button> + </body> +</xml> |