Add server connection functionality

lib/server_connection.ml

@@ -0,0 +1,101 @@
+module IOVec = Httpaf.IOVec
+
+type 'handle state =
+  | Uninitialized
+  | Handshake of 'handle Server_handshake.t
+  | Websocket of Server_websocket.t
+
+type 'handle t = 'handle state ref
+
+type input_handlers = Server_websocket.input_handlers =
+  { frame : opcode:Websocket.Opcode.t -> is_fin:bool -> Bigstring.t -> off:int -> len:int -> unit
+  ; eof   : unit                                                                          -> unit }
+
+let passes_scrutiny _headers =
+  true (* XXX(andreas): missing! *)
+
+let create ~sha1 ~websocket_handler =
+  let t = ref Uninitialized in
+  let request_handler reqd =
+    let request = Httpaf.Reqd.request reqd in
+    if passes_scrutiny request.headers then begin
+      let key = Httpaf.Headers.get_exn request.headers "sec-websocket-key" in
+      let accept = sha1 (key ^ "258EAFA5-E914-47DA-95CA-C5AB0DC85B11") in
+      let headers = Httpaf.Headers.of_list [
+        "upgrade",              "websocket";
+        "connection",           "upgrade";
+        "sec-websocket-accept", accept
+      ] in
+      let response = Httpaf.(Response.create ~headers `Switching_protocols) in
+      (* XXX(andreas): this is a hacky workaround for a missing flush hook *)
+      let body = Httpaf.Reqd.respond_with_streaming reqd response in
+      Httpaf.Body.write_string body " ";
+      Httpaf.Body.flush body (fun () ->
+        t := Websocket (Server_websocket.create ~websocket_handler);
+        Httpaf.Body.close_writer body
+      )
+    end
+  in
+  let handshake =
+    Server_handshake.create
+      ~request_handler
+  in
+  t := Handshake handshake;
+  t
+;;
+
+let next_read_operation t =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.next_read_operation handshake
+  | Websocket websocket -> (Server_websocket.next_read_operation websocket :> [ `Read | `Yield | `Close ])
+;;
+
+let read t bs ~off ~len =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.read handshake bs ~off ~len
+  | Websocket websocket -> Server_websocket.read websocket bs ~off ~len
+;;
+
+let read_eof t bs ~off ~len =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.read_eof handshake bs ~off ~len
+  | Websocket websocket -> Server_websocket.read_eof websocket bs ~off ~len
+;;
+
+let yield_reader t f =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.yield_reader handshake f
+  | Websocket _         -> assert false
+;;
+
+let next_write_operation t =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.next_write_operation handshake
+  | Websocket websocket -> Server_websocket.next_write_operation websocket
+;;
+
+let report_write_result t result =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.report_write_result handshake result
+  | Websocket websocket -> Server_websocket.report_write_result websocket result
+;;
+
+let yield_writer t f =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.yield_writer handshake f
+  | Websocket websocket -> Server_websocket.yield_writer websocket f
+;;
+
+let close t =
+  match !t with
+  | Uninitialized       -> assert false
+  | Handshake handshake -> Server_handshake.close handshake
+  | Websocket websocket -> Server_websocket.close websocket
+;;

lib/server_connection.mli

@@ -0,0 +1,24 @@
+module IOVec = Httpaf.IOVec
+
+type 'handle t
+
+type input_handlers =
+  { frame : opcode:Websocket.Opcode.t -> is_fin:bool -> Bigstring.t -> off:int -> len:int -> unit
+  ; eof   : unit                                                                          -> unit }
+
+val create
+  : sha1 : (string -> string)
+  -> websocket_handler : (Wsd.t -> input_handlers)
+  -> 'handle t
+
+val next_read_operation  : _ t -> [ `Read | `Yield | `Close ]
+val next_write_operation : _ t -> [ `Write of Bigstring.t IOVec.t list | `Yield | `Close of int ]
+
+val read : _ t -> Bigstring.t -> off:int -> len:int -> int
+val read_eof : _ t -> Bigstring.t -> off:int -> len:int -> int
+val report_write_result : _ t -> [`Ok of int | `Closed ] -> unit
+
+val yield_reader : _ t -> (unit -> unit) -> unit
+val yield_writer : _ t -> (unit -> unit) -> unit
+
+val close : _ t -> unit

lib/server_handshake.ml

