PageRenderTime 45ms CodeModel.GetById 16ms app.highlight 23ms RepoModel.GetById 1ms app.codeStats 0ms

/frame.ml

http://github.com/djs55/ocaml-spdy
OCaml | 293 lines | 278 code | 13 blank | 2 comment | 5 complexity | b9d0c7591e76f8d97774fcf00edc1631 MD5 | raw file
  1
  2let rec really_read fd string off n =
  3  if n=0 then () else
  4    let m = Unix.read fd string off n in
  5    if m = 0 then raise End_of_file;
  6    really_read fd string (off+m) (n-m)
  7
  8let really_read_string fd length =
  9  let buf = String.make length '\000' in
 10  really_read fd buf 0 length;
 11  buf
 12
 13module Message = struct
 14  type t = {
 15    control: bool;
 16    version: int;
 17    ty: int;
 18    flags: int;
 19    length: int;
 20    data: Bitstring.t;
 21  }
 22  let unmarshal fd =
 23    (* The first 8 bytes contain the length of the message *)
 24    let hdr = really_read_string fd 8 in
 25    let bs = Bitstring.bitstring_of_string hdr in
 26    bitmatch bs with
 27      | { control: 1;
 28	  version: 15: int;
 29	  ty: 16: int;
 30	  flags: 8: int;
 31	  length: 24: int } ->
 32	let data = really_read_string fd length in
 33	let data = Bitstring.bitstring_of_string data in {
 34	control = control; version = version; ty = ty;
 35	flags = flags; length = length; data = data
 36      }
 37      | { _ } -> failwith "Failed to parse header"
 38
 39end
 40
 41let take num one bits =
 42  let rec loop acc bits = function
 43    | 0l -> List.rev acc
 44    | n ->
 45      let nv, rest = one bits in
 46      loop (nv :: acc) rest (Int32.sub n 1l) in
 47  loop [] bits num
 48
 49module NVPairs = struct
 50  let unmarshal bits =
 51    let num, rest = bitmatch bits with
 52      | { num: 16;
 53	  rest: -1: bitstring
 54	} -> Int32.of_int num, rest
 55      | { _ } -> failwith "Failed to parse NVPairs len" in
 56    let one bits = bitmatch bits with
 57      | { name_len: 16;
 58	  name: name_len * 8: string;
 59	  v_len: 16;
 60	  v: v_len * 8: string;
 61	  rest: -1: bitstring
 62	} -> (name, v), rest
 63      | { _ } -> failwith "Failed to parse NVPair" in
 64    take num one rest
 65end
 66
 67module IdVPairs = struct
 68  let unmarshal bits =
 69    let num, rest = bitmatch bits with
 70      | { num: 32;
 71	  rest: -1: bitstring
 72	} -> num, rest in
 73    let one bits = bitmatch bits with
 74      | { id: 24;
 75	  flags: 8;
 76	  v: 32
 77	} -> (id, flags, v), rest
 78      | { _ } -> failwith "Failed to parse NVPair" in
 79    take num one rest
 80end
 81
 82let parse_flags table x =
 83  List.map snd (List.filter (fun (mask, flag) -> x.Message.flags land mask <> 0) table)
 84
 85module Control = struct
 86  module Syn = struct
 87    type flag =
 88      | Fin
 89      | Unidirectional
 90    let flags = [
 91      0x01, Fin;
 92      0x02, Unidirectional
 93    ]
 94    type t = {
 95      stream_id: int; (* 31 bits *)
 96      associated_to_stream_id: int; (* 31 bits *)
 97      pri: int; (* 2 bits *)
 98      flags: flag list;
 99      headers: (string * string) list;
100    }
101    let unmarshal (x: Message.t) =
102      let flags = parse_flags flags x in
103      bitmatch x.Message.data with
104	| { _: 1;
105	    stream_id: 31;
106	    _: 1;
107	    associated_to_stream_id: 31;
108	    pri: 2;
109	    _: 14;
110	    rest: -1: bitstring
111	  } ->
112	  let headers = NVPairs.unmarshal rest in {
113	    stream_id = stream_id;
114	    associated_to_stream_id = associated_to_stream_id;
115	    pri = pri;
116	    flags = flags;
117	    headers = headers
118	  }
119	| { _ } -> failwith "Failed to parse SYN"
120  end
121  module Reply = struct
122    type flag =
123      | Fin
124    let flags = [
125      0x1, Fin
126    ]
127    type t = {
128      stream_id: int; (* 31 bits *)
129      flags: flag list;
130      headers: (string * string) list;
131    }
132    let unmarshal (x: Message.t) =
133      bitmatch x.Message.data with
134	| { _: 1;
135	    stream_id: 31;
136	    _: 16;
137	    rest: -1: bitstring } ->
138	  let flags = parse_flags flags x in
139	  let headers = NVPairs.unmarshal rest in {
140	    stream_id = stream_id;
141	    flags = flags;
142	    headers = headers
143	  }
144	| { _ } -> failwith "Failed to parse REPLY"
145
146  end
147  module Rst = struct
148    type status_code = 
149      | Protocol_error
150      | Invalid_stream
151      | Refused_stream
152      | Unsupported_version
153      | Cancel
154      | Internal_error
155      | Flow_control_error
156    let status_codes = [
157      1l, Protocol_error;
158      2l, Invalid_stream;
159      3l, Refused_stream;
160      4l, Unsupported_version;
161      5l, Cancel;
162      6l, Internal_error;
163      7l, Flow_control_error
164    ]
165    type t = {
166      stream_id: int; (* 31 bits *)
167      status_code: status_code;
168    }
169    let unmarshal (x: Message.t) =
170      bitmatch x.Message.data with
171	| { _: 1;
172	    stream_id: 31;
173	    status_code: 32
174	  } ->
175	  if not (List.mem_assoc status_code status_codes)
176	  then failwith (Printf.sprintf "Unknown RST status code: %ld" status_code);
177	  { stream_id = stream_id;
178	    status_code = List.assoc status_code status_codes }
179	| { _ } -> failwith "Failed to parse RST"
180  end
181  module Settings = struct
182    type flag =
183      | Clear_previously_persisted_settings
184    let flags = [
185      0x1, Clear_previously_persisted_settings
186    ]
187    type id_flag =
188      | Persist_value
189      | Persisted
190    let id_flags = [
191      0x1, Persist_value;
192      0x2, Persisted;
193    ]
194    type id =
195      | Upload_bandwidth
196      | Download_bandwidth
197      | Round_trip_time
198      | Max_concurrent_streams
199      | Current_cwnd
200      | Download_retrans_rate
201      | Initial_window_size
202    let ids = [
203      1, Upload_bandwidth;
204      2, Download_bandwidth;
205      3, Round_trip_time;
206      4, Max_concurrent_streams;
207      5, Current_cwnd;
208      6, Download_retrans_rate;
209      7, Initial_window_size;
210    ]
211    type t = {
212      flags: flag list;
213      settings: (id * id_flag * Int32.t) list;
214    }
215    let unmarshal (x: Message.t) =
216      let flags = parse_flags flags x in
217      let raw_settings = IdVPairs.unmarshal x.Message.data in
218      let settings =
219	List.map (fun (id, id_flag, v) ->
220	  if not(List.mem_assoc id ids)
221	  then failwith (Printf.sprintf "Unknown SETTINGS id %d" id);
222	  if not(List.mem_assoc id_flag id_flags)
223	  then failwith (Printf.sprintf "Unknown SETTINGS id_flag %d" id_flag);
224	  List.assoc id ids, List.assoc id_flag id_flags, v
225	) raw_settings in
226      { flags = flags;
227	settings = settings }
228  end
229  module Noop = struct
230    type t = unit
231    let unmarshal (x: Message.t) = ()
232  end
233  module Ping = struct
234    type t = int32
235    let unmarshal (x: Message.t) =
236      bitmatch x.Message.data with
237	| { id: 32 } -> id
238	| { _ } -> failwith "Failed to parse PING"
239  end
240  module Goaway = struct
241    type t = {
242      last_good_stream_id: int; (* 31 bits *)
243    }
244    let unmarshal (x: Message.t) =
245      bitmatch x.Message.data with
246	| { _: 1;
247	    last_good_stream_id: 31 } -> {
248	  last_good_stream_id = last_good_stream_id
249	}
250	| { _ } -> failwith "Failed to parse GOAWAY"
251  end
252  module Headers = struct
253    type t = {
254      stream_id: int; (* 31 bits *)
255      headers: (string * string) list;
256    }
257    let unmarshal (x: Message.t) =
258      bitmatch x.Message.data with
259	| { _: 1;
260	    stream_id: 31;
261	    _: 16;
262	    rest: -1: bitstring } ->
263	  let headers = NVPairs.unmarshal rest in {
264	    stream_id = stream_id;
265	    headers = headers
266	  }
267	| { _ } -> failwith "Failed to parse HEADERS"
268  end
269  type t =
270    | Syn of Syn.t
271    | Reply of Reply.t
272    | Rst of Rst.t
273    | Settings of Settings.t
274    | Noop of Noop.t
275    | Ping of Ping.t
276    | Goaway of Goaway.t
277    | Headers of Headers.t
278  let unmarshal (x: Message.t) =
279    (* assume control and version have values we recognise *)
280    match x.Message.ty with
281      | 1 -> Syn (Syn.unmarshal x)
282      | 2 -> Reply (Reply.unmarshal x)
283      | 3 -> Rst (Rst.unmarshal x)
284      | 4 -> Settings (Settings.unmarshal x)
285      | 5 -> Noop (Noop.unmarshal x)
286      | 6 -> Ping (Ping.unmarshal x)
287      | 7 -> Goaway (Goaway.unmarshal x)
288      | 8 -> Headers (Headers.unmarshal x)
289      | x -> failwith (Printf.sprintf "Unknown CONTROL message type: %d" x)
290end
291
292
293