New .urp directive: file

11 files changed, 178 insertions, 4 deletions

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,
@@ -3488,6 +3499,37 @@ fun p_file env (ds, ps) =
                   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,
              string "uw_clear_headers(ctx);",
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 <xml>Main page</xml>
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
--- /dev/null
+++ b/tests/web.png