From 49791c1d4f2eb143dd3ca57ee1098723e062f5eb Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Mon, 24 Feb 2020 17:55:29 +1100 Subject: [PATCH] WIP untestest untrusted s3 tests. --- lib/aws.ml | 4 +- lib/endpoints.ml | 6 +++ libraries/s3/lib/createBucket.ml | 5 +-- libraries/s3/lib_test/aws_s3_test.ml | 60 ++++++++++++++++++++++++---- libraries/s3/lib_test/dune | 13 +++--- libraries/s3/lib_test/test_async.ml | 11 +++++ libraries/s3/lib_test/test_lwt.ml | 10 +++++ lwt/runtime.ml | 3 ++ 8 files changed, 94 insertions(+), 18 deletions(-) diff --git a/lib/aws.ml b/lib/aws.ml index 5e5c90a91..bd9039e3c 100644 --- a/lib/aws.ml +++ b/lib/aws.ml @@ -405,7 +405,7 @@ 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 @@ -413,7 +413,7 @@ module Signing = struct 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) diff --git a/lib/endpoints.ml b/lib/endpoints.ml index a4698f014..8f9fac80f 100644 --- a/lib/endpoints.ml +++ b/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 diff --git a/libraries/s3/lib/createBucket.ml b/libraries/s3/lib/createBucket.ml index 776d51a33..282137bba 100644 --- a/libraries/s3/lib/createBucket.ml +++ b/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 \ No newline at end of file + | None -> None diff --git a/libraries/s3/lib_test/aws_s3_test.ml b/libraries/s3/lib_test/aws_s3_test.ml index f950b23ac..006b3ff97 100644 --- a/libraries/s3/lib_test/aws_s3_test.ml +++ b/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 diff --git a/libraries/s3/lib_test/dune b/libraries/s3/lib_test/dune index a12f25eac..b9b5ace9e 100644 --- a/libraries/s3/lib_test/dune +++ b/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) diff --git a/libraries/s3/lib_test/test_async.ml b/libraries/s3/lib_test/test_async.ml index 8414b52e2..2613e70a1 100644 --- a/libraries/s3/lib_test/test_async.ml +++ b/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 +*) diff --git a/libraries/s3/lib_test/test_lwt.ml b/libraries/s3/lib_test/test_lwt.ml index ef1fc46d2..e408d7b71 100644 --- a/libraries/s3/lib_test/test_lwt.ml +++ b/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 +*) diff --git a/lwt/runtime.ml b/lwt/runtime.ml index 1dfa75d18..71226ea14 100644 --- a/lwt/runtime.ml +++ b/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