summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c5
-rw-r--r--src/cjr_print.sml48
-rw-r--r--src/compiler.sml9
-rw-r--r--src/settings.sig6
-rw-r--r--src/settings.sml102
5 files changed, 167 insertions, 3 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 15:35:32 +0000