Merge pull request #125 from Nymphium/split-aws-modules

Split modules in aws.ml into files

lib/baseTypes.ml

@@ -0,0 +1,155 @@
+open Query
+open Xml
+
+module type Base = sig
+  type t
+
+  val to_json : t -> Json.t
+
+  val of_json : Json.t -> t
+
+  val to_query : t -> Query.t
+
+  val parse : Ezxmlm.nodes -> t option
+
+  val to_string : t -> string
+
+  val of_string : string -> t
+end
+
+module Unit = struct
+  type t = unit
+
+  let to_json () = `Null
+
+  let of_json = function
+    | `Null -> ()
+    | t -> raise (Json.Casting_error ("unit", t))
+
+  let to_query () = List []
+
+  let parse _ = Some () (* XXX(seliopou): Should never be used, maybe assert that? *)
+
+  let to_string _ = raise (Failure "unit")
+
+  let of_string _ = raise (Failure "unit")
+end
+
+module String = struct
+  include String
+
+  let to_json s = `String s
+
+  let of_json = function
+    | `String s -> s
+    | t -> raise (Json.Casting_error ("string", t))
+
+  let to_query s = Value (Some s)
+
+  let parse s = Some (data_to_string s)
+
+  let to_string s = s
+
+  let of_string s = s
+end
+
+(* NOTE(dbp 2015-01-15): In EC2, Blobs seem to be used for Base64
+   encoded data, which seems okay to represent as a string, at least
+   for now. *)
+module Blob = String
+
+module Boolean = struct
+  type t = bool
+
+  let to_json b = `Bool b
+
+  let of_json = function
+    | `Bool b -> b
+    | t -> raise (Json.Casting_error ("bool", t))
+
+  let to_query = function
+    | true -> Value (Some "true")
+    | false -> Value (Some "false")
+
+  let parse b =
+    match String.parse b with
+    | None -> None
+    | Some s -> (
+        match String.lowercase_ascii s with
+        | "false" -> Some false
+        | "true" -> Some true
+        | _ -> None)
+
+  let to_string b = if b then "true" else "false"
+
+  let of_string s =
+    match String.lowercase_ascii s with
+    | "false" -> false
+    | "true" -> true
+    | _ -> raise (Failure ("Bad boolean string " ^ s))
+end
+
+module Integer = struct
+  type t = int
+
+  let to_json i = `Int i
+
+  let of_json = function
+    | `Int i -> i
+    | t -> raise (Json.Casting_error ("int", t))
+
+  let to_query i = Value (Some (string_of_int i))
+
+  let parse i =
+    match String.parse i with
+    | None -> None
+    | Some s -> ( try Some (int_of_string s) with Failure _ -> None)
+
+  let to_string i = string_of_int i
+
+  let of_string s = int_of_string s
+end
+
+module Long = Integer
+
+module Float = struct
+  type t = float
+
+  let to_json f = `Float f
+
+  let of_json = function
+    | `Float f -> f
+    | t -> raise (Json.Casting_error ("float", t))
+
+  let to_query f = Value (Some (string_of_float f))
+
+  let parse f =
+    match String.parse f with
+    | None -> None
+    | Some s -> ( try Some (float_of_string s) with Failure _ -> None)
+
+  let to_string f = string_of_float f
+
+  let of_string s = float_of_string s
+end
+
+module Double = Float
+
+module DateTime = struct
+  type t = CalendarLib.Calendar.t
+
+  let to_json c = `String (Time.format c)
+
+  let of_json t = Time.parse (String.of_json t)
+
+  let to_query c = Value (Some (Time.format c))
+
+  let parse c =
+    match String.parse c with
+    | None -> None
+    | Some s -> ( try Some (Time.parse s) with Invalid_argument _ -> None)
+
+  let to_string c = Time.format c
+
+  let of_string s = Time.parse s
+end

lib/error.ml

@@ -0,0 +1,77 @@
+type 'a code =
+  | Understood of 'a
+  | Unknown of string
+
+type bad_response =
+  { body : string
+  ; message : string
+  }
+
+type 'a error_response =
+  | BadResponse of bad_response
+  | AwsError of ('a code * string) list
+
+type 'a t =
+  | TransportError of string
+  | HttpError of int * 'a error_response
+
+let code_to_string utos = function
+  | Understood code -> utos code
+  | Unknown code -> code
+
+let format print_native = function
+  | TransportError msg -> Printf.(sprintf "TransportError %s" msg)
+  | HttpError (code, err) -> (
+      match err with
+      | BadResponse br ->
+          Printf.sprintf
+            "HttpError(%d - BadResponse): %s. Body: %s\n"
+            code
+            br.message
+            br.body
+      | AwsError ers ->
+          Printf.sprintf
+            "HttpError(%d - AwsError): %s"
+            code
+            (String.concat
+               ", "
+               (List.map
+                  (fun (code, msg) ->
+                    Printf.sprintf "[%s: %s]" (code_to_string print_native code) msg)
+                  ers)))
+
+let parse_aws_error body =
+  try
+    let tags = Ezxmlm.from_string body |> snd in
+    let errors =
+      Util.(
+        match
+          option_bind (Xml.member "Response" tags) (fun r ->
+              option_bind (Xml.member "Errors" r) (fun errs ->
+                  Some (Xml.members "Error" errs)))
+        with
+        | Some es -> Some es
+        | None ->
+            option_bind (Xml.member "ErrorResponse" tags) (fun r ->
+                Some (Xml.members "Error" r)))
+    in
+    match errors with
+    | None -> `Error "Could not find <Error> nodes for error response code."
+    | Some err_nodes ->
+        Util.(
+          option_map
+            (List.map
+               (fun node ->
+                 match
+                   ( option_map (Xml.member "Code" node) Xml.data_to_string
+                   , option_map (Xml.member "Message" node) Xml.data_to_string )
+                 with
+                 | Some error_code, Some message -> Some (error_code, message)
+                 | _ -> None)
+               err_nodes
+            |> option_all)
+            (fun res -> `Ok res)
+          |> of_option
+               (`Error
+                 "Could not find properly formatted <Error> nodes in <Errors> response."))
+  with Failure msg -> `Error ("Error parsing xml: " ^ msg)

lib/json.ml

@@ -0,0 +1,32 @@
+type t =
+  [ `Assoc of (string * t) list
+  | `Bool of bool
+  | `Float of float
+  | `Int of int
+  | `List of t list
+  | `Null
+  | `String of string
+  ]
+
+exception Casting_error of string * t
+
+let to_list f = function
+  | `List l -> List.map f l
+  | t -> raise (Casting_error ("list", t))
+
+let to_hashtbl key_f f = function
+  | `Assoc m ->
+      List.fold_left
+        (fun acc (k, v) ->
+          Hashtbl.add acc (key_f k) (f v);
+          acc)
+        (Hashtbl.create (List.length m))
+        m
+  | t -> raise (Casting_error ("map", t))
+
+let lookup t s =
+  try
+    match t with
+    | `Assoc l -> Some (List.assoc s l)
+    | _ -> raise Not_found
+  with Not_found -> None

lib/query.ml

@@ -0,0 +1,29 @@
+type t =
+  | List of t list
+  | Pair of (string * t)
+  | Value of string option
+
+let render q =
+  let rec enc k q =
+    match k, q with
+    | k, List xs -> List.concat (List.map (enc k) xs)
+    | Some n, Pair (label, subq) -> enc (Some (n ^ "." ^ label)) subq
+    | None, Pair (label, subq) -> enc (Some label) subq
+    | Some n, Value (Some s) -> [ n ^ "=" ^ Uri.pct_encode ~component:`Query_value s ]
+    | None, Value (Some s) -> [ Uri.pct_encode s ]
+    | Some s, _ -> [ s ]
+    | _ -> []
+  in
+  String.concat "&" (enc None q)
+
+let to_query_list to_query vals =
+  let i = ref 0 in
+  List
+    (List.map
+       (fun v ->
+         i := !i + 1;
+         Pair (string_of_int !i, to_query v))
+       vals)
+
+let to_query_hashtbl key_to_str to_query tbl =
+  List (Hashtbl.fold (fun k v acc -> Pair (key_to_str k, to_query v) :: acc) tbl [])

lib/request.ml

@@ -0,0 +1,33 @@
+type meth =
+  [ `DELETE
+  | `GET
+  | `HEAD
+  | `OPTIONS
+  | `CONNECT
+  | `TRACE
+  | `Other of string
+  | `PATCH
+  | `POST
+  | `PUT
+  ]
+
+let string_of_meth = function
+  | `DELETE -> "DELETE"
+  | `GET -> "GET"
+  | `HEAD -> "HEAD"
+  | `OPTIONS -> "OPTIONS"
+  | `CONNECT -> "CONNECT"
+  | `TRACE -> "TRACE"
+  | `Other s -> s
+  | `PATCH -> "PATCH"
+  | `POST -> "POST"
+  | `PUT -> "PUT"
+
+type headers = (string * string) list
+
+type signature_version =
+  | V4
+  | V2
+  | S3
+
+type t = meth * Uri.t * headers