diff options
-rw-r--r-- | include/urweb/urweb_cpp.h | 1 | ||||
-rw-r--r-- | lib/ur/basis.urs | 2 | ||||
-rw-r--r-- | lib/ur/listPair.ur | 16 | ||||
-rw-r--r-- | lib/ur/listPair.urs | 3 | ||||
-rw-r--r-- | lib/ur/option.ur | 5 | ||||
-rw-r--r-- | lib/ur/option.urs | 2 | ||||
-rw-r--r-- | src/c/urweb.c | 16 | ||||
-rw-r--r-- | src/cjr_print.sml | 24 | ||||
-rw-r--r-- | src/main.mlton.sml | 19 | ||||
-rw-r--r-- | src/settings.sml | 1 |
10 files changed, 78 insertions, 11 deletions
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 25f26e1b..18b5f583 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -263,6 +263,7 @@ uw_Basis_string uw_Basis_fileMimeType(struct uw_context *, uw_Basis_file); uw_Basis_blob uw_Basis_fileData(struct uw_context *, uw_Basis_file); uw_Basis_int uw_Basis_blobSize(struct uw_context *, uw_Basis_blob); uw_Basis_blob uw_Basis_textBlob(struct uw_context *, uw_Basis_string); +uw_Basis_string uw_Basis_textOfBlob(struct uw_context *, uw_Basis_blob); uw_Basis_string uw_Basis_postType(struct uw_context *, uw_Basis_postBody); uw_Basis_string uw_Basis_postData(struct uw_context *, uw_Basis_postBody); diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c893e65d..be13c684 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1019,6 +1019,8 @@ val checkMime : string -> option mimeType val returnBlob : t ::: Type -> blob -> mimeType -> transaction t val blobSize : blob -> int val textBlob : string -> blob +val textOfBlob : blob -> option string +(* Returns [Some] exactly when the blob contains no zero bytes. *) type postBody val postType : postBody -> string diff --git a/lib/ur/listPair.ur b/lib/ur/listPair.ur index 94b92872..c5e70708 100644 --- a/lib/ur/listPair.ur +++ b/lib/ur/listPair.ur @@ -40,7 +40,21 @@ fun mp [a] [b] [c] (f : a -> b -> c) = case (ls1, ls2) of ([], []) => [] | (x1 :: ls1, x2 :: ls2) => f x1 x2 :: map' ls1 ls2 - | _ => error <xml>ListPair.map2: Unequal list lengths</xml> + | _ => error <xml>ListPair.mp: Unequal list lengths</xml> in map' end + +fun mapM [m] (_ : monad m) [a] [b] [c] (f : a -> b -> m c) = + let + fun mapM' ls1 ls2 = + case (ls1, ls2) of + ([], []) => return [] + | (x1 :: ls1, x2 :: ls2) => + y <- f x1 x2; + ls <- mapM' ls1 ls2; + return (y :: ls) + | _ => error <xml>ListPair.mapM: Unequal list lengths</xml> + in + mapM' + end diff --git a/lib/ur/listPair.urs b/lib/ur/listPair.urs index b473e226..9efff405 100644 --- a/lib/ur/listPair.urs +++ b/lib/ur/listPair.urs @@ -8,3 +8,6 @@ val all : a ::: Type -> b ::: Type -> (a -> b -> bool) -> list a -> list b -> bo val mp : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> c) -> list a -> list b -> list c + +val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> c ::: Type + -> (a -> b -> m c) -> list a -> list b -> m (list c) diff --git a/lib/ur/option.ur b/lib/ur/option.ur index baa08466..dd186161 100644 --- a/lib/ur/option.ur +++ b/lib/ur/option.ur @@ -59,3 +59,8 @@ fun unsafeGet [a] (o : option a) = case o of None => error <xml>Option.unsafeGet: encountered None</xml> | Some v => v + +fun mapM [m] (_ : monad m) [a] [b] (f : a -> m b) (x : t a) : m (t b) = + case x of + None => return None + | Some y => z <- f y; return (Some z) diff --git a/lib/ur/option.urs b/lib/ur/option.urs index c30c40e7..705c0313 100644 --- a/lib/ur/option.urs +++ b/lib/ur/option.urs @@ -14,3 +14,5 @@ val bind : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b val get : a ::: Type -> a -> option a -> a val unsafeGet : a ::: Type -> option a -> a + +val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type -> (a -> m b) -> t a -> m (t b) diff --git a/src/c/urweb.c b/src/c/urweb.c index 4742bc3e..58f7884d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4132,6 +4132,20 @@ uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { return b; } +uw_Basis_string uw_Basis_textOfBlob(uw_context ctx, uw_Basis_blob b) { + size_t i; + uw_Basis_string r; + + for (i = 0; i < b.size; ++i) + if (b.data[i] == 0) + return NULL; + + r = uw_malloc(ctx, b.size + 1); + memcpy(r, b.data, b.size); + r[b.size] = 0; + return r; +} + uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { (void)ctx; return f.data; @@ -5264,7 +5278,7 @@ uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) { fd = mkstemp(tempfile); if (fd < 0) - uw_error(ctx, FATAL, "Error creating temporary file for cache"); + uw_error(ctx, FATAL, "Error creating temporary file %s for cache", tempfile); while (written_so_far < contents.size) { ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 31653a74..09cd9c7f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3391,6 +3391,14 @@ fun p_file env (ds, ps) = newline, string "#include <time.h>", newline, + (case Settings.getFileCache () of + NONE => box [] + | SOME _ => box [string "#include <sys/types.h>", + newline, + string "#include <sys/stat.h>", + newline, + string "#include <unistd.h>", + newline]), if hasDb then box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), newline] @@ -3655,7 +3663,21 @@ fun p_file env (ds, ps) = newline, string "static void uw_initializer(uw_context ctx) {", newline, - box [string "uw_begin_initializing(ctx);", + box [(case Settings.getFileCache () of + NONE => box [] + | SOME dir => box [newline, + string "struct stat st = {0};", + newline, + newline, + string "if (stat(\"", + string (Prim.toCString dir), + string "\", &st) == -1)", + newline, + box [string "mkdir(\"", + string (Prim.toCString dir), + string "\", 0700);", + newline]]), + string "uw_begin_initializing(ctx);", newline, p_list_sep newline (fn x => x) (rev (!global_initializers)), string "uw_end_initializing(ctx);", diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 57e89ef2..99005df5 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -175,7 +175,7 @@ fun oneRun args = demo := SOME (prefix, true)), NONE), ("tutorial", set_true tutorial, - NONE), + SOME "render HTML tutorials from .ur source files"), ("protocol", ONE ("[http|cgi|fastcgi|static]", Settings.setProtocol), SOME "set server protocol"), @@ -186,7 +186,7 @@ fun oneRun args = ("dbms", ONE ("[sqlite|mysql|postgres]", Settings.setDbms), SOME "select database engine"), ("debug", call_true Settings.setDebug, - NONE), + SOME "save some intermediate C files"), ("verbose", ZERO (fn () => (Compiler.debug := true; Elaborate.verbose := true)), @@ -202,7 +202,8 @@ fun oneRun args = ("unifyMore", set_true Elaborate.unifyMore, SOME "continue unification before reporting type error"), ("dumpSource", set_true Compiler.dumpSource, - NONE), + SOME ("print source code of last intermediate program "^ + "if there is an error")), ("dumpVerboseSource", ZERO (fn () => (Compiler.dumpSource := true; ElabPrint.debug := true; @@ -221,17 +222,19 @@ fun oneRun args = ("stop", ONE ("<phase>", Compiler.setStop), SOME "stop compilation after <phase>"), ("path", TWO ("<name>", "<path>", Compiler.addPath), - NONE), + SOME ("set path variable <name> to <path> for use in "^ + ".urp files")), ("root", TWO ("<name>", "<path>", (fn (name, path) => Compiler.addModuleRoot (path, name))), - NONE), + SOME "prefix names of modules found in <path> with <name>"), ("boot", ZERO (fn () => (Compiler.enableBoot (); Settings.setBootLinking true)), - NONE), + SOME ("run from build tree and generate statically linked "^ + "executables ")), ("sigfile", ONE ("<file>", Settings.setSigFile o SOME), - NONE), + SOME "search for cryptographic signing keys in <file>"), ("iflow", set_true Compiler.doIflow, NONE), ("sqlcache", call_true Settings.setSqlcache, @@ -243,7 +246,7 @@ fun oneRun args = ("noEmacs", set_true Demo.noEmacs, NONE), ("limit", TWO ("<class>", "<num>", add_class), - NONE), + SOME "set resource usage limit for <class> to <num>"), ("explainEmbed", set_true JsComp.explainEmbed, SOME ("explain errors about embedding of server-side "^ "values in client code")) diff --git a/src/settings.sml b/src/settings.sml index f42df135..0fea73e8 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -157,6 +157,7 @@ fun isEffectful ("Sqlcache", _) = true fun addEffectful x = effectful := S.add (!effectful, x) val benignBase = basis ["get_cookie", + "getenv", "new_client_source", "get_client_source", "set_client_source", |