1(* Bend Bank: the host2 ===================34 The bank is web.bend, compiled to web.cml, which this file follows. It5 only moves bytes, as host.mjs does: it replays the log into the bank at6 boot, then reads HTTP requests off each connection, in order; for each,7 it prefixes the time and a fresh random key, asks Web.serve for the8 answer, appends the input to the log when the bank changed (before9 answering), and writes the answer back. Bytes are chars, one per byte.10 ffi.c holds the sockets; it closes a connection idle for 30 seconds.11 Usage: bank PORT LOG | bank check VAULT | bank replay LOG *)1213val room = 16384;1415(* a String chain, from char codes; and back to bytes *)16fun chain cs = List.foldr (fn c => fn r => C ("SCon", [I c, r])) (C ("SNil", [])) cs;17fun bytes v =18 let fun go v acc = case v of19 C ("SCon", [I c, r]) => go r (Char.chr (c mod 256) :: acc)20 | _ => String.implode (List.rev acc)21 in go v [] end;22fun codes s = List.map Char.ord (String.explode s);2324(* the bank after an input, and the answer *)25fun serve bank input =26 case f_Web'serve bank input of27 C ("Reply", [C ("Some", [next]), text]) => (Some next, text)28 | C ("Reply", [_, text]) => (None, text);2930(* JSON.parse of a JSON string line, as char codes *)31fun hexval c = if Char.isDigit c then Char.ord c - 48 else Char.ord c mod 32 + 9;32fun unjson line =33 let fun go cs acc = case cs of34 #"\"" :: _ => List.rev acc35 | #"\\" :: #"u" :: a :: b :: c :: d :: r =>36 go r (List.foldl (fn x => fn n => 16 * n + hexval x) 0 [a, b, c, d] :: acc)37 | #"\\" :: e :: r => go r (Char.ord (case e of38 #"b" => #"\b" | #"f" => #"\f" | #"n" => #"\n" | #"r" => #"\r"39 | #"t" => #"\t" | #"\"" => #"\"" | #"\\" => #"\\" | #"/" => #"/") :: acc)40 | c :: r => go r (Char.ord c :: acc)41 in case String.explode line of #"\"" :: cs => go cs [] end;4243(* JSON.stringify of a latin1 string, as Node writes it: UTF-8 bytes *)44fun hex2 n = String.implode (List.map (fn d => String.sub "0123456789abcdef" d) [n div 16, n mod 16]);45fun json s =46 let fun esc c = let val n = Char.ord c in47 if c = #"\"" then "\\\"" else if c = #"\\" then "\\\\"48 else if c = #"\b" then "\\b" else if c = #"\f" then "\\f"49 else if c = #"\n" then "\\n" else if c = #"\r" then "\\r"50 else if c = #"\t" then "\\t" else if n < 32 then "\\u00" ^ hex2 n51 else if n < 128 then String.str c52 else String.implode [Char.chr (192 + n div 64), Char.chr (128 + n mod 64)] end53 in "\"" ^ String.concat (List.map esc (String.explode s)) ^ "\"" end;5455(* the bank after each nonempty line of the log, from genesis *)56fun replay path =57 List.foldl (fn line => fn bank => if line = "" then bank else58 case serve bank (chain (unjson line)) of (Some next, _) => next | _ => bank)59 (f_bank'Bank'genesis ()) (String.fields (fn c => c = #"\n") (Option.valOf (TextIO.inputAllFrom (Some path))));6061(* the dump printer, as check/dump.mjs *)62fun dump v =63 let fun str v acc = case v of64 C ("SNil", []) => Some (List.rev acc)65 | C ("SCon", [I c, r]) => str r (c :: acc)66 | _ => None67 in case (v, str v []) of68 (_, Some cs) => "s(" ^ String.concatWith "," (List.map Int.toString cs) ^ ")"69 | (I n, _) => Int.toString n70 | (C (t, fs), _) => t ^ "{" ^ String.concatWith "," (List.map dump fs) ^ "}"71 | (F _, _) => "<fn>"72 | (U, _) => "_"73 end;7475(* the FFI *)76val ev = Word8Array.array (8 + 65536) (Word8.fromInt 0);77fun get a i k = if k = 0 then 0 else 256 * get a i (k - 1) + Word8.toInt (Word8Array.sub a (i + k - 1));78fun put a k n = if k = 0 then () else (Word8Array.update a (k - 1) (Word8.fromInt (n mod 256)); put a (k - 1) (n div 256));79exception Ffi string;80fun ok name = if Word8Array.sub ev 0 = Word8.fromInt 0 then () else raise Ffi name;81fun now () = (#(bank_time) "" ev; get ev 0 8);82fun key () = (#(bank_random) "" ev; String.concat (List.tabulate 16 (fn i => hex2 (Word8.toInt (Word8Array.sub ev i)))));83fun shut fd = (put ev 4 fd; #(bank_close) "" ev);84fun send fd text = (put ev 4 fd; #(bank_write) text ev; ok "write");85fun append line = (#(bank_append) line ev; ok "log");8687(* the server: one byte buffer per connection, indexed by fd *)88fun server port path =89 let90 val u = (#(bank_open) path ev; ok "open")91 val bank = Ref (replay path)92 val bufs = Array.array 65536 ""93 fun drop fd = (Array.update bufs fd ""; shut fd)94 fun drain fd =95 let val buf = Array.sub bufs fd in96 if String.size buf > room then drop fd else97 case f_Req'size (chain (codes buf)) of98 C ("Some", [I n]) =>99 if n > room then drop fd else100 if String.size buf < n then () else101 let102 val input = Int.toString (now ()) ^ "\n" ^ key () ^ "\n" ^ String.substring buf 0 n103 val u = Array.update bufs fd (String.extract buf n None)104 val (next, text) = serve (!bank) (chain (codes input))105 val u = case next of Some b => (append (json input ^ "\n"); bank := b) | None => ()106 in send fd (bytes text); drain fd end107 | _ => ()108 end109 fun loop () =110 let111 val u = #(bank_wait) "" ev112 val fd = get ev 0 4113 val n = get ev 4 4114 in115 (if n = 0 then Array.update bufs fd "" else116 ((Array.update bufs fd (Array.sub bufs fd ^ Word8Array.substring ev 8 n); drain fd)117 handle e => (TextIO.print_err "bank: connection failed\n"; drop fd)));118 loop ()119 end120 in121 put ev 4 port; #(bank_listen) "" ev; ok "listen";122 print ("bank on " ^ Int.toString port ^ "\n");123 loop ()124 end;125126(* check: the dump of each answer to the stdin lines, then of the bank *)127fun check vault =128 let val stdin = TextIO.openStdIn ()129 fun go bank = case TextIO.inputLine stdin of130 None => print (dump bank ^ "\n")131 | Some line =>132 let val (next, text) = serve bank (chain (unjson line)) in133 print (dump text ^ "\n"); go (Option.getOpt next bank)134 end135 in go (C ("Bank", [I vault, C ("Tip", [])])) end;136137val u = case CommandLine.arguments () of138 ["check", vault] => check (Option.valOf (Int.fromString vault))139 | ["replay", path] => print (dump (replay path) ^ "\n")140 | [port, path] => server (Option.valOf (Int.fromString port)) path141 | _ => TextIO.print_err "usage: bank PORT LOG | bank check VAULT | bank replay LOG\n";