1. camlspotter
  2. spotxtras

Commits

camlspotter  committed 36d33b6

update

  • Participants
  • Parent commits 3c8c0b8
  • Branches default

Comments (0)

Files changed (6)

File META

View file
  • Ignore whitespace
+name="spotxtras"
+version="1.0.0"
+description="Spotter's toxic garbages"
+requires="spotlib,curl,tiny_json_conv"
+archive(byte)="spotxtras.cmo"
+archive(native)="spotxtras.cmx"
+linkopts = ""

File META.in

View file
  • Ignore whitespace
+name="spotxtras"
+version="@version@"
+description="Spotter's toxic garbages"
+requires="spotlib,curl,tiny_json_conv"
+archive(byte)="spotxtras.cmo"
+archive(native)="spotxtras.cmx"
+linkopts = ""

File xcurl.ml

View file
  • Ignore whitespace
+open Spotlib.Spot
+
 let ok200 = function
   | 200, v -> `Ok v
   | n, mes -> `Error (`Http (n, mes))
 
+let wrap f =
+  try f () with
+  | Curl.CurlException (_, n, mes) -> `Error (`Curl (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;
-  let code = h#get_httpcode in
-  h#cleanup; (* Need to flush out cookies *)
-  ok200 (code, Buffer.contents buf)
+  wrap & fun () -> 
+    h#perform;
+    let code = h#get_httpcode in
+    h#cleanup; (* Need to flush out cookies *)
+    ok200 (code, Buffer.contents buf)
 
 let download dst f =
   let h = new Curl.handle in
   let oc = open_out_bin tmp in
   h#set_writefunction (fun s -> 
     output_string oc s; String.length s);
-  h#perform;
-  let code = h#get_httpcode in
-  h#cleanup; (* Need to flush out cookies *)
-  close_out oc;
-  match code with
-  | 200 -> Unix.rename tmp dst; `Ok dst
-  | e -> `Error (`Http (e, tmp))
-  
+  wrap & fun () -> 
+    protect' (fun () -> h#perform) ~finally:(fun () -> close_out oc);
+    let code = h#get_httpcode in
+    h#cleanup; (* Need to flush out cookies *)
+    match code with
+    | 200 -> Unix.rename tmp dst; `Ok dst
+    | e -> `Error (`Http (e, tmp))

File xcurl.mli

View file
  • Ignore whitespace
 val ok200 : int * 'a -> [> `Ok of 'a | `Error of [> `Http of int * 'a ]]
 (** HTTP result to a result monad *)
 
-val get_string : (Curl.handle -> unit) -> [> `Error of [> `Http of int * string ] | `Ok of string ]
+val get_string : 
+  (Curl.handle -> unit) 
+  -> [> `Error of [> `Http of int * string 
+                  |  `Curl of int * string ]
+     | `Ok of string ]
 (** Get string *)
 
-val download : string -> (Curl.handle -> unit) -> [> `Error of [> `Http of int * string ] | `Ok of string ]
+val download : 
+  string 
+  -> (Curl.handle -> unit) 
+  -> [> `Error of [> `Http of int * string 
+                  |  `Curl of int * string ]
+     | `Ok of string ]
 (** Download file. Return the final downloaded file path.
     At error, the tmp file is not removed since it may contain error message. 
 *)

File xjson.ml

View file
  • Ignore whitespace
 
   let format ppf = function
     | `Http (n, _err) -> fprintf ppf "HTTP Error %d@." n
+    | `Curl (n, _err) -> fprintf ppf "Curl 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 e -> Json_conv.format_full_error Format.stderr e 

File xjson.mli

View file
  • Ignore whitespace
   val wrap_json_conv : 
     'a Json_conv.decoder 
     -> Json.t 
-    ->  ('a, [> `Json_conv of Json.t Meta_conv.Error.t]) Meta_conv.Result.t
+    ->  ('a, [> `Json_conv of Json.t Meta_conv.Error.t]) Result.t
 
   val format : Format.t 
     -> [< `Http of int * 'a
-       | `Json_conv of Json.t Meta_conv.Error.t
-       | `Json_parse of exn
-       | `Other of exn ] 
+       |  `Curl of int * string
+       |  `Json_conv of Json.t Meta_conv.Error.t
+       |  `Json_parse of exn
+       |  `Other of exn ] 
     -> unit
 
   val from_Ok :
     [< `Error of [< `Http of int * 'a
-                 | `Json_conv of Json.t Meta_conv.Error.t
-                 | `Json_parse of exn
-                 | `Other of exn ]
+                 |  `Curl of int * string
+                 |  `Json_conv of Json.t Meta_conv.Error.t
+                 |  `Json_parse of exn
+                 |  `Other of exn ]
     | `Ok of 'b ] 
     -> 'b
 end
   'a Json_conv.decoder 
   -> (Curl.handle -> unit) 
   -> ('a, [> `Http of int * string
-          | `Json_conv of Json.t Meta_conv.Error.t
-          | `Json_parse of exn ]) Meta_conv.Result.t
+          |  `Curl of int * string
+          |  `Json_conv of Json.t Meta_conv.Error.t
+          |  `Json_parse of exn ]) Result.t