Clean up Date-header generation etc by introducing "|>" operator

TODO

@@ -1 +1,2 @@
  - ui_relay.ml: deal with Message.Subscribe and .Unsubscribe as well as .Post in api_tap_sink
+ - web: add cache control information to served responses

hof.ml

@@ -0,0 +1,36 @@
+(* Copyright 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>. *)
+
+(* This file is part of Ocamlmsg. *)
+
+(* Ocamlmsg is free software: you can redistribute it and/or modify it *)
+(* under the terms of the GNU General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version. *)
+
+(* Ocamlmsg is distributed in the hope that it will be useful, but *)
+(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU *)
+(* General Public License for more details. *)
+
+(* You should have received a copy of the GNU General Public License *)
+(* along with Ocamlmsg.  If not, see <http://www.gnu.org/licenses/>. *)
+
+(* Higher-order function utilities, based on the interfaces in Ocaml
+Batteries. *)
+
+let ( |> ) x f = f x
+let ( **> ) f x = f x
+
+let identity x = x
+let const x y = x
+
+let ( |- ) first second x = second (first x)
+let ( -| ) second first x = second (first x)
+
+let flip f x y = f y x
+
+let ( *** ) f g (x, y) = (f x, g y)
+let ( &&& ) f g x = (f x, g x)
+
+let first f (x, y) = (f x, y)
+let second f (x, y) = (x, f y)

httpd.ml

@@ -62,7 +62,15 @@ let disable_cache_headers () =
    "Cache-Control", "no-cache, must-revalidate, max-age=0";
    "Pragma", "no-cache"]
 
-let add_completion_callback resp cb =
+let add_headers headers resp =
+  let b = resp.resp_body in
+  {resp with resp_body = {b with headers = b.headers @ headers}}
+
+let add_disable_cache_headers resp = add_headers (disable_cache_headers ()) resp
+
+let add_date_header resp = add_headers ["Date", Httpd_date.http_gmtime (Unix.time ())] resp
+
+let add_completion_callback cb resp =
   {resp with completion_callbacks = cb :: resp.completion_callbacks}
 
 let http_error code reason body = raise (HTTPError (code, reason, body))

ui_main.ml

@@ -16,6 +16,7 @@
 (* along with Ocamlmsg.  If not, see <http://www.gnu.org/licenses/>. *)
 
 open Html
+open Hof
 
 let dispatch_table = ref []
 
@@ -65,6 +66,7 @@ let api_server_stats id r =
 		      "boot_time", Json.Num boot_time;
 		      "uptime", Json.Num (Unix.time () -. boot_time);
 		      "classes", Json.Arr (List.map Json.str (Factory.all_class_names ()))])
+  |> Httpd.add_date_header
 
 let init () =
   register_dispatcher ("/_/server_stats", api_server_stats);

ui_relay.ml

@@ -15,6 +15,8 @@
 (* You should have received a copy of the GNU General Public License *)
 (* along with Ocamlmsg.  If not, see <http://www.gnu.org/licenses/>. *)
 
+open Hof
+
 type outbound_message =
   | Data of Sexp.t
   | Heartbeat
@@ -44,19 +46,19 @@ let rec api_tap_source id r =
     handle_message n (Message.subscribe (Sexp.Str (Node.local_container_name()),
 					 Sexp.Str "", Sexp.Str "",
 					 Sexp.Str "", Sexp.Str ""));
-    Httpd.add_completion_callback
-      (Httpd.resp_generic 200 "Streaming"
-	 ([Httpd.text_content_type_header;
-	   "Access-Control-Allow-Origin", "*";
-	   "Date", Httpd_date.http_gmtime (Unix.time ())]
-	  @ Httpd.disable_cache_headers ())
-	 (Httpd.Variable
-	    (Stringstream.switch_after 131072
-	       (Stringstream.seq id_block_and_padding (Stringstream.make (message_stream ch)))
-	       Stringstream.empty)))
-      (fun _ ->
-	Node.unbind_all n;
-	Squeue.add Shutdown ch)
+    Httpd.resp_generic 200 "Streaming"
+      [Httpd.text_content_type_header;
+       "Access-Control-Allow-Origin", "*"]
+      (Httpd.Variable
+	 (Stringstream.switch_after 131072
+	    (Stringstream.seq id_block_and_padding (Stringstream.make (message_stream ch)))
+	    Stringstream.empty))
+    |> Httpd.add_disable_cache_headers
+    |> Httpd.add_date_header
+    |> Httpd.add_completion_callback
+	(fun _ ->
+	  Node.unbind_all n;
+	  Squeue.add Shutdown ch)
 
 let api_tap_sink irrelevant_id r =
   let params = Httpd.parse_urlencoded (Httpd.string_of_content r.Httpd.req_body.Httpd.content) in