@@ -0,0 +1,39 @@
+module IOVec = Httpaf.IOVec
+
+type 'handle t =
+  { connection : 'handle Httpaf.Server_connection.t
+  }
+
+let create
+    ~request_handler
+  =
+  let connection =
+    Httpaf.Server_connection.create
+      request_handler
+  in
+  { connection }
+;;
+
+let next_read_operation t =
+  Httpaf.Server_connection.next_read_operation t.connection
+
+let next_write_operation t =
+  Httpaf.Server_connection.next_write_operation t.connection
+
+let read t =
+  Httpaf.Server_connection.read t.connection
+
+let read_eof t =
+  Httpaf.Server_connection.read_eof t.connection
+
+let report_write_result t =
+  Httpaf.Server_connection.report_write_result t.connection
+
+let yield_reader t =
+  Httpaf.Server_connection.yield_writer t.connection
+
+let yield_writer t =
+  Httpaf.Server_connection.yield_writer t.connection
+
+let close t =
+  Httpaf.Server_connection.shutdown t.connection

lib/server_handshake.mli

@@ -0,0 +1,19 @@
+module IOVec = Httpaf.IOVec
+
+type 'handle t
+
+val create
+  :  request_handler : 'handle Httpaf.Server_connection.request_handler
+  -> 'handle t
+
+val next_read_operation  : _ t -> [ `Read | `Close | `Yield ]
+val next_write_operation : _ t -> [ `Write of Bigstring.t IOVec.t list | `Yield | `Close of int ]
+
+val read : _ t -> Bigstring.t -> off:int -> len:int -> int
+val read_eof : _ t -> Bigstring.t -> off:int -> len:int -> int
+val report_write_result : _ t -> [`Ok of int | `Closed ] -> unit
+
+val yield_reader : _ t -> (unit -> unit) -> unit
+val yield_writer : _ t -> (unit -> unit) -> unit
+
+val close : _ t -> unit

lib/server_websocket.ml

@@ -0,0 +1,43 @@
+module IOVec = Httpaf.IOVec
+
+type t =
+  { reader : [`Parse of string list * string] Reader.t
+  ; wsd    : Wsd.t }
+
+type input_handlers =
+  { frame : opcode:Websocket.Opcode.t -> is_fin:bool -> Bigstring.t -> off:int -> len:int -> unit
+  ; eof   : unit                                                                          -> unit }
+
+let create ~websocket_handler =
+  let mode         = `Server in
+  let wsd          = Wsd.create mode in
+  let { frame; _ } = websocket_handler wsd in
+  { reader = Reader.create frame
+  ; wsd
+  }
+
+let next_read_operation t =
+  Reader.next t.reader
+
+let next_write_operation t =
+  Wsd.next t.wsd
+
+let read t bs ~off ~len =
+  Reader.read_with_more t.reader bs ~off ~len Incomplete
+
+let read_eof t bs ~off ~len =
+  Reader.read_with_more t.reader bs ~off ~len Complete
+
+let report_write_result t result =
+  Wsd.report_result t.wsd result
+
+let yield_writer t k =
+  if Wsd.is_closed t.wsd
+  then begin
+    Wsd.close t.wsd;
+    k ()
+  end else
+    Wsd.when_ready_to_write t.wsd k
+
+let close { wsd; _ } =
+  Wsd.close wsd

lib/server_websocket.mli

@@ -0,0 +1,22 @@
+module IOVec = Httpaf.IOVec
+
+type t
+
+type input_handlers =
+  { frame : opcode:Websocket.Opcode.t -> is_fin:bool -> Bigstring.t -> off:int -> len:int -> unit
+  ; eof   : unit                                                                          -> unit }
+
+val create
+  :  websocket_handler : (Wsd.t -> input_handlers)
+  -> t
+
+val next_read_operation  : t -> [ `Read | `Close ]
+val next_write_operation : t -> [ `Write of Bigstring.t IOVec.t list | `Yield | `Close of int ]
+
+val read : t -> Bigstring.t -> off:int -> len:int -> int
+val read_eof : t -> Bigstring.t -> off:int -> len:int -> int
+val report_write_result : t -> [`Ok of int | `Closed ] -> unit
+
+val yield_writer : t -> (unit -> unit) -> unit
+
+val close : t -> unit

lib/websocketaf.ml

@@ -1,5 +1,6 @@
 module Bigstring = Bigstring
 module Client_handshake = Client_handshake
 module Client_connection = Client_connection
+module Server_connection = Server_connection
 module Wsd = Wsd
 module Websocket = Websocket