WIP untestest untrusted s3 tests.

lib/aws.ml

@@ -405,15 +405,15 @@ module Signing = struct
         | None -> Digestif.SHA256.digest_string str
 
       let sha256 ?key str =
-	_sha256 ?key str |> Digestif.SHA256.to_raw_string
+        _sha256 ?key str |> Digestif.SHA256.to_raw_string
 
       let sha256_hex ?key str =
         _sha256 ?key str |> Digestif.SHA256.to_hex
     end
 
     let encode_query ps =
       (* NOTE(dbp 2015-03-13): We want just:
-	 A-Z, a-z, 0-9, hyphen ( - ), underscore ( _ ), period ( . ), and tilde ( ~ ).
+         A-Z, a-z, 0-9, hyphen ( - ), underscore ( _ ), period ( . ), and tilde ( ~ ).
          As per the docs:
          http://docs.aws.amazon.com/general/latest/gr/sigv4-create-canonical-request.html
          Uri has that as it's fall-through, which at least currently (and hopefully forever)

lib/endpoints.ml

@@ -2052,3 +2052,9 @@ let url_of svc_name region =
   match endpoint_of svc_name region with
   | Some var -> Some ("https://" ^ var)
   | None -> None
+
+(* Create a URL for *)
+let url_with_prefix prefix svc_name region =
+  match endpoint_of svc_name region with
+  | Some var -> Some ("https://" ^ prefix ^ "." ^ var)
+  | None -> None

libraries/s3/lib/createBucket.ml

@@ -8,8 +8,7 @@ let to_http service region (req : input) =
   let uri =
     Uri.add_query_params
       (Uri.of_string @@
-         ((^) req.bucket
-            (Aws.Util.of_option_exn (Endpoints.url_of service region))))
+         (Aws.Util.of_option_exn (Endpoints.url_with_prefix req.bucket service region)))
       (List.append
          [("Version", ["2006-03-01"]); ("Action", ["CreateBucket"])]
          (Util.drop_empty
@@ -55,4 +54,4 @@ let parse_error code err =
             | None -> true))
       then Some var
       else None
-  | None -> None
+  | None -> None

libraries/s3/lib_test/aws_s3_test.ml

@@ -2,7 +2,7 @@ open OUnit
 open Aws_s3
 
 module TestSuite(Runtime : sig
-    type 'a m
+    type +'a m
     val run_request :
         (module Aws.Call with type input = 'input
                            and type output = 'output
@@ -12,12 +12,59 @@ module TestSuite(Runtime : sig
     val un_m : 'a m -> 'a
   end) = struct
 
-  let noop_test () =
-    "Noop S3 test succeeds"
-    @?true
+  let create_bucket bucket =
+    Runtime.(un_m (run_request (module CreateBucket)
+                     (Types.CreateBucketRequest.make ~bucket ())))
+
+  let delete_bucket bucket =
+    Runtime.(un_m (run_request (module DeleteBucket)
+                     (Types.DeleteBucketRequest.make ~bucket ())))
+
+  let list_buckets =
+    Runtime.(un_m (run_request (module ListBuckets) ()))
+
+  let arb_bucket = QCheck.Gen.oneofl ["test-bucket"]
+
+  let list_bucket_test =
+    QCheck.Test.make ~count:1 ~max_fail:1
+      ~name:"SQS create and delete bucket"
+      QCheck.(QCheck.make arb_bucket)
+      (fun bucket_name ->
+        match list_buckets with
+        | `Ok resp ->
+           Printf.printf "%s\n" (Yojson.Basic.to_string (Types.ListBucketsOutput.(to_json (of_json (to_json resp)))));
+           true
+        | `Error err ->
+           Printf.printf "Error: %s\n" (Aws.Error.format Errors_internal.to_string err);
+           false
+      )
+
+  let create_delete_bucket_test =
+    QCheck.Test.make ~count:1
+      ~name:"SQS create and delete bucket"
+      QCheck.(QCheck.make arb_bucket)
+      (fun bucket_name ->
+        let create_res = create_bucket bucket_name in
+
+        match create_res with
+        | `Ok resp ->
+           Printf.printf "%s\n" (Yojson.Basic.to_string (Types.CreateBucketOutput.(to_json (of_json (to_json resp)))));
+        | `Error err ->
+           Printf.printf "Error: %s\n" (Aws.Error.format Errors_internal.to_string err);
+           QCheck.assume_fail ();
+           ;
+       let delete_res = delete_bucket bucket_name in
+       match delete_res with
+       | `Ok resp ->
+          true
+       | `Error err ->
+          Printf.printf "Error: %s\n" (Aws.Error.format Errors_internal.to_string err);
+          false
+      )
 
   let test_cases =
-    [ "S3 noop" >:: noop_test ]
+    [ list_bucket_test
+    ; create_delete_bucket_test]
 
   let rec was_successful =
     function
@@ -30,13 +77,12 @@ module TestSuite(Runtime : sig
     | RTodo _::_ ->
       false
   let _ =
-    let suite = "Tests" >::: test_cases in
     let verbose = ref false in
     let set_verbose _ = verbose := true in
     Arg.parse
       [("-verbose", Arg.Unit set_verbose, "Run the test in verbose mode.");]
       (fun x -> raise (Arg.Bad ("Bad argument : " ^ x)))
       ("Usage: " ^ Sys.argv.(0) ^ " [-verbose]");
-    if not (was_successful (run_test_tt ~verbose:!verbose suite)) then
+    if not (was_successful (QCheck_runner.run_tests_main test_cases)) then
       exit 1
 end

libraries/s3/lib_test/dune

@@ -5,13 +5,14 @@
  (libraries aws aws-s3-core aws-async aws-lwt
             oUnit yojson
             async cohttp-async
-            lwt cohttp-lwt cohttp-lwt-unix))
+            lwt cohttp-lwt cohttp-lwt-unix
+            qcheck))          
 
