diff options
| -rw-r--r-- | src/cjr_print.sml | 63 | ||||
| -rw-r--r-- | src/compiler.sml | 8 | ||||
| -rw-r--r-- | src/demo.sml | 4 | ||||
| -rw-r--r-- | src/elab_err.sml | 2 | ||||
| -rw-r--r-- | src/fileio.sig | 9 | ||||
| -rw-r--r-- | src/fileio.sml | 34 | ||||
| -rw-r--r-- | src/globals.sig | 7 | ||||
| -rw-r--r-- | src/globals.sml | 7 | ||||
| -rw-r--r-- | src/jscomp.sml | 2 | ||||
| -rw-r--r-- | src/main.mlton.sml | 5 | ||||
| -rw-r--r-- | src/settings.sig | 1 | ||||
| -rw-r--r-- | src/settings.sml | 9 | ||||
| -rw-r--r-- | src/sha1.sig | 31 | ||||
| -rw-r--r-- | src/sha1.sml | 264 | ||||
| -rw-r--r-- | src/sources | 9 | ||||
| -rw-r--r-- | src/tutorial.sml | 4 |
16 files changed, 413 insertions, 46 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b2c85a54..688b3e4d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -55,6 +55,8 @@ structure CM = BinaryMapFn(struct val debug = ref false +val app_js = ref "" + val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan) val ident = String.translate (fn #"'" => "PRIME" @@ -2509,9 +2511,15 @@ fun p_decl env (dAll as (d, loc) : decl) = | DDatabase _ => box [] | DPreparedStatements _ => box [] - | DJavaScript s => box [string "static char jslib[] = \"", - string (Prim.toCString s), - string "\";"] + | DJavaScript s => + let + val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), + file = "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"} + in + box [string "static char jslib[] = \"", + string (Prim.toCString s), + string "\";"] + end | DCookie s => box [string "/*", space, string "cookie", @@ -2948,15 +2956,11 @@ fun p_file env (ds, ps) = newline] end - val timestamp = LargeInt.toString (Time.toMilliseconds (Time.now ())) - val app_js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (), - file = "app." ^ timestamp ^ ".js"} - - val allScripts = + fun allScripts () = foldl (fn (x, scripts) => scripts ^ "<script type=\\\"text/javascript\\\" src=\\\"" ^ x ^ "\\\"></script>\\n") - "" (Settings.getScripts () @ [app_js]) + "" (Settings.getScripts () @ [!app_js]) fun p_page (ek, s, n, ts, ran, side, dbmode, tellSig) = let @@ -3098,7 +3102,7 @@ fun p_file env (ds, ps) = val scripts = case side of ServerOnly => "" - | _ => allScripts + | _ => allScripts () in string scripts end, @@ -3306,8 +3310,7 @@ fun p_file env (ds, ps) = val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds - val now = Time.now () - val nowD = Date.fromTimeUniv now + val lastMod = Date.fromTimeUniv (FileIO.mostRecentModTime ()) val rfcFmt = "%a, %d %b %Y %H:%M:%S GMT" fun hexifyByte (b : Word8.word) : string = @@ -3496,26 +3499,26 @@ fun p_file env (ds, ps) = string "static void uw_handle(uw_context ctx, char *request) {", newline, - string "if (!strcmp(request, \"", - string app_js, - string "\")) {", + string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");", newline, - box [string "uw_Basis_string ims = uw_Basis_requestHeader(ctx, \"If-modified-since\");", - newline, - string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt nowD ^ "\")) {"), - newline, - box [string "uw_clear_headers(ctx);", - newline, - string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");", - newline, - string "return;", - newline], - string "}", + string ("if (ims && !strcmp(ims, \"" ^ Date.fmt rfcFmt lastMod ^ "\")) {"), + newline, + box [string "uw_clear_headers(ctx);", newline, + string "uw_write_header(ctx, uw_supports_direct_status ? \"HTTP/1.1 304 Not Modified\\r\\n\" : \"Status: 304 Not Modified\\r\\n\");", newline, - string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");", + string "return;", + newline], + string "}", + newline, + newline, + string "if (!strcmp(request, \"", + string (!app_js), + string "\")) {", + newline, + box [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 lastMod ^ "\\r\\n\");"), newline, string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, @@ -3538,7 +3541,7 @@ fun p_file env (ds, ps) = string (String.toCString ct), string "\\r\\n\");", newline]), - string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt (Date.fromTimeUniv (#LastModified r)) ^ "\\r\\n\");"), + string ("uw_write_header(ctx, \"Last-Modified: " ^ Date.fmt rfcFmt lastMod ^ "\\r\\n\");"), newline, string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), newline, @@ -3634,7 +3637,7 @@ fun p_file env (ds, ps) = newline, if !hasJs then box [string "uw_set_script_header(ctx, \"", - string allScripts, + string (allScripts ()), string "\");", newline] else diff --git a/src/compiler.sml b/src/compiler.sml index dccda06d..87d175ed 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -212,7 +212,7 @@ val parseUrs = val fname = OS.FileSys.tmpName () val outf = TextIO.openOut fname val () = TextIO.output (outf, "sig\n") - val inf = TextIO.openIn filename + val inf = FileIO.txtOpenIn filename fun loop () = case TextIO.inputLine inf of NONE => () @@ -225,7 +225,7 @@ val parseUrs = val () = (ErrorMsg.resetErrors (); ErrorMsg.resetPositioning filename; Lex.UserDeclarations.initialize ()) - val file = TextIO.openIn fname + val file = FileIO.txtOpenIn fname fun get _ = TextIO.input file fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s val lexer = LrParser.Stream.streamify (Lex.makeLexer get) @@ -251,7 +251,7 @@ val parseUr = { val () = (ErrorMsg.resetErrors (); ErrorMsg.resetPositioning filename; Lex.UserDeclarations.initialize ()) - val file = TextIO.openIn filename + val file = FileIO.txtOpenIn filename fun get _ = TextIO.input file fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s val lexer = LrParser.Stream.streamify (Lex.makeLexer get) @@ -478,7 +478,7 @@ fun parseUrp' accLibs fname = val thisPath = OS.Path.dir filename val dir = OS.Path.dir filename - fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) + fun opener () = FileIO.txtOpenIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) val inf = opener () diff --git a/src/demo.sml b/src/demo.sml index 0d9f0f4f..47d22395 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -33,7 +33,7 @@ fun make' {prefix, dirname, guided} = let val prose = OS.Path.joinDirFile {dir = dirname, file = "prose"} - val inf = TextIO.openIn prose + val inf = FileIO.txtOpenIn prose val outDir = OS.Path.concat (dirname, "out") @@ -351,7 +351,7 @@ fun make' {prefix, dirname, guided} = SOME "urp" => doit (fn (src, html) => let - val inf = TextIO.openIn src + val inf = FileIO.txtOpenIn src val out = TextIO.openOut html fun loop () = diff --git a/src/elab_err.sml b/src/elab_err.sml index 33daa118..385caca3 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -275,7 +275,7 @@ fun p_decl env d = fun readFromFile () = let - val inf = TextIO.openIn fname + val inf = FileIO.txtOpenIn fname fun loop acc = case TextIO.inputLine inf of diff --git a/src/fileio.sig b/src/fileio.sig new file mode 100644 index 00000000..37b3b529 --- /dev/null +++ b/src/fileio.sig @@ -0,0 +1,9 @@ +signature FILE_IO = sig + + (* When was a source file last modified (excluding files produced after [getResetTime])? *) + val mostRecentModTime : unit -> Time.time + + val txtOpenIn : string -> TextIO.instream + val binOpenIn : string -> BinIO.instream + +end diff --git a/src/fileio.sml b/src/fileio.sml new file mode 100644 index 00000000..72e72f6d --- /dev/null +++ b/src/fileio.sml @@ -0,0 +1,34 @@ +structure FileIO :> FILE_IO = struct + +val mostRecentModTimeRef = ref (Time.zeroTime) + +fun checkFileModTime fname = + let val mtime = OS.FileSys.modTime fname in + if Time.compare (mtime, !mostRecentModTimeRef) = GREATER andalso + Time.compare (mtime, Globals.getResetTime ()) = LESS + then mostRecentModTimeRef := mtime + else () + end + +fun mostRecentModTime () = + if Time.compare (!mostRecentModTimeRef, Time.zeroTime) = EQUAL + then Globals.getResetTime () + else !mostRecentModTimeRef + +fun txtOpenIn fname = + let + val inf = TextIO.openIn fname + val () = checkFileModTime fname + in + inf + end + +fun binOpenIn fname = + let + val inf = BinIO.openIn fname + val () = checkFileModTime fname + in + inf + end + +end diff --git a/src/globals.sig b/src/globals.sig new file mode 100644 index 00000000..0cff65b5 --- /dev/null +++ b/src/globals.sig @@ -0,0 +1,7 @@ +signature GLOBALS = sig + + (* When was the Ur/Web compiler started or reset? *) + val setResetTime : unit -> unit + val getResetTime : unit -> Time.time + +end diff --git a/src/globals.sml b/src/globals.sml new file mode 100644 index 00000000..fafc0438 --- /dev/null +++ b/src/globals.sml @@ -0,0 +1,7 @@ +structure Globals :> GLOBALS = struct + +val resetTime = ref (Time.zeroTime) +fun setResetTime () = resetTime := Time.now () +fun getResetTime () = !resetTime + +end diff --git a/src/jscomp.sml b/src/jscomp.sml index 65a0fa3a..dedcb554 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -1334,7 +1334,7 @@ fun process (file : file) = maxName = U.File.maxName file + 1} (#1 file) - val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) + val inf = FileIO.txtOpenIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) fun lines acc = case TextIO.inputLine inf of NONE => String.concat (rev acc) diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 6d368106..fb1a1723 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -254,7 +254,8 @@ fun send (sock, s) = send (sock, String.extract (s, n, NONE)) end -val () = case CommandLine.arguments () of +val () = (Globals.setResetTime (); + case CommandLine.arguments () of ["daemon", "start"] => (case Posix.Process.fork () of SOME _ => () @@ -376,4 +377,4 @@ val () = case CommandLine.arguments () of else (OS.FileSys.remove socket; raise OS.SysErr ("", NONE)) - end handle OS.SysErr _ => OS.Process.exit (oneRun args) + end handle OS.SysErr _ => OS.Process.exit (oneRun args)) diff --git a/src/settings.sig b/src/settings.sig index dd135bda..05ab5e23 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -302,4 +302,5 @@ signature SETTINGS = sig val addJsFile : string (* filename *) -> unit val listJsFiles : unit -> {Filename : string, Content : string} list + end diff --git a/src/settings.sml b/src/settings.sml index b72789df..f4d399dc 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -844,7 +844,7 @@ fun noMime () = fun readMimeTypes () = let - val inf = TextIO.openIn "/etc/mime.types" + val inf = FileIO.txtOpenIn "/etc/mime.types" fun loop m = case TextIO.inputLine inf of @@ -914,7 +914,7 @@ fun addFile {Uri, LoadFromFilename} = ErrorMsg.error ("Two different files requested for URI " ^ Uri ^ " ( " ^ path' ^ " vs. " ^ path ^ ")") | NONE => let - val inf = BinIO.openIn path + val inf = FileIO.binOpenIn path in files := SM.insert (!files, Uri, @@ -937,7 +937,7 @@ val jsFiles = ref (SM.empty : {Filename : string, Content : string} SM.map) fun addJsFile LoadFromFilename = let val path = OS.Path.concat (!filePath, LoadFromFilename) - val inf = TextIO.openIn path + val inf = FileIO.txtOpenIn path in jsFiles := SM.insert (!jsFiles, path, @@ -952,7 +952,8 @@ fun addJsFile LoadFromFilename = fun listJsFiles () = SM.listItems (!jsFiles) fun reset () = - (urlPrefixFull := "/"; + (Globals.setResetTime (); + urlPrefixFull := "/"; urlPrefix := "/"; urlPrePrefix := ""; timeout := 0; diff --git a/src/sha1.sig b/src/sha1.sig new file mode 100644 index 00000000..7fda97f5 --- /dev/null +++ b/src/sha1.sig @@ -0,0 +1,31 @@ + +(* Implementation the SHA-1 hash function. + Written by Tom 7 in 2004; code in the public domain. *) + +signature SHA1 = +sig + + (* Perform the SHA-1 hash function on a message. + Returns the 160 bit (20 byte) hash. + + recall that string = CharVector.vector. + The input string may contain non-ascii data; + the output certainly will. *) + + val hash : string -> string + + (* pass in a stream as stateful function that returns + SOME s for some non-empty prefix of the remainder of + the stream, or NONE when the stream has ended. *) + val hash_stream : (unit -> string option) -> string + + (* XXX move to hashutil *) + (* convert a binary string to one built of hex digits *) + val bintohex : string -> string + + (* Parse a hexadecimal SHA-1 string. Uppercase and lowercase + are permitted. If the string is not the right length or + contains invalid characters, returns NONE. *) + val parse_hex : string -> string option + +end diff --git a/src/sha1.sml b/src/sha1.sml new file mode 100644 index 00000000..d962c4e0 --- /dev/null +++ b/src/sha1.sml @@ -0,0 +1,264 @@ + +(* RFC-3174 (SHA-1) hashing function. + By Tom 7, 2004: Code placed in the public domain. +*) + +structure SHA1 :> SHA1 = +struct + exception Unimplemented + + val xorb = Word32.xorb + val andb = Word32.andb + val orb = Word32.orb + val << = Word32.<< + val >> = Word32.>> + val notb = Word32.notb + val ++ = Word32.+ + + type w32 = word + infix xorb andb orb << >> ++ + + (* workaround for andb bug in MLton 20010706 *) + fun mkbyte w = Word32.mod (w, 0w256) + + fun ROL(X, N : Word.word) = (X << N) orb (X >> (0w32-N)) + + fun wc hi lo = (hi << 0w16) orb lo + + fun w2b w = map chr + [Word32.toInt (mkbyte (w >> 0w24)), + Word32.toInt (mkbyte (w >> 0w16)), + Word32.toInt (mkbyte (w >> 0w8)), + Word32.toInt (mkbyte w)] + + (* the length (arg in bytes, output in bits) + as a 64-bit quantity, big-endian *) + fun lenbits l = + implode (List.tabulate (4, fn _ => chr 0)) ^ + implode (w2b (Word32.fromInt (l * 8))) + + + (* executes f for each index lo..hi-1 inclusive *) + fun for lo hi f = + if lo >= hi then () + else (ignore (f lo); for (lo + 1) hi f) + + fun ford lo hi b f = + if lo >= hi then b + else + let + val b = f (lo, b) + in + (ford (lo + 1) hi b f) + end + + fun doblock (aa, bb, cc, dd, ee) msg = + let + val K0 = wc 0wx5A82 0wx7999 + val K1 = wc 0wx6ED9 0wxEBA1 + val K2 = wc 0wx8F1B 0wxBCDC + val K3 = wc 0wxCA62 0wxC1D6 + + fun mb n = Word32.fromInt (ord (CharVector.sub(msg, n))) + + val W = Array.array(80, 0w0) + fun Ws x = Array.sub(W, x) + + val _ = + for 0 16 + (fn t => + let in + Array.update(W, t, + (mb (t * 4 ) << 0w24) orb + (mb (t * 4 + 1) << 0w16) orb + (mb (t * 4 + 2) << 0w8) orb + (mb (t * 4 + 3))) + end) + + val _ = + for 16 80 + (fn t => + let + val n = + Ws (t-3) xorb + Ws (t-8) xorb + Ws (t-14) xorb + Ws (t-16) + val zz = ROL(n, 0w1) + in + Array.update(W, t, zz) + end) + + + val (A, B, C, D, E) = (aa, bb, cc, dd, ee) + + + fun round lo hi f k ctxt = + ford lo hi ctxt + (fn (t, ctxt as (A, B, C, D, E)) => + let + val temp = ROL(A, 0w5) ++ (f ctxt) ++ E ++ Ws t ++ k + val E = D; + val D = C; + val C = ROL(B, 0w30) + val B = A + val A = temp + in + (A, B, C, D, E) + end) + + val (A, B, C, D, E) = + round 0 20 (fn (A, B, C, D, E) => + ((B andb C) orb ((notb B) andb D))) + K0 (A, B, C, D, E) + + val (A, B, C, D, E) = + round 20 40 (fn (A, B, C, D, E) => + (B xorb C xorb D)) + K1 (A, B, C, D, E) + + val (A, B, C, D, E) = + round 40 60 (fn (A, B, C, D, E) => + ((B andb C) orb (B andb D) orb (C andb D))) + K2 (A, B, C, D, E) + + val (A, B, C, D, E) = + round 60 80 (fn (A, B, C, D, E) => + (B xorb C xorb D)) + K3 (A, B, C, D, E) + + in + (aa ++ A, bb ++ B, cc ++ C, dd ++ D, ee ++ E) + end + + datatype 'a stream = + Cons of ('a * (unit -> 'a stream)) + | Nil + + (* turn a stream of oddly chunked strings into + one with 512-bit blocks *) + fun chunk_512 s = + let + + (* the padding required to make a message of length l (bytes) + a proper SHA-1 input. Returns either one or two Cons cells. + tail is the end of the input (63 bytes or less) + l is the total length of the input, *including* the length of the + tail end *) + fun padding tail l = + let val v = l mod 64 in + if v < 56 then + let val p = 56 - v + val padding = implode (List.tabulate (p - 1, fn _ => chr 0)) + in Cons (tail ^ str (chr 0x80) ^ padding ^ lenbits l, + fn _ => Nil) + end + else if v < 64 then + let val p = 64 - v + val padding1 = implode (List.tabulate (p - 1, fn _ => chr 0)) + val padding2 = implode (List.tabulate (56, fn _ => chr 0)) + in Cons (tail ^ str (chr 0x80) ^ padding1, + fn _ => Cons (padding2 ^ lenbits l, fn _ => Nil)) + end + else raise Unimplemented (* Impossible? *) + end + + (* n is the bytes we've already output. + cur is a string (of 64 bytes or less) that will + be our next chunk. + rest,sofar is a string and index indicating the + next bit of data. *) + (* PERF Could be more efficient by using an + accumulating array instead of a string for cur *) + fun ch n cur sofar startat () = + (* if we already have 64 bytes, return it *) + if size cur = 64 + then + let in + Cons(cur, ch (n + 64) "" sofar startat) + end + else + (* do we have any in 'sofar'? *) + if startat < size sofar + then let + val get = Int.min(size sofar - startat, + 64 - size cur) + in + (* be eager, since we need to return something now *) + ch n (cur ^ String.substring(sofar, startat, get)) + sofar (startat + get) () + end + else + (* sofar has been exhausted, + so get some from input stream *) + (case s () of + (* eager, again *) + SOME ss => ch n cur ss 0 () + | NONE => + (* no more data. *) + padding cur (n + size cur)) + in + ch 0 "" "" 0 + end + + fun hash_stream orig_stream = + let + + val stream512 = chunk_512 orig_stream + + (* gets hash context, length of string so far (bytes), + and tail of stream *) + fun hash_rest stream ctxt = + (case stream() of + Cons (s, stream) => + let val ctxt = doblock ctxt s + in hash_rest stream ctxt + end + | Nil => ctxt) + + val init = + (wc 0wx6745 0wx2301, + wc 0wxefcd 0wxab89, + wc 0wx98ba 0wxdcfe, + wc 0wx1032 0wx5476, + wc 0wxc3d2 0wxe1f0) + + val (a, b, c, d, e) = hash_rest stream512 init + in + implode (w2b a @ w2b b @ w2b c @ w2b d @ w2b e) + end + + fun hash m = + hash_stream + (let val r = ref true + in (fn () => + if !r + then (r := false; SOME m) + else NONE) + end) + + val digits = "0123456789ABCDEF" + fun bintohex s = + String.translate (fn c => + implode [CharVector.sub (digits, ord c div 16), + CharVector.sub (digits, ord c mod 16)]) s + + (* ASCII trick: (ch | 4400) % 55 *) + fun hexvalue ch = + SysWord.toInt (SysWord.orb(SysWord.fromInt(ord ch), SysWord.fromInt 4400)) mod 55 + + fun parse_hex s = + if size s <> 40 + orelse not (CharVector.all (fn c => (ord c >= ord #"0" andalso + ord c <= ord #"9") orelse + (ord c >= ord #"a" andalso + ord c <= ord #"f") orelse + (ord c >= ord #"A" andalso + ord c <= ord #"F")) s) + then NONE + else SOME (CharVector.tabulate(20, + (fn i => + chr(hexvalue (String.sub(s, i * 2)) * 16 + + hexvalue (String.sub(s, i * 2 + 1)))))) + +end diff --git a/src/sources b/src/sources index 1a09e7e8..52b1bdd7 100644 --- a/src/sources +++ b/src/sources @@ -1,6 +1,9 @@ $(SRC)/config.sig config.sml +$(SRC)/globals.sig +$(SRC)/globals.sml + $(SRC)/search.sig $(SRC)/search.sml @@ -16,6 +19,9 @@ $(SRC)/errormsg.sml $(SRC)/print.sig $(SRC)/print.sml +$(SRC)/fileio.sig +$(SRC)/fileio.sml + $(SRC)/settings.sig $(SRC)/settings.sml @@ -227,6 +233,9 @@ $(SRC)/sigcheck.sml $(SRC)/mono_inline.sml +$(SRC)/sha1.sig +$(SRC)/sha1.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/tutorial.sml b/src/tutorial.sml index dd2d3f7d..0c2f908f 100644 --- a/src/tutorial.sml +++ b/src/tutorial.sml @@ -38,7 +38,7 @@ fun readAll inf = before TextIO.closeIn inf end -val readAllFile = readAll o TextIO.openIn +val readAllFile = readAll o FileIO.txtOpenIn fun fixupFile (fname, title) = let @@ -154,7 +154,7 @@ fun fixupFile (fname, title) = fun doUr fname = let - val inf = TextIO.openIn fname + val inf = FileIO.txtOpenIn fname val title = case TextIO.inputLine inf of NONE => raise Fail ("No title comment at start of " ^ fname) |