From 40f5ea3c4242f8f92d511596778f980671972d7f Mon Sep 17 00:00:00 2001 From: Jacob Mitchell Date: Thu, 8 Sep 2016 11:09:45 -0700 Subject: Use hash instead of timestamp in app.js filename Makes Ur/Web project builds reproducible without sacrificing HTTP caching. Uses a public domain SHA1 implementation by tom7. See #38. --- src/cjr_print.sml | 28 +++--- src/sha1.sig | 31 +++++++ src/sha1.sml | 264 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/sources | 9 ++ 4 files changed, 320 insertions(+), 12 deletions(-) create mode 100644 src/sha1.sig create mode 100644 src/sha1.sml diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 2e969c46..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 ^ "\\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, @@ -3509,7 +3513,7 @@ fun p_file env (ds, ps) = newline, newline, string "if (!strcmp(request, \"", - string app_js, + string (!app_js), string "\")) {", newline, box [string "uw_write_header(ctx, \"Content-Type: text/javascript\\r\\n\");", @@ -3633,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/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 -- cgit v1.2.3