preparation for Tell and BencodeStream

_oasis

@@ -41,7 +41,7 @@ Library "containers"
                     UnionFind, SmallSet, Leftistheap, AbsSet, CSM, MultiMap,
                     ActionMan, BV, QCheck, BencodeOnDisk, Show, TTree,
                     HGraph, Automaton, Conv, Levenshtein, Bidir, Iteratee,
-                    Ty
+                    Ty, Tell
   BuildDepends:     unix
 
 Library "containers_thread"

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 1f820e710eb0e25ebe36cbb436da1e21)
+# DO NOT EDIT (digest: 7cc04ba603fa39231957d867b707c9af)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -58,6 +58,7 @@
 "bidir.cmx": for-pack(Containers)
 "iteratee.cmx": for-pack(Containers)
 "ty.cmx": for-pack(Containers)
+"tell.cmx": for-pack(Containers)
 # Library containers_thread
 "threads/containers_thread.cmxs": use_containers_thread
 <threads/*.ml{,i}>: package(threads)

bencodeStream.ml

@@ -0,0 +1,304 @@
+
+(*
+copyright (c) 2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 Full-Streaming API of Bencode} *)
+
+type token =
+  | Int of int
+  | String of string
+  | BeginDict
+  | EndDict
+  | BeginList
+  | EndList
+
+module Encode = struct
+  type sink =
+    [ `File of string
+    | `Out of out_channel
+    | `Buf of Buffer.t
+    ]
+
+  type t = {
+    write_string : string -> unit;
+    write_char : char -> unit;
+    on_close : unit -> unit;
+  }
+  
+  let nop() = ()
+
+  let create = function
+    | `Out o ->
+        { write_string=output_string o
+        ; write_char=output_char o
+        ; on_close = nop
+        }
+    | `File f ->
+        let o = open_in f in
+        { write_string=output_string o
+        ; write_char=output_char o
+        ; on_close = (fun () -> close_out o)
+        }
+    | `Buf b ->
+        { write_string=Buffer.add_string b
+        ; write_char=Buffer.add_char b
+        ; on_close =nop
+        }
+
+    let push out tok = match tok with
+      | Int i ->
+          out.write_char 'i';
+          out.write_string (string_of_int i);
+          out.write_char 'e'
+      | String s ->
+          out.write_string (string_of_int (String.length s));
+          out.write_char ':';
+          out.write_string s
+      | BeginDict ->
+          out.write_char 'd'
+      | EndDict ->
+          out.write_char 'e'
+      | BeginList ->
+          out.write_char 'l'
+      | EndList ->
+          out.write_char 'e'
+end
+
+module Decode = struct
+  type source =
+    [ `File of string
+    | `In of in_channel
+    | `String of string
+    | `Manual
+    ]
+
+  type result =
+    | Yield of token
+    | Error of string
+    | End
+    | Await  (** The user needs to call {!feed} with some input *)
+
+  type t = {
+    read_string : string -> int -> int -> int;
+    read_char : unit -> char;
+    mutable buf : string;  (* buffer *)
+    mutable i : int;  (* index in buf *)
+    mutable len : int;  (* length of substring to read *)
+    mutable c : int;  (* line *)
+    mutable l : int;  (* column *)
+    mutable state : result;
+    mutable stack : partial_state list;
+  }
+
+  let __default = {
+    read_string = (fun _ _ _ -> assert false);
+    read_char = (fun _ -> '\000');
+    buf = "";
+    i = 0;
+    len = 0;
+    c = 0;
+    l = 0;
+    state = Error "no input";
+    stack = [];
+  }
+
+  let create = function
+    | `File f ->
+
+
+  val create : source -> t
+  (** Create a new decoder with the given source. *)
+
+  type decoder = {
+    mutable buf : string;  (* buffer *)
+    mutable i : int;  (* index in buf *)
+    mutable len : int;  (* length of substring to read *)
+    mutable c : int;  (* line *)
+    mutable l : int;  (* column *)
+    mutable state : parse_result;
+    mutable stack : partial_state list;
+  }
+
+  (** Result of parsing *)
+  and parse_result =
+    | ParseOk of t
+    | ParseError of string
+    | ParsePartial
+
+  (** Partial state of the parser *)
+  and partial_state =
+    | PS_I of bool * int (* sign and integer *)
+    | PS_S of int ref * string   (* index in string, plus string *)
+    | PS_L of t list
+    | PS_D of t SMap.t  (* in dictionary *)
+    | PS_D_key of string * t SMap.t  (* parsed key, wait for value *) 
+    | PS_return of t  (* bottom of stack *)
+    | PS_error of string (* error *)
+
+  let mk_decoder () =
+    let dec = {
+      buf = "";
+      i = 0;
+      len = 0;
+      c = 0;
+      l = 0;
+      state = ParsePartial;
+      stack = [];
+    } in
+    dec
+
+  let is_empty dec = dec.len = 0
+  let cur dec = dec.buf.[dec.i]
+
+  let junk dec =
+    (* update line/column *)
+    (if cur dec = '\n'
+      then (dec.c <- 0; dec.l <- dec.l + 1)
+      else dec.c <- dec.c + 1);
+    dec.i <- dec.i + 1;
+    dec.len <- dec.len - 1
+
+  let next dec =
+    let c = cur dec in
+    junk dec;
+    c
+
+  (* parse value *)
+  let rec parse_rec dec =
+    match dec.stack with
+    | [PS_return v] ->  (* return value *)
+      dec.stack <- [];
+      dec.state <- ParseOk v;
+      dec.state
+    | [PS_error s] -> (* failure *)
+      dec.stack <- [];
+      dec.state <- ParseError s;
+      dec.state
+    | _ ->
+      if is_empty dec then ParsePartial (* wait *)
+      else begin
+        let c = next dec in
+        (match dec.stack, c with
+        | (PS_I (sign, i)) :: stack, '0' .. '9' ->
+          dec.stack <- PS_I (sign, (Char.code c - Char.code '0') + 10 * i) :: stack;
+        | (PS_I (_, 0)) :: stack, '-' ->
+          dec.stack <- PS_I (false, 0) :: stack  (* negative number *)
+        | (PS_I (sign, i)) :: stack, 'e' ->
+          dec.stack <- stack;
+          push_value dec (I (if sign then i else ~- i))
+        | ((PS_D _ | PS_D_key _ | PS_L _) :: _ | []), '0' .. '9' ->
+          (* initial length of string *)
+          dec.stack <- (PS_I (true, Char.code c - Char.code '0')) :: dec.stack
+        | (PS_I (sign, i)) :: stack, ':' ->
+          if i < 0
+            then error dec "string length cannot be negative"
+          else if i = 0 then  (* empty string *)
+            let _ = dec.stack <- stack in
+            push_value dec (S "")
+          else (* prepare to parse a string *)
+            dec.stack <- (PS_S (ref 0, String.create i)) :: stack;
+        | (PS_S (n, s)) :: stack, _ ->
+          s.[!n] <- c;
+          incr n;
+          (* value completed *)
+          (if !n = String.length s
+            then
+              let _ = dec.stack <- stack in
+              push_value dec (S s));
+        | stack, 'i' ->
+          dec.stack <- (PS_I (true, 0)) :: stack
+        | stack, 'l' ->
+          dec.stack <- PS_L [] :: stack;
+        | stack, 'd' ->
+          dec.stack <- PS_D SMap.empty :: stack
+        | (PS_L l) :: stack, 'e' -> (* end of list *)
+          dec.stack <- stack;
+          push_value dec (L (List.rev l))
+        | (PS_D d) :: stack, 'e' -> (* end of dict *)
+          dec.stack <- stack;
+          push_value dec (D d)
+        | (PS_D_key _) :: _, 'e' -> (* error *)
+          error dec "missing value in dict"
+        | _ -> (* generic error *)
+          error dec (Printf.sprintf "expected value, got %c" c));
+        parse_rec dec
+      end
+  (* When a value is parsed, push it on the stack (possibly collapsing it) *)
+  and push_value dec v =
+    match v, dec.stack with
+    | _, [] ->
+      dec.stack <- [PS_return v] (* finished *)
+    | _, (PS_L l) :: stack ->
+      (* add to list *)
+      dec.stack <- (PS_L (v :: l)) :: stack;
+    | S key, ((PS_D d) :: stack) ->
+      (* new key for the map *)
+      dec.stack <- (PS_D_key (key, d)) :: stack;
+    | _, ((PS_D d) :: _) ->
+      (* error: key must be string *)
+      error dec "dict keys must be strings"
+    | _, (PS_D_key (key, d)) :: stack ->
+      (* new binding for the map *)
+      dec.stack <- (PS_D (SMap.add key v d)) :: stack;
+    | _ -> assert false
+  (* signal error *)
+  and error dec msg =
+    let msg = Printf.sprintf "Bencode: error at line %d, column %d: %s"
+      dec.l dec.c msg in
+    dec.stack <- [PS_error msg]
+
+  (* exported parse function *)
+  let parse dec s i len =
+    (if i < 0 || i+len > String.length s
+      then invalid_arg "Bencode.parse: not a valid substring");
+    (* add the input to [dec] *)
+    if dec.len = 0
+      then begin
+        dec.buf <- String.copy s;
+        dec.i <- i;
+        dec.len <- len;
+      end else begin
+        (* use a buffer to merge the stored input and the new input *)
+        let buf' = String.create (dec.len + len - dec.i) in
+        String.blit dec.buf dec.i buf' 0 dec.len;
+        String.blit s i buf' dec.len len;
+        dec.buf <- buf';
+        dec.i <- 0;
+        dec.len <- dec.len + len - dec.i;
+      end;
+    (* state machine *)
+    parse_rec dec
+
+  val feed : t -> string -> unit
+  (** For manual mode, provide some input *)
+
+  type result =
+    | Yield of token
+    | End
+    | Await  (** The user needs to call {!feed} with some input *)
+
+  val next : t -> result
+end
+

bencodeStream.mli

@@ -0,0 +1,74 @@
+
+(*
+copyright (c) 2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 Full-Streaming API of Bencode} *)
+
+type token =
+  | Int of int
+  | String of string
+  | BeginDict
+  | EndDict
+  | BeginList
+  | EndList
+
+module Encode : sig
+  type t
+
+  type sink =
+    [ `File of string
+    | `Out of out_channel
+    | `Buf of Buffer.t
+    ]
+
+  val create : sink -> t
+
+  val push : t -> token -> unit
+end
+
+module Decode : sig
+  type t
+
+  type source =
+    [ `File of string
+    | `In of in_channel
+    | `String of string
+    | `Manual
+    ]
+
+  val create : source -> t
+  (** Create a new decoder with the given source. *)
+
+  val feed : t -> string -> unit
+  (** For manual mode, provide some input *)
+
+  type result =
+    | Yield of token
+    | Error of string
+    | End
+    | Await  (** The user needs to call {!feed} with some input *)
+
+  val next : t -> result
+end

containers.mlpack

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: a57e9337d5ca2ca5de2c29c113a55d57)
+# DO NOT EDIT (digest: 4f32d3f650d22abadbd792d7ed9a300a)
 Cache
 Deque
 Gen
@@ -43,4 +43,5 @@ Levenshtein
 Bidir
 Iteratee
 Ty
+Tell
 # OASIS_STOP

containers.odocl

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: a57e9337d5ca2ca5de2c29c113a55d57)
+# DO NOT EDIT (digest: 4f32d3f650d22abadbd792d7ed9a300a)
 Cache
 Deque
 Gen
@@ -43,4 +43,5 @@ Levenshtein
 Bidir
 Iteratee
 Ty
+Tell
 # OASIS_STOP

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.3.0 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 607ac444249450197cccc8d204000609) *)
+(* DO NOT EDIT (digest: 64cad3d2ac0a699d2cce214751e56a41) *)
 (*
    Regenerated by OASIS v0.4.4
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -7001,7 +7001,8 @@ let setup_t =
                            "Levenshtein";
                            "Bidir";
                            "Iteratee";
-                           "Ty"
+                           "Ty";
+                           "Tell"
                         ];
                       lib_pack = true;
                       lib_internal_modules = [];
@@ -7388,8 +7389,7 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.4";
-     oasis_digest =
+     oasis_digest = Some "\145(\131\246\004\000\023}\183\228*\141]B\1918";
-       Some "\234\208\170\146/\020\006\020k\186\024\145\237\193\148\145";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false

tell.ml

@@ -0,0 +1,54 @@
+
+(*
+copyright (c) 2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 Hierarchic logging} *)
+
+type t = {
+  name : string;
+  out : out_channel;
+  cleanup : bool;
+  mutable context : string list;
+}
+
+let __new_name =
+  let r = ref 0 in
+  fun () ->
+    let name = Printf.sprintf "Tell.log_%d" !r in
+    incr r;
+    name
+
+let to_chan ?(cleanup=false) o = {
+  name = __new_name ();
+  out = o;
+  cleanup;
+  context = [];
+}
+
+let to_file filename =
+  let o = open_out filename in
+  to_chan ~cleanup:true o
+
+let step

tell.mli

@@ -0,0 +1,75 @@
+
+(*
+copyright (c) 2014, simon cruanes
+all rights reserved.
+
+redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.  redistributions in binary
+form must reproduce the above copyright notice, this list of conditions and the
+following disclaimer in the documentation and/or other materials provided with
+the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*)
+
+(** {1 Hierarchic logging} *)
+
+type t
+
+val to_file : string -> t
+(** Create a logger that outputs to the given file *)
+
+val to_chan : ?cleanup:bool out_channel -> t
+(** Obtain a logger that outputs to the given channel.
+    @param cleanup if true, will close the channel on exit;
+    if false or not explicited, won't do anything. *)
+
+exception Error of string
+
+(** {2 Raw functions} *)
+
+val step : t -> string -> unit
+
+val close : t -> unit
+(** Close the logger. It will be unusable afterwards. *)
+
+(** {2 Hierarchy} *)
+
+val enter : t -> unit
+(** Enter a new subsection *)
+
+val exit : t -> unit
+(** Exit the current subsection *)
+
+val within : ?descr:string -> log:t -> (unit -> 'a) -> 'a
+(** Enter a subsection named [descr], evaluate the given function,
+    exit the subsection and return the function's result.
+    Also protects against exceptions. *)
+
+(** {2 Buffer-formatting output}
+The following functions use a {!Buffer.t} to create the message,
+then send it to their logger. *)
+
+module B : sig
+  val enter : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a
+  (** Enter a new (sub-)section with the given message *)
+
+  val exit : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a
+  (** Exit (close) the current sub-section. *)
+
+  val step : log:t -> ('a, Buffer.t, unit, unit) format4 -> 'a
+  (** Unit step within the current section *)
+end
+