-(alias
- (name runtest)
- (deps test_async.exe)
- (locks  m)
- (action (run %{deps})))
+;(alias
+; (name runtest)
+; (deps test_async.exe)
+; (locks  m)
+; (action (run %{deps})))
 
 (alias
  (name runtest)

libraries/s3/lib_test/test_async.ml

@@ -10,3 +10,14 @@ module T = TestSuite(struct
     let run_request x = Aws_async.Runtime.run_request ~access_key ~secret_key ~region x
     let un_m v = Async.Thread_safe.block_on_async_exn (fun () -> v)
   end)
+(*
+sig
+  type 'a m = 'a Async.Deferred.t
+  val access_key : string
+  val secret_key : string
+  val region : string
+  val run_request :
+    ('a, 'b, 'c) Aws.call -> 'a -> [ `Error of 'c Aws.Error.t | `Ok of 'b ] m
+  val un_m : 'a m -> 'a
+end
+*)

libraries/s3/lib_test/test_lwt.ml

@@ -10,3 +10,13 @@ module T = TestSuite(struct
     let run_request x = Aws_lwt.Runtime.run_request ~access_key ~secret_key ~region x
     let un_m = Lwt_main.run
   end)
+
+(*
+sig
+  type 'a m
+  val run_request :
+    (module Aws.Call with type error = 'error and type input = 'input and type output = 'output) ->
+    'input -> [ `Error of 'error Aws.Error.t | `Ok of 'output ] m
+  val un_m : 'a m -> 'a
+end
+*)

lwt/runtime.ml

@@ -51,6 +51,9 @@ let run_request
   let open Cohttp in
   let headers = Header.of_list headers in
   Lwt.catch (fun () ->
+    Cohttp_lwt_unix.IO.write Lwt_io.stderr ("Uri: " ^ Uri.to_string uri ^ "\n") >>= fun _ ->
+    Cohttp_lwt_unix.IO.write Lwt_io.stderr ("Headers: " ^ Header.to_string headers ^ "\n") >>= fun _ ->
+
     Cohttp_lwt_unix.Client.call ~headers meth uri >>= fun (resp, body) ->
     Cohttp_lwt.Body.to_string body >|= fun body ->
     let code = Code.code_of_status (Response.status resp) in