The -dbms sqlite flag indicates that instead of using the default database management system (PostgreSQL), we wish to use SQLite (usually unsuited for production). The -db flag allows us to specify the file-system path to our SQLite database. The -demo /Demo parameter indicates that we want to build a demo application that expects its URIs to begin with /Demo. The final argument demo gives the path to a directory housing Ur/Web source files (.ur, .urp, .urs, etc.).
+
The -dbms sqlite flag indicates that instead of using the default database management system (PostgreSQL), we wish to use SQLite (usually unsuited for production). The -db flag allows us to specify the file-system path to our SQLite database. The -demo /Demo parameter indicates that we want to build a demo application that expects its URIs to begin with /Demo, while the -noEmacs parameter disables invocation of Emacs to syntax-highlight source files for HTML rendering. The final argument demo gives the path to a directory housing Ur/Web source files (.ur, .urp, .urs, etc.).
--
cgit v1.2.3
From 73fd5266bf7c1f05beb830c71107342c3a7be9c0 Mon Sep 17 00:00:00 2001
From: Peter Bock
Date: Fri, 29 Sep 2017 06:26:25 +0200
Subject: new flag -help, and refactoring of flag parsing.
---
src/main.mlton.sml | 343 ++++++++++++++++++++++++++++++-----------------------
1 file changed, 194 insertions(+), 149 deletions(-)
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 2caa43f8..3d28acdc 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";
+ ListUtil.appi 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 ("", Settings.setCCompiler),
+ SOME "set the C compiler to "),
+ ("demo", ONE ("", fn prefix =>
+ demo := SOME (prefix, false)),
+ NONE),
+ ("guided-demo", ONE ("", 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 ("", Settings.setUrlPrefix),
+ SOME "set prefix used before all URI's"),
+ ("db", ONE ("", Settings.setDbstring o SOME),
+ SOME "database connection information"),
+ ("dbms", ONE ("[sqlite|mysql|postgrsql]", 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 ("", Settings.setExe o SOME),
+ SOME "output executable as "),
+ ("js", ONE ("", Settings.setOutputJsFile o SOME),
+ SOME "serve javascript as "),
+ ("sql", ONE ("", Settings.setSql o SOME),
+ SOME "output sql script as "),
+ ("static", call_true Settings.setStaticLinking,
+ SOME "enable static linking"),
+ ("stop", ONE ("", Compiler.setStop),
+ SOME "stop compilation after "),
+ ("path", TWO ("", "", Compiler.addPath),
+ NONE),
+ ("root", TWO ("", "",
+ (fn (name, path) =>
+ Compiler.addModuleRoot (path, name))),
+ NONE),
+ ("boot", ZERO (fn () =>
+ (Compiler.enableBoot ();
+ Settings.setBootLinking true)),
+ NONE),
+ ("sigfile", ONE ("", Settings.setSigFile o SOME),
+ NONE),
+ ("iflow", set_true Compiler.doIflow,
+ NONE),
+ ("sqlcache", call_true Settings.setSqlcache,
+ NONE),
+ ("heuristic", ONE ("", Sqlcache.setHeuristic),
+ NONE),
+ ("moduleOf", ONE ("", printModuleOf),
+ SOME "print module name of and exit"),
+ ("noEmacs", set_true Demo.noEmacs,
+ NONE),
+ ("limit", TWO ("", "", add_class),
+ NONE),
+ ("explainEmbed", set_true JsComp.explainEmbed,
+ SOME ("explain errors about embedding of server-side "^
+ "values in clinent 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, _, _) =>
--
cgit v1.2.3
From 06452188bc3a4f04762214ba7bcf7d4d0e36c9f3 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 1 Oct 2017 16:50:15 -0400
Subject: README extension: installation and simple invocation
---
README.md | 39 +++++++++++++++++++++++++++++++++++++++
1 file changed, 39 insertions(+)
diff --git a/README.md b/README.md
index 3bfd94a1..433ef0bb 100644
--- a/README.md
+++ b/README.md
@@ -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.
+
+```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/).
--
cgit v1.2.3
From b1a6440a3fb285cdfd5301510b96b1ef3b96c050 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 1 Oct 2017 17:13:17 -0400
Subject: New .urp directives: mimeTypes and long form of file
---
doc/manual.tex | 2 ++
src/compiler.sig | 3 ++-
src/compiler.sml | 31 ++++++++++++++++++++++---------
src/demo.sml | 3 ++-
src/settings.sig | 5 ++++-
src/settings.sml | 13 +++++++++----
tests/fake_types | 2 ++
tests/mimeTypesDirective.ur | 0
tests/mimeTypesDirective.urp | 6 ++++++
9 files changed, 49 insertions(+), 16 deletions(-)
create mode 100644 tests/fake_types
create mode 100644 tests/mimeTypesDirective.ur
create mode 100644 tests/mimeTypesDirective.urp
diff --git a/doc/manual.tex b/doc/manual.tex
index eaf7aab5..1b476499 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -150,6 +150,7 @@ 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{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 +177,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.
diff --git a/src/compiler.sig b/src/compiler.sig
index 952c7070..0ff84f1c 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -62,7 +62,8 @@ signature COMPILER = sig
sigFile : 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
diff --git a/src/compiler.sml b/src/compiler.sml
index c13de304..3fb0b767 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -66,7 +66,8 @@ type job = {
sigFile : string option,
safeGets : string list,
onError : (string * string list * string) option,
- minHeap : int
+ minHeap : int,
+ mimeTypes : string option
}
type ('src, 'dst) phase = {
@@ -386,7 +387,8 @@ 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.setMimeFilePath (Option.getOpt (#mimeTypes job, "/etc/mime.types")))
datatype commentableLine =
EndOfFile
@@ -467,7 +469,8 @@ fun parseUrp' accLibs fname =
sigFile = NONE,
safeGets = [],
onError = NONE,
- minHeap = 0}
+ minHeap = 0,
+ mimeTypes = NONE}
in
institutionalizeJob job;
{Job = job, Libs = []}
@@ -601,6 +604,7 @@ fun parseUrp' accLibs fname =
val safeGets = ref []
val onError = ref NONE
val minHeap = ref 0
+ val mimeTypes = ref NONE
fun finish sources =
let
@@ -638,7 +642,8 @@ fun parseUrp' accLibs fname =
sigFile = !sigFile,
safeGets = rev (!safeGets),
onError = !onError,
- minHeap = !minHeap
+ minHeap = !minHeap,
+ mimeTypes = !mimeTypes
}
fun mergeO f (old, new) =
@@ -699,7 +704,8 @@ fun parseUrp' accLibs fname =
sigFile = mergeO #2 (#sigFile old, #sigFile 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
@@ -914,13 +920,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" =>
diff --git a/src/demo.sml b/src/demo.sml
index 62b9037a..a682d28d 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -125,7 +125,8 @@ fun make' {prefix, dirname, guided} =
sigFile = mergeWith #2 (#sigFile combined, #sigFile 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/settings.sig b/src/settings.sig
index 256a12b5..729218ac 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -298,7 +298,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 +306,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..d3ac99d4 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -843,14 +843,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,7 +911,7 @@ 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)
in
@@ -926,7 +929,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/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/mimeTypesDirective.ur b/tests/mimeTypesDirective.ur
new file mode 100644
index 00000000..e69de29b
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
--
cgit v1.2.3
From 2d22156b3814802c7f1c46db5f553af6904a794d Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 1 Oct 2017 17:32:07 -0400
Subject: Small tweaks to new help text
---
src/main.mlton.sml | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 3d28acdc..1229d552 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -79,7 +79,7 @@ fun usage flag_info =
| print_args (ONE (x, _)) = print (" " ^ x)
| print_args (TWO (x, y, _)) = print (" " ^ x ^ " " ^ y)
- fun print_flag (_, (flag, args, desc)) =
+ fun print_flag (flag, args, desc) =
(print (" -" ^ flag);
print_args args;
print_desc desc)
@@ -88,7 +88,7 @@ fun usage flag_info =
print (" " ^ name ^ " daemon [stop|start]\n");
print (" " ^ name ^ " [flag ...] project-name\n");
print "Supported flags are:\n";
- ListUtil.appi print_flag flag_info;
+ app print_flag flag_info;
raise Code OS.Process.success
end
@@ -172,7 +172,7 @@ fun oneRun args =
SOME "set prefix used before all URI's"),
("db", ONE ("", Settings.setDbstring o SOME),
SOME "database connection information"),
- ("dbms", ONE ("[sqlite|mysql|postgrsql]", Settings.setDbms),
+ ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms),
SOME "select database engine"),
("debug", call_true Settings.setDebug,
NONE),
@@ -202,7 +202,7 @@ fun oneRun args =
("output", ONE ("", Settings.setExe o SOME),
SOME "output executable as "),
("js", ONE ("", Settings.setOutputJsFile o SOME),
- SOME "serve javascript as "),
+ SOME "serve JavaScript as "),
("sql", ONE ("", Settings.setSql o SOME),
SOME "output sql script as "),
("static", call_true Settings.setStaticLinking,
@@ -235,7 +235,7 @@ fun oneRun args =
NONE),
("explainEmbed", set_true JsComp.explainEmbed,
SOME ("explain errors about embedding of server-side "^
- "values in clinent code"))
+ "values in client code"))
]
val () = case args of
--
cgit v1.2.3
From fb4e582bd0a673fc792d0fcc49fdcac2097bb0e0 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 11 Nov 2017 16:01:34 -0500
Subject: Manual fix: [self] only callable on the server
---
doc/manual.tex | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/doc/manual.tex b/doc/manual.tex
index 1b476499..985dab5b 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2237,7 +2237,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} \\
--
cgit v1.2.3
From 8604afcbc37276760ae74b2d1fbe200aa4b64dce Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 18 Nov 2017 15:42:31 -0500
Subject: README: mention that GNU Make is required
---
README.md | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/README.md b/README.md
index 433ef0bb..911d13f0 100644
--- a/README.md
+++ b/README.md
@@ -32,7 +32,7 @@ wget http://localhost:8080/Hello/main -O -
# Simple Installation
-The normal UNIX-style build and installation procedure works.
+The normal UNIX-style build and installation procedure works (where the `make` program needs to be GNU Make).
```sh
./configure
--
cgit v1.2.3
From a707c42ce3773318f80ed78eea653a581639fdba Mon Sep 17 00:00:00 2001
From: Vladimir Shabanov
Date: Tue, 5 Dec 2017 17:24:12 +0300
Subject: Added oninput event to inputs which support it.
Added onscroll event to and title/sizes attributes to .
---
lib/js/urweb.js | 8 +++++
lib/ur/basis.urs | 94 +++++++++++++++++++++++++++-----------------------------
src/monoize.sml | 4 +++
3 files changed, 57 insertions(+), 49 deletions(-)
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index ebe192ca..1a275451 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1389,6 +1389,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..c354d784 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -830,7 +830,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 +842,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 +875,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 +974,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 +995,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 +1032,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 +1063,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,24 +1073,23 @@ 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 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,
- Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val ctextarea : cformTag ([Rows = int, Cols = int, Placeholder = string, Source = source string] ++ boxAttrs ++ inputAttrs) []
(*** Tables *)
diff --git a/src/monoize.sml b/src/monoize.sml
index ddf6cd4c..60ff78ea 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3281,6 +3281,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),
--
cgit v1.2.3
From 5d6b1ac92263d41c32e896603b4fa3e1790c9d71 Mon Sep 17 00:00:00 2001
From: Vladimir Shabanov
Date: Wed, 13 Dec 2017 19:24:56 +0300
Subject: dynClass() now calculates and sets class and style attributes before
adding node to DOM.
---
lib/js/urweb.js | 19 +++++++++++++------
1 file changed, 13 insertions(+), 6 deletions(-)
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 1a275451..d8198ed0 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -1286,11 +1286,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 +1306,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 +1326,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) {
--
cgit v1.2.3
From 1c9b94a22036cec4e3d0430ca2991eefc8198350 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 6 Jan 2018 10:40:15 -0500
Subject: README: explain need to run autogen.sh (closes #93)
---
README.md | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/README.md b/README.md
index 911d13f0..5863d242 100644
--- a/README.md
+++ b/README.md
@@ -32,7 +32,7 @@ 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).
+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
--
cgit v1.2.3
From 458c671a9d5fb352aafebe4b9e1b00670e8e706f Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Mon, 8 Jan 2018 14:26:00 -0500
Subject: Proper handling of absolute paths for files to serve
---
src/settings.sml | 1 +
1 file changed, 1 insertion(+)
diff --git a/src/settings.sml b/src/settings.sml
index d3ac99d4..9e6d3e76 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -914,6 +914,7 @@ fun setFilePath path = filePath := path
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', _) =>
--
cgit v1.2.3
From e6567eca7c5567b8bd4a93ba516170aed9e30662 Mon Sep 17 00:00:00 2001
From: steinuil
Date: Mon, 26 Feb 2018 15:54:56 +0100
Subject: automatically enable foreign keys and WAL for SQLite
---
src/sqlite.sml | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/src/sqlite.sml b/src/sqlite.sml
index a9b6389d..0acd866b 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,7 +848,7 @@ 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",
--
cgit v1.2.3
From de2d8358dda08bfaf491d815df91d0c1ba33e7c9 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Tue, 13 Mar 2018 15:30:11 -0400
Subject: Handle empty SELECT clauses
---
src/monoize.sml | 27 +++++++++++++++------------
src/postgres.sml | 11 +++++++++--
2 files changed, 24 insertions(+), 14 deletions(-)
diff --git a/src/monoize.sml b/src/monoize.sml
index 60ff78ea..85a66e87 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 ""),
diff --git a/src/postgres.sml b/src/postgres.sml
index 404384d2..fac913f0 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));",
--
cgit v1.2.3
From 7d4a7a7f92095edfea1cb55a11e037667c2c21da Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Fri, 30 Mar 2018 18:01:44 -0400
Subject: Demo links escape frames
---
demo/more/prose | 4 ++--
demo/prose | 12 ++++++------
2 files changed, 8 insertions(+), 8 deletions(-)
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 @@
-
These are some extra demo applications written in Ur/Web. See the main demo for a more tutorial-like progression through language and library features.
+
These are some extra demo applications written in Ur/Web. See the main demo for a more tutorial-like progression through language and library features.
Ur/Web 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). Ur 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 Standard ML, with a few Haskell-isms added, and kinder, gentler versions added of many features from dependently typed languages like the logic behind Coq. 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.
+
Ur/Web 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). Ur 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 Standard ML, with a few Haskell-isms added, and kinder, gentler versions added of many features from dependently typed languages like the logic behind Coq. 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.
-
The page you are currently reading is a part of the demo included with the Ur/Web sources and supporting files available from GitHub. 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 the manual for more detailed instructions.
+
The page you are currently reading is a part of the demo included with the Ur/Web sources and supporting files available from GitHub. 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 the manual for more detailed instructions.
The -dbms sqlite flag indicates that instead of using the default database management system (PostgreSQL), we wish to use SQLite (usually unsuited for production). The -db flag allows us to specify the file-system path to our SQLite database. The -demo /Demo parameter indicates that we want to build a demo application that expects its URIs to begin with /Demo, while the -noEmacs parameter disables invocation of Emacs to syntax-highlight source files for HTML rendering. The final argument demo gives the path to a directory housing Ur/Web source files (.ur, .urp, .urs, etc.).
+
The -dbms sqlite flag indicates that instead of using the default database management system (PostgreSQL), we wish to use SQLite (usually unsuited for production). The -db flag allows us to specify the file-system path to our SQLite database. The -demo /Demo parameter indicates that we want to build a demo application that expects its URIs to begin with /Demo, while the -noEmacs parameter disables invocation of Emacs to syntax-highlight source files for HTML rendering. The final argument demo gives the path to a directory housing Ur/Web source files (.ur, .urp, .urs, etc.).
@@ -88,7 +88,7 @@ hello.urp
We must, of course, begin with "Hello World."
-
The project file justs list one filename prefix, hello. This causes both hello.urs and hello.ur to be pulled into the project. .urs files are like OCaml.mli files, and .ur files are like OCaml .ml files. That is, .urs files provide interfaces, and .ur files provide implementations. .urs files may be omitted for .ur files, in which case most permissive interfaces are inferred.
+
The project file justs list one filename prefix, hello. This causes both hello.urs and hello.ur to be pulled into the project. .urs files are like OCaml.mli files, and .ur files are like OCaml .ml files. That is, .urs files provide interfaces, and .ur files provide implementations. .urs files may be omitted for .ur files, in which case most permissive interfaces are inferred.
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. hello.urs tells us that we only export a function named main, taking no arguments and running a transaction that results in an HTML page. transaction is a monad in the spirit of the Haskell IO monad, with the intent that every operation performable in transaction 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.
@@ -114,7 +114,7 @@ form.urp
nested.urp
-
Here is an implementation of the tiny challenge problem from this web framework comparison. Using nested function definitions, it is easy to persist state across clicks.
+
Here is an implementation of the tiny challenge problem from this web framework comparison. Using nested function definitions, it is easy to persist state across clicks.
Ur/Web guarantees that compiled applications are immune to certain kinds of cross site request forgery. 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.
+
Ur/Web guarantees that compiled applications are immune to certain kinds of cross site request forgery. 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.
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.
--
cgit v1.2.3
From 1fef19035d2f3388e9ab0dad1889a4cad5c1ca3e Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 14 Apr 2018 14:17:31 -0400
Subject: List.existsM
---
lib/ur/list.ur | 15 +++++++++++++++
lib/ur/list.urs | 2 ++
2 files changed, 17 insertions(+)
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index cc533676..a7296552 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 =
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index fd56679d..37cbe442 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
--
cgit v1.2.3
From 0cadb1a719bc515af2449ac966e545a6599aee4d Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 14 Apr 2018 15:15:07 -0400
Subject: List.findM
---
lib/ur/list.ur | 15 +++++++++++++++
lib/ur/list.urs | 2 ++
2 files changed, 17 insertions(+)
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index a7296552..95d6fbc8 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -255,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 37cbe442..fe730152 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -60,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
--
cgit v1.2.3
From 2bc51bd866b52bc738f259ffe6e9fb8f6068a6b6 Mon Sep 17 00:00:00 2001
From: "majorseitan@blockfreie.org"
Date: Sat, 14 Apr 2018 21:56:09 -0400
Subject: Handling of JSON escape characters
1. Handle escape sequence chars
\t \n \r
2. Fail on unsupported escape characters.
Instead of skipping \ on unsupported
sequences it now fails.
---
lib/ur/json.ur | 22 +++++++++++++++++-----
tests/jsonTest.ur | 1 +
2 files changed, 18 insertions(+), 5 deletions(-)
diff --git a/lib/ur/json.ur b/lib/ur/json.ur
index 9288a6dd..1e3e3f39 100644
--- a/lib/ur/json.ur
+++ b/lib/ur/json.ur
@@ -46,10 +46,14 @@ 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 +94,15 @@ fun unescape s =
if i+1 >= len then
error JSON unescape: Bad escape sequence: {[s]}
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 JSON unescape: Bad escape char: {[x]})
+ ^
+ unesc (i+2)
| _ => String.str ch ^ unesc (i+1)
end
in
diff --git a/tests/jsonTest.ur b/tests/jsonTest.ur
index 97898de8..1be6e7b5 100644
--- a/tests/jsonTest.ur
+++ b/tests/jsonTest.ur
@@ -1,6 +1,7 @@
open Json
fun main () : transaction page = return
+
{[ fromJson "\"line 1\\nline 2\"" : string ]}
{[fromJson "[1, 2, 3]" : list int]}
{[toJson ("hi" :: "bye\"" :: "hehe" :: [])]}
--
cgit v1.2.3
From e2552a79ed87721a81c246b9cfd053701d665f25 Mon Sep 17 00:00:00 2001
From: "majorseitan@blockfreie.org"
Date: Sun, 15 Apr 2018 16:20:31 -0400
Subject: Handling of JSON escape characters
1. Handle the escape character
\\
---
lib/ur/json.ur | 2 ++
tests/jsonTest.ur | 2 +-
2 files changed, 3 insertions(+), 1 deletion(-)
diff --git a/lib/ur/json.ur b/lib/ur/json.ur
index 1e3e3f39..7ebb010f 100644
--- a/lib/ur/json.ur
+++ b/lib/ur/json.ur
@@ -52,6 +52,7 @@ fun escape s =
| #"\t" => "\\t"
| #"\"" => "\\\""
| #"\'" => "\\\'"
+ | #"\\" => "\\\\"
| x => String.str ch
) ^ esc (String.suffix s 1)
end
@@ -100,6 +101,7 @@ fun unescape s =
| #"t" => "\t"
| #"\"" => "\""
| #"\'" => "\'"
+ | #"\\" => "\\"
| x => error JSON unescape: Bad escape char: {[x]})
^
unesc (i+2)
diff --git a/tests/jsonTest.ur b/tests/jsonTest.ur
index 1be6e7b5..071cf34b 100644
--- a/tests/jsonTest.ur
+++ b/tests/jsonTest.ur
@@ -1,7 +1,7 @@
open Json
fun main () : transaction page = return
-