Source

ibx / lib / tws_prot.ml

(* File: tws_prot.ml

   IBX - OCaml implementation of the Interactive Brokers TWS API

   Copyright (C) 2013-  Oliver Gu
   email: gu.oliver@yahoo.com

   This library is free software; you can redistribute it and/or
   modify it under the terms of the GNU Lesser General Public
   License as published by the Free Software Foundation; either
   version 2 of the License, or (at your option) any later version.

   This library 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
   Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public
   License along with this library; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*)

open Core.Std

type raw_tws = string with sexp

module Val_type = struct
  type 'a t = {
    tws_of_a : 'a -> raw_tws;
    a_of_tws : raw_tws -> 'a;
  }

  let create tws_of_a a_of_tws = { tws_of_a; a_of_tws }

  let tws_of_unit () = ""
  let unit_of_tws = function
    | "" -> ()
    | s -> invalid_argf "Val_type.unit_of_tws: %S" s ()
  let unit = create tws_of_unit unit_of_tws

  let string = create Fn.id Fn.id
  let int    = create Int.to_string Int.of_string
  let int64  = create Int64.to_string Int64.of_string

  let tws_of_float x =
    let s = Float.to_string x in
    let n = String.length s in
    if s.[n-1] = '.' then s^"0" else s
  let float_of_tws = Float.of_string
  let float = create tws_of_float float_of_tws

  let tws_of_bool = function
    | false -> "0"
    | true  -> "1"
  let bool_of_tws = function
    | "0" -> false
    | "1" -> true
    | s -> invalid_argf "Val_type.bool_of_tws: %S" s ()
  let bool = create tws_of_bool bool_of_tws

  let tws_of_time tm = Time.format tm "%Y%m%d %H:%M:%S"
  let time_of_tws = Time.of_string
  let time = create tws_of_time time_of_tws

  let tws_of_date = Date.to_string_iso8601_basic
  let date_of_tws = Date.of_string_iso8601_basic ~pos:0
  let date = create tws_of_date date_of_tws
end

module Pickler = struct

  let serialize_aux raw_tws buf =
    Buffer.add_string buf raw_tws;
    Buffer.add_char buf '\000'

  let serialize tws_of_a a buf = serialize_aux (tws_of_a a) buf

  let serialize_opt default_on_none tws_of_a a_opt buf =
    match a_opt with
    | None   -> serialize_aux default_on_none buf
    | Some a -> serialize tws_of_a a buf

  module Spec = struct
    type 'a t = {
      f : 'a -> Buffer.t -> unit;
    }

    let (++) t1 t2 = {
      f = (fun (a, b) buf -> t1.f a buf; t2.f b buf)
    }

    let empty () = {
      f = (fun `Args _buf -> ())
    }

    let ($) x y = (x, y)

    let wrap t f = {
      f = Fn.compose t.f f;
    }

    include struct
      open Val_type
      let unit   = unit
      let string = string
      let int    = int
      let int64  = int64
      let float  = float
      let bool   = bool
      let time   = time
      let date   = date
    end

    type 'a value = {
      value : 'a -> Buffer.t -> unit;
    }

    let required val_type = {
      value = (fun a buf -> serialize val_type.Val_type.tws_of_a a buf);
    }

    let optional ?(default_on_none="") val_type = {
      value = (fun a buf ->
        serialize_opt default_on_none val_type.Val_type.tws_of_a a buf);
    }



    let skipped_if_none val_type = {
      value = (fun a_opt buf ->
        match a_opt with
        | None   -> ()
        | Some a -> serialize val_type.Val_type.tws_of_a a buf);
    }

    let skipped = {
      value = (fun _a _buf -> ());
    }

    let tws_data = {
      value = (fun raw_tws buf -> Buffer.add_string buf raw_tws)
    }

    let value v = {
      f = v.value;
    }

    let fields_value v specs _field = specs ++ value v
  end

  type 'a t = {
    f : 'a -> Buffer.t -> unit;
    name : string option;
    buf_size : int;
  }

  let create ?(buf_size=256) ?name {Spec.f} =
    { f; name; buf_size }

  let run t value =
    let buf = Buffer.create t.buf_size in
    t.f value buf;
    Buffer.contents buf
end

module Unpickler = struct

  let parse_aux name a_of_tws raw_tws =
    match Result.try_with (fun () -> a_of_tws raw_tws) with
    | Ok a -> a
    | Error exn ->
      failwithf "failed to parse %s value %S -- %s" name raw_tws (Exn.to_string exn) ()

  let parse name a_of_tws msg =
    match Queue.dequeue msg with
    | None -> failwithf "missing message field %s" name ()
    | Some raw_tws -> (parse_aux name a_of_tws raw_tws, msg)

  let parse_opt none_on_default name a_of_tws msg =
    match Queue.dequeue msg with
    | None -> failwithf "missing message field %s" name ()
    | Some raw_tws ->
      if String.equal raw_tws none_on_default
      then (None                                  , msg)
      else (Some (parse_aux name a_of_tws raw_tws), msg)

  module Spec = struct

    type ('a, 'b) t = {
      f : ('a * raw_tws Queue.t -> 'b * raw_tws Queue.t);
    }

    let (++) t1 t2 = {
      f = Fn.compose t2.f t1.f;
    }

    let step f = {
      f = (fun (a, msg) -> (f a, msg));
    }

    let empty () = step Fn.id

    include struct
      open Val_type
      let unit   = unit
      let string = string
      let int    = int
      let int64  = int64
      let float  = float
      let bool   = bool
      let time   = time
      let date   = date
    end

    type 'a parse = raw_tws Queue.t -> 'a * raw_tws Queue.t

    type 'a value = {
      value : name:string -> 'a parse;
    }

    let required val_type = {
      value = (fun ~name msg -> parse name val_type.Val_type.a_of_tws msg);
    }

    let optional ?(none_on_default="") val_type = {
      value = (fun ~name msg ->
        parse_opt none_on_default name val_type.Val_type.a_of_tws msg);
    }

    let optional_with_default ~default val_type = {
      value = (fun ~name msg ->
        match parse_opt "" name val_type.Val_type.a_of_tws msg with
        | None  , msg -> default, msg
        | Some a, msg -> a      , msg);
    }

    let capture_remaining_message = {
      f = (fun (k, msg) ->
        let captured_msg = Queue.create () in
        Queue.transfer ~src:msg ~dst:captured_msg;
        (k captured_msg, msg));
    }

    let value v ~name = {
      f = (fun (k, msg) ->
        let (a, remaining_msg) = v.value msg ~name in
        (k a, remaining_msg));
    }

    let fields_value v specs field =
      specs ++ value v ~name:(Fieldslib.Field.name field)

  end

  type 'a t = {
    f : raw_tws Queue.t -> 'a;
    name : string option;
  }

  let create ?name {Spec.f} conv = {
    f = (fun msg ->
      let (result, remaining_msg) = f (conv, msg) in
      if Queue.is_empty remaining_msg
      then result
      else failwiths "message is too long" (Queue.length msg) sexp_of_int);
    name;
  }

  let map t ~f = {
    f = (fun msg -> (f (t.f msg)));
    name = t.name;
  }

  let const a = {
    f = (fun _msg -> a);
    name = None;
  }

  let run t msg =
    match Or_error.try_with (fun () -> t.f msg) with
    | Ok _ as x -> x
    | Error err -> Error (Option.value_map t.name ~default:err ~f:(Error.tag err))

  let run_exn t msg = Or_error.ok_exn (run t msg)
end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.