Commits

camlspotter  committed ed0c510 Merge

merged with dev

  • Participants
  • Parent commits 9253a5c, 17c01ea

Comments (0)

Files changed (6)

 name="bitbucket"
 version="0.0.0"
 description="Bitbucket API for OCaml"
-requires="tiny_json_conv,spotlib,curl,sexplib"
+requires="tiny_json_conv,spotlib,curl,ocaml_conv"
 archive(byte)="bitbucket.cmo"
 archive(native)="bitbucket.cmx"
 linkopts = ""
 OCAMLPACKS[] =
     curl
     tiny_json_conv
-    sexplib
+    ocaml_conv
     spotlib
 
 OCAMLFLAGS = -annot -w A-4-9-39 
-OCAMLDEPFLAGS= -syntax camlp4o -package meta_conv.syntax,sexplib.syntax
-OCAMLPPFLAGS=  -syntax camlp4o -package meta_conv.syntax,sexplib.syntax
+OCAMLDEPFLAGS= -syntax camlp4o -package meta_conv.syntax
+OCAMLPPFLAGS=  -syntax camlp4o -package meta_conv.syntax
 
 FILES[] =
     xcurl
 MyOCamlPackage(bitbucket, $(FILES), $(EMPTY), $(EMPTY))
 
 api.p4.ml: api.ml
-    camlp4o dynlink.cma -I $(HOME)/.opam/system/lib/type_conv pa_type_conv.cma -I $(HOME)/.opam/system/lib/meta_conv pa_json_tc.cmo -printer Camlp4OCamlPrinter -o api.p4.ml api.ml
+    camlp4o dynlink.cma -I $(HOME)/.opam/system/lib/type_conv pa_type_conv.cma -I $(HOME)/.opam/system/lib/meta_conv pa_meta_conv.cma -printer Camlp4OCamlPrinter -o api.p4.ml api.ml
+open Printf
 open Common
+
 open Tiny_json
-open Json_conv
-open Meta_conv.Open
-open Sexplib.Conv
+open Meta_conv.Types.Result.Open (* I use >>= only for Result here *)
+open Json_conv  (* for conv(json) *)
+open Ocaml_conv (* for conv(ocaml) *)
+
+
+(* field of type Json.t mc_leftovers is automatically handled for Json, but not for ocaml *)
+type 'target mc_leftovers = (string * 'target) list with conv(ocaml)
+
+(* CR jfuruse: mc_fields should be supported in Ocaml_conv *)
+type 'target mc_fields = (string * 'target) list with conv(ocaml)
 
 module Json = struct
   include Json
