From 3154131cddb8bc8fe76b86bd9f4902f1d531bce6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 31 Jul 2014 09:56:41 -0400 Subject: New .urp directive: file --- doc/manual.tex | 3 +- include/urweb/urweb_cpp.h | 1 + src/c/urweb.c | 5 +++ src/cjr_print.sml | 48 ++++++++++++++++++++-- src/compiler.sml | 9 ++++ src/settings.sig | 6 +++ src/settings.sml | 102 ++++++++++++++++++++++++++++++++++++++++++++++ tests/files.ur | 1 + tests/files.urp | 6 +++ tests/hello.txt | 1 + tests/web.png | Bin 0 -> 9565 bytes 11 files changed, 178 insertions(+), 4 deletions(-) create mode 100644 tests/files.ur create mode 100644 tests/files.urp create mode 100644 tests/hello.txt create mode 100644 tests/web.png diff --git a/doc/manual.tex b/doc/manual.tex index 2218d2c5..32ed9fc2 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -146,7 +146,8 @@ Here is the complete list of directive forms. ``FFI'' stands for ``foreign func \item \texttt{database DBSTRING} sets the string to pass to libpq to open a database connection. \item \texttt{debug} saves some intermediate C files, which is mostly useful to help in debugging the compiler itself. \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{exe FILENAME} sets the filename to which to write the output executable. The default for file \texttt{P.urp} is \texttt{P.exe}. +\item \texttt{file URI FILENAME} asks for the application executable to respond to requests for \texttt{URI} by serving a snapshot of the contents of \texttt{FILENAME} as of compile time. That is, the file contents are baked into the executable. System file \texttt{/etc/mime.types} is consulted (again, at compile time) to figure out the right MIME type to suggest in the HTTP response. \item \texttt{ffi FILENAME} reads the file \texttt{FILENAME.urs} to determine the interface to a new FFI module. The name of the module is calculated from \texttt{FILENAME} in the same way as for normal source files. See the files \texttt{include/urweb/urweb\_cpp.h} and \texttt{src/c/urweb.c} for examples of C headers and implementations for FFI modules. In general, every type or value \texttt{Module.ident} becomes \texttt{uw\_Module\_ident} in C. \item \texttt{html5} activates work-in-progress support for generating HTML5 instead of XHTML. For now, this option only affects the first few tokens on any page, which are always the same. \item \texttt{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. diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 5a4411e8..72997a12 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -263,6 +263,7 @@ void uw_mayReturnIndirectly(struct uw_context *); __attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType); __attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType); __attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url); +void uw_replace_page(struct uw_context *, const char *data, size_t size); uw_Basis_time uw_Basis_now(struct uw_context *); uw_Basis_time uw_Basis_addSeconds(struct uw_context *, uw_Basis_time, uw_Basis_int); diff --git a/src/c/urweb.c b/src/c/urweb.c index a9e722ad..1799d01e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -3861,6 +3861,11 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); } +void uw_replace_page(uw_context ctx, const char *data, size_t size) { + uw_buffer_reset(&ctx->page); + ctx_uw_buffer_append(ctx, "page", &ctx->page, data, size); +} + __attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) { cleanup *cl; int len; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 05dce35e..9046acc8 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -3293,6 +3293,17 @@ fun p_file env (ds, ps) = val now = Time.now () val nowD = Date.fromTimeUniv now val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT" + + fun hexifyByte (b : Word8.word) : string = + let + val s = Int.fmt StringCvt.HEX (Word8.toInt b) + in + "\\x" ^ (if size s < 2 then "0" else "") ^ s + end + + fun hexify (v : Word8Vector.vector) : string = + String.concat (Word8Vector.foldr (fn (b, ls) => + hexifyByte b :: ls) [] v) in box [string "#include \"", string (OS.Path.joinDirFile {dir = !Settings.configInclude, @@ -3476,9 +3487,9 @@ fun p_file env (ds, ps) = string "}", newline, newline, - string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");", + string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");", newline, - string ("uw_write_header(ctx, \"Last-modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"), + string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt nowD ^ "\\r\\n\");"), newline, string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, @@ -3487,6 +3498,37 @@ fun p_file env (ds, ps) = string "return;", newline], string "}", + newline, + newline, + + p_list_sep newline (fn r => + box [string "if (!strcmp(request, \"", + string (String.toCString (#Uri r)), + string "\")) {", + newline, + box [(case #ContentType r of + NONE => box [] + | SOME ct => box [string "uw_write_header(ctx, \"Content-Type: ", + string (String.toCString ct), + string "\\r\\n\");", + newline]), + string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt (Date.fromTimeUniv (#LastModified r)) ^ "\\r\\n\");"), + newline, + string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), + newline, + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + newline, + string "uw_replace_page(ctx, \"", + string (hexify (#Bytes r)), + string "\", ", + string (Int.toString (Word8Vector.length (#Bytes r))), + string ");", + newline, + string "return;", + newline], + string "};", + newline]) (Settings.listFiles ()), + newline, p_list_sep newline (fn x => x) pds', newline, diff --git a/src/compiler.sml b/src/compiler.sml index 269a7824..2190684a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -461,6 +461,8 @@ fun parseUrp' accLibs fname = end else let + val thisPath = OS.Path.dir fname + val pathmap = ref (!pathmap) val bigLibs = ref [] @@ -876,6 +878,13 @@ fun parseUrp' accLibs fname = | "html5" => Settings.setIsHtml5 true | "lessSafeFfi" => Settings.setLessSafeFfi true + | "file" => + (case String.fields Char.isSpace arg of + [uri, fname] => (Settings.setFilePath thisPath; + Settings.addFile {Uri = uri, + LoadFromFilename = fname}) + | _ => ErrorMsg.error "Bad 'file' arguments") + | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end diff --git a/src/settings.sig b/src/settings.sig index 29c4c506..9b32e502 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -278,4 +278,10 @@ signature SETTINGS = sig val setLessSafeFfi : bool -> unit val getLessSafeFfi : unit -> bool + + val setFilePath : string -> unit + (* Sets the directory where we look for files being added below. *) + + val addFile : {Uri : string, LoadFromFilename : string} -> unit + val listFiles : unit -> {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector} list end diff --git a/src/settings.sml b/src/settings.sml index ff3ab83a..eb350c95 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,4 +744,106 @@ val less = ref false fun setLessSafeFfi b = less := b fun getLessSafeFfi () = !less +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) + +val noMimeFile = ref false + +fun noMime () = + (TextIO.output (TextIO.stdErr, "WARNING: Error opening /etc/mime.types. Static files will be served with no suggested MIME types.\n"); + noMimeFile := true; + SM.empty) + +fun readMimeTypes () = + let + val inf = TextIO.openIn "/etc/mime.types" + + fun loop m = + case TextIO.inputLine inf of + NONE => m + | SOME line => + if size line > 0 andalso String.sub (line, 0) = #"#" then + loop m + else + case String.tokens Char.isSpace line of + typ :: exts => + loop (foldl (fn (ext, m) => SM.insert (m, ext, typ)) m exts) + | _ => loop m + in + loop SM.empty + before TextIO.closeIn inf + end handle IO.Io _ => noMime () + | OS.SysErr _ => noMime () + +val mimeTypes = ref (NONE : string SM.map option) + +fun getMimeTypes () = + case !mimeTypes of + SOME m => m + | NONE => + let + val m = readMimeTypes () + in + mimeTypes := SOME m; + m + end + +fun mimeTypeOf filename = + case OS.Path.ext filename of + NONE => (if !noMimeFile then + () + else + TextIO.output (TextIO.stdErr, "WARNING: No extension found in filename '" ^ filename ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n"); + NONE) + | SOME ext => + let + val to = SM.find (getMimeTypes (), ext) + in + case to of + NONE => if !noMimeFile then + () + else + TextIO.output (TextIO.stdErr, "WARNING: No MIME type known for extension '" ^ ext ^ "'. Header 'Content-Type' will be omitted in HTTP responses.\n") + | _ => (); + to + end + +val files = ref (SM.empty : (string * {Uri : string, ContentType : string option, LastModified : Time.time, Bytes : Word8Vector.vector}) SM.map) + +val filePath = ref "." + +fun setFilePath path = filePath := path + +fun addFile {Uri, LoadFromFilename} = + let + val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename} + in + case SM.find (!files, Uri) of + SOME (path', _) => + if path' = path then + () + else + ErrorMsg.error ("Two different files requested for URI " ^ Uri) + | NONE => + let + val inf = BinIO.openIn path + in + files := SM.insert (!files, + Uri, + (path, + {Uri = Uri, + ContentType = mimeTypeOf path, + LastModified = OS.FileSys.modTime path, + Bytes = BinIO.inputAll inf})); + BinIO.closeIn inf + end + end handle IO.Io _ => + ErrorMsg.error ("Error loading file " ^ LoadFromFilename) + | OS.SysErr (s, _) => + ErrorMsg.error ("Error loading file " ^ LoadFromFilename ^ " (" ^ s ^ ")") + +fun listFiles () = map #2 (SM.listItems (!files)) + end diff --git a/tests/files.ur b/tests/files.ur new file mode 100644 index 00000000..94cf8eb1 --- /dev/null +++ b/tests/files.ur @@ -0,0 +1 @@ +fun main () : transaction page = return Main page diff --git a/tests/files.urp b/tests/files.urp new file mode 100644 index 00000000..100992e5 --- /dev/null +++ b/tests/files.urp @@ -0,0 +1,6 @@ +rewrite all Files/* +file /hello_world.txt hello.txt +file /img/web.png web.png +file /files.urp files.urp + +files diff --git a/tests/hello.txt b/tests/hello.txt new file mode 100644 index 00000000..980a0d5f --- /dev/null +++ b/tests/hello.txt @@ -0,0 +1 @@ +Hello World! diff --git a/tests/web.png b/tests/web.png new file mode 100644 index 00000000..17548060 Binary files /dev/null and b/tests/web.png differ -- cgit v1.2.3