-  let sexp_of_t j = Sexplib.Sexp.Atom (Json.show j)
-  let t_of_sexp = function
-    | Sexplib.Sexp.Atom s -> Json.parse s
-    | _ -> assert false
+
+  let ocaml_of_t : Json.t Ocaml_conv.encoder = fun j -> Ocaml.String (Json.show j)
+  let t_of_ocaml : Json.t Ocaml_conv.decoder = fun o ->
+    try match o with
+    | Ocaml.String s -> `Ok (Json.parse s)
+    | _ -> failwith "Ocaml.String expected"
+    with e -> `Error (Meta_conv.Types.Error.Deconstruction_error e, o)
+
+  let parse s = try `Ok (parse s) with e -> `Error (`Json_parse e)
 end
 
-module Address = struct
-  include Meta_conv.Types.Address
-  let sexp_of_t _ = Sexplib.Sexp.Atom ""
-  let t_of_sexp _ = top
-end
-
-type 'target fields = (string * ('target * Address.t)) list with sexp
+(** { 6 Types } *)
 
 module Scheme = struct
-  type t = Hg(:"hg":) | Git(:"git":) with conv(json), sexp
+  type t = 
+    | Hg  (:"hg":) 
+    | Git (:"git":) 
+  with conv(json), conv(ocaml)
 end
 
 module LocalTime = struct
-  type t = string with conv(json), sexp
+  (* CRv2 jfuruse: this should be lazily parsed date *)
+  type t = string with conv(json), conv(ocaml)
 end
 
 module UTCTime = struct
-  type t = string with conv(json), sexp
+  (* CRv2 jfuruse: this should be lazily parsed date *)
+  type t = string with conv(json), conv(ocaml)
 end
 
-(** repositories Endpoint *)
-module Repositories = struct
+module Error = struct
+  open Format
 
+  let wrap_json_conv convf s = match convf s with
+    | `Ok v -> `Ok v
+    | `Error e -> `Error (`Json_conv e)
+
+  let format ppf = function
+    | `Http (n, _err) -> fprintf ppf "HTTP Error %d@." n
+    | `Json_parse exn -> fprintf ppf "Error at Json parse: %s@." (Printexc.to_string exn)
+    | `Other exn      -> fprintf ppf "Error: %s@." (Printexc.to_string exn)
+    | `Json_conv ((_,v) as e) -> 
+        (* CR jfuruse: This is bit strange. Meta_conv.Types.Error.format should print [v] too? *)
+        Format.eprintf "%a@.Error input: %s@." 
+          (Meta_conv.Types.Error.format (fun _ _ -> ())) e
+          (Json.show v)
+end
+
+let curl_get_and_parse (convf : 'a Json_conv.decoder) curlf = 
+  Curl.get_string curlf >>= Json.parse >>= Error.wrap_json_conv convf
+
+module Data = struct
+
+  (* CR jfuruse: It seems we should use classes since there are so many name overloads *)
+    
+  (** Full repository information *)
   module Repository = struct
-    type t = {
+    type t = <
+      name              : string;
       scm               : Scheme.t;
       has_wiki          : bool;
       last_updated      : LocalTime.t;
       is_fork           : bool;
       slug              : string;
       is_private        : bool;
-      name              : string;
       language          : string;
       email_writers     : bool;
       no_public_forks   : bool;
       fork_of           : t option;
       mq_of             : t option;
       creator           : string option;
-    } with conv(json), sexp
+    > with conv(json), conv(ocaml)
   end
 
+  (** Commited file *)  
+  module File = struct
+    type t = <
+      type_ as "type" : string;
+      file : string;
+    > with conv(json), conv(ocaml)
+  end
 
+  (** Branch info *)    
+  module Branch = struct
+
+    type t = <
+      node         : string;
+      raw_node     : string;
+      author       : string;
+      raw_author   : string;
+      utctimestamp : UTCTime.t;
+      timestamp    : LocalTime.t;
+      message      : string;
+      files        : File.t list;
+      size         : int64;
+      revision     : int64;
+      parents      : string list;
+      branch       : string;
+      unknown      : Json.t mc_leftovers;
+    > with conv(json), conv(ocaml)
+
+  end
+
+  (** User identity info *)
+  module UserID = struct
+    type t = <
+      username     : string;
+      display_name : string;
+      first_name   : string;
+      last_name    : string;
+      is_team      : bool;
+      avatar       : string;
+      resource_uri : string;
+      user_rest    : Json.t mc_leftovers;
+    > with conv(json), conv(ocaml)
+  end
+
+  module User = struct
+    type t = <
+      user : UserID.t;
+      repositories : Repository.t list;
+      rest : Json.t mc_leftovers;
+    > with conv(json), conv(ocaml)
+  end
+
+  module UserRepo = struct
+
+    (** Small version of Repository.t *)  
+    type t = <
+      owner      : string;
+      scm        : Scheme.t;
+      slug       : string;
+      is_private : bool;
+      name       : string
+    >
+
+    and ts = t list with conv(json)
+  end
+
+end
+
+(** { 6 End points } *)
+
+(** repositories Endpoint *)
+module Repositories = struct
+
+  (* https://api.bitbucket.org/1.0/repositories/{accountname}/{repo_slug}/branches *)
+  module Branches = struct
+
+    type t = Data.Branch.t mc_fields with conv(json), conv(ocaml)
+
+    let get ~accountname ~repo_slug = 
+      Format.eprintf "%s : %s...@." accountname repo_slug;
+      curl_get_and_parse 
+        t_of_json
+        (fun h ->
+          (* ~user ~password  *)
+          (* h#set_userpwd (Printf.sprintf "%s:%s" user password)) *)
+          h#set_url (sprintf "https://api.bitbucket.org/1.0/repositories/%s/%s/branches" accountname repo_slug)
+          (* h#set_userpwd (Printf.sprintf "%s:%s" user password) *) )
+  end
 end
 
 (** user Endpoint *)
 module User = struct
 
-  type user = {
-    username     : string;
-    first_name   : string;
-    last_name    : string;
-    is_team      : bool;
-    avatar       : string;
-    resource_uri : string
-  } with conv(json), sexp
-
-  type resp = {
-    user : user;
-    repositories : Repositories.Repository.t list;
-    rest (: Leftovers :) : Json.t fields;
-  } with conv(json), sexp
-
   let get ~user ~password = 
-    let s = Curl.get_string (fun h ->
-      h#set_url "https://api.bitbucket.org/1.0/user";
-      h#set_userpwd (Printf.sprintf "%s:%s" user password))
-    in
-    try resp_of_json_exn (Json.parse s) with e -> 
-      prerr_endline (Printexc.to_string e);
-      prerr_endline s;
-      raise e
+    curl_get_and_parse
+      Data.User.t_of_json
+      (fun h ->
+        h#set_url "https://api.bitbucket.org/1.0/user";
+        h#set_userpwd (Printf.sprintf "%s:%s" user password))
 
   module Repositories = struct
 
-    type repo = { 
-      owner      : string;
-      scm        : Scheme.t;
-      slug       : string;
-      is_private : bool;
-      name       : string
-    } 
-
-    and resp = repo list with conv(json)
-
     let get ~user ~password = 
-      resp_of_json (Json.parse (Curl.get_string (fun h ->
-        h#set_url "https://api.bitbucket.org/1.0/user/repositories/";
-        h#set_userpwd (Printf.sprintf "%s:%s" user password))))
+      curl_get_and_parse
+        Data.UserRepo.ts_of_json
+        (fun h ->
+          h#set_url "https://api.bitbucket.org/1.0/user/repositories/";
+          h#set_userpwd (Printf.sprintf "%s:%s" user password))
   end
 
 end
   include Curl
   include Xcurl
 end
+
+external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+let ok200 = function
+  | 200, v -> `Ok v
+  | n, mes -> `Error (`Http (n, mes))
+
 let get_string f = 
   let h = new Curl.handle in
   f h;
   let buf = Buffer.create 100 in
   h#set_writefunction (fun s -> Buffer.add_string buf s; String.length s);
   h#perform;
-  Buffer.contents buf
+  h#cleanup; (* Need to flush out cookies *)
+  ok200 (h#get_httpcode, Buffer.contents buf)
 
+let download dst f =
+  let h = new Curl.handle in
+  f h;
+  let tmp = dst ^ ".tmp" in
+  let oc = open_out_bin tmp in
+  h#set_writefunction (fun s -> 
+    output_string oc s; String.length s);
+  h#perform;
+  h#cleanup; (* Need to flush out cookies *)
+  close_out oc;
+  (* CR jfuruse: what to do files when code <> 200? *)
+  ok200 (h#get_httpcode, Unix.rename tmp dst)
+  
-val get_string : (Curl.handle -> unit) -> string
-  (** [get_string init] initializes curl handle by [init] then add a write function for the simple string retrieval and perform it.
-      It returns the obtained string. *)
+val ok200 : (int * string) -> [`Ok of string | `Error of [> `Http of (int * string) ]]
+
+val get_string : (Curl.handle -> unit) -> [`Ok of string | `Error of [> `Http of (int * string) ]]
+  (** [get_string init] initializes curl handle by [init] 
+      then add a write function for the simple string retrieval and perform it.
+      It returns the obtained string.
+  *)
+