Merge pull request #27 from cryptosense/add-put-upload-method

Add PUT upload method

Author: eXenon

.github/workflows/main.yml

@@ -10,11 +10,11 @@ jobs:
       fail-fast: false
       matrix:
         os:
-          - ubuntu-18.04
+          - ubuntu-20.04
           - ubuntu-22.04
           - windows-latest
         ocaml-compiler:
-          - 4.13.x
+          - 4.14.x
     runs-on: ${{ matrix.os }}
     steps:
       - name: Checkout code
@@ -33,7 +33,8 @@ jobs:
         with:
           ocaml-compiler: ${{ matrix.ocaml-compiler }}
           opam-repositories: |
-            default: 'https://github.com/fdopen/opam-repository-mingw.git#opam2'
+            opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset
+            default: https://github.com/ocaml/opam-repository.git
       - run: opam pin add cs_api_client.dev . --no-action
       - run: opam depext cs_api_client --yes --with-test
       - run: opam install . --deps-only --with-test

.ocamlformat

@@ -1,4 +1,4 @@
-version=0.19.0
+version=0.25.1
 break-cases=all
 break-fun-decl=fit-or-vertical
 break-fun-sig=fit-or-vertical

api/api.ml

@@ -28,6 +28,7 @@ end
 module Data = struct
   type t =
     | Raw of string
+    | File of File.t
     | Multipart of Part.t list
   [@@deriving eq, ord, show]
 
@@ -39,6 +40,7 @@ module Method = struct
   type t =
     | Get
     | Post
+    | Put
   [@@deriving eq, ord, show]
 end
 

api/api.mli

@@ -28,6 +28,7 @@ end
 module Data : sig
   type t =
     | Raw of string
+    | File of File.t
     | Multipart of Part.t list
   [@@deriving eq, ord, show]
 
@@ -38,6 +39,7 @@ module Method : sig
   type t =
     | Get
     | Post
+    | Put
 end
 
 module Request : sig

cs_api_cli/cs_api_cli.ml

@@ -37,9 +37,9 @@ let resolve_project_name ~client ~api ~project_id ~project_name =
 let rec analyze_trace ~client ~trace_id ~api ~count profile_id =
   let open Lwt.Infix in
   (let open Lwt_result.Infix in
-  Cs_api_core.build_analyze_request ~api ~trace_id ~profile_id
-  |> Cs_api_io.send_request ~client
-  >>= Cs_api_io.get_response_graphql)
+   Cs_api_core.build_analyze_request ~api ~trace_id ~profile_id
+   |> Cs_api_io.send_request ~client
+   >>= Cs_api_io.get_response_graphql)
   >>= function
   | Error "Not found" ->
     Printf.printf "Profile ID not found\n";
@@ -66,32 +66,37 @@ let upload_trace
     ~api =
   let open Lwt.Infix in
   (let open Lwt_result.Infix in
-  get_file trace_file >>= fun file ->
-  resolve_project_name ~client ~api ~project_id ~project_name
-  >>= fun project_id ->
-  Cs_api_core.build_s3_signed_post_request ~api
-  |> Cs_api_io.send_request ~client
-  >>= Cs_api_io.get_response_graphql
-  >>= (fun body ->
-        match Cs_api_core.parse_s3_signature_request ~body with
-        | None ->
-          Lwt.return (Error "Failed to parse S3 signature request response")
-        | Some (s3_url, s3_signature) ->
-          Lwt.return
-            (Ok
-               (Cs_api_core.build_file_upload_request ~s3_url ~s3_signature
-                  ~file)))
-  >>= Cs_api_io.send_request ~client
-  >>= Cs_api_io.get_response
-  >>= (fun body ->
-        let s3_key = Cs_api_core.parse_s3_response ~body in
-        let import_request =
-          Cs_api_core.build_trace_import_request ~slot_name ~api ~project_id
-            ~s3_key ~trace_name ~file
-        in
-        Lwt.return (Ok import_request))
-  >>= Cs_api_io.send_request ~client
-  >>= Cs_api_io.get_response_graphql)
+   get_file trace_file >>= fun file ->
+   resolve_project_name ~client ~api ~project_id ~project_name
+   >>= fun project_id ->
+   Cs_api_core.build_s3_signed_post_request ~api
+   |> Cs_api_io.send_request ~client
+   >>= Cs_api_io.get_response_graphql
+   >>= (fun body ->
+         match Cs_api_core.parse_s3_signature_request ~body with
+         | None ->
+           Lwt.return (Error "Failed to parse S3 signature request response")
+         | Some (s3_url, s3_method, s3_signature) ->
+           Lwt.return
+             (Ok
+                ( s3_url
+                , Cs_api_core.build_file_upload_request ~s3_url ~s3_method
+                    ~s3_signature ~file )))
+   >>= (fun (url, request) ->
+         ( Cs_api_io.send_request ~client request >>= fun response ->
+           Cs_api_io.get_response response )
+         >>= fun body ->
+         match Cs_api_core.parse_s3_response ~body with
+         | Ok s3_key -> Lwt_result.return s3_key
+         | Error _ -> Lwt.return (Cs_api_core.parse_s3_url url))
+   >>= (fun s3_key ->
+         let import_request =
+           Cs_api_core.build_trace_import_request ~slot_name ~api ~project_id
+             ~s3_key ~trace_name ~file
+         in
+         Lwt.return (Ok import_request))
+   >>= Cs_api_io.send_request ~client
+   >>= Cs_api_io.get_response_graphql)
   >>= function
   | Ok body ->
     let trace_id = Cs_api_core.get_id_from_trace_import_response_body ~body in
@@ -107,10 +112,10 @@ let upload_trace
 let list_profiles ~client ~api =
   let open Lwt.Infix in
   (let open Lwt_result.Infix in
-  Cs_api_core.build_list_profiles_request ~api
-  |> Cs_api_io.send_request ~client
-  >>= Cs_api_io.get_response_graphql
-  >|= fun body -> Cs_api_core.parse_list_profiles_response ~body)
+   Cs_api_core.build_list_profiles_request ~api
+   |> Cs_api_io.send_request ~client
+   >>= Cs_api_io.get_response_graphql
+   >|= fun body -> Cs_api_core.parse_list_profiles_response ~body)
   >|= function
   | Error message ->
     Printf.printf "%s\n" message;
@@ -184,7 +189,7 @@ let api_endpoint =
 
 let api_key =
   let doc = "API key" in
-  let env = Cmdliner.Arg.env_var "CRYPTOSENSE_API_KEY" ~doc in
+  let env = Cmdliner.Cmd.Env.info "CRYPTOSENSE_API_KEY" ~doc in
   let doc =
     "API key - can also be defined using the CRYPTOSENSE_API_KEY environment \
      variable"
@@ -259,10 +264,10 @@ let list_profiles_term =
     $ no_check_certificate)
 
 let list_profiles_info =
-  Cmdliner.Term.info "list-profiles"
+  Cmdliner.Cmd.info "list-profiles"
     ~doc:"List the available profiles of the Cryptosense Analyzer platform"
 
-let list_profiles_cmd = (list_profiles_term, list_profiles_info)
+let list_profiles_cmd = Cmdliner.Cmd.v list_profiles_info list_profiles_term
 
 let analyze_term =
   Cmdliner.Term.(
@@ -275,9 +280,9 @@ let analyze_term =
     $ no_check_certificate)
 
 let analyze_info =
-  Cmdliner.Term.info "analyze" ~doc:"Analyze a trace to create a report"
+  Cmdliner.Cmd.info "analyze" ~doc:"Analyze a trace to create a report"
 
-let analyze_cmd = (analyze_term, analyze_info)
+let analyze_cmd = Cmdliner.Cmd.v analyze_info analyze_term
 
 let upload_trace_term =
   Cmdliner.Term.(
@@ -294,19 +299,19 @@ let upload_trace_term =
     $ no_check_certificate)
 
 let upload_trace_info =
-  Cmdliner.Term.info "upload-trace"
+  Cmdliner.Cmd.info "upload-trace"
     ~doc:"Upload a trace to the Cryptosense Analyzer platform"
 
-let upload_trace_cmd = (upload_trace_term, upload_trace_info)
+let upload_trace_cmd = Cmdliner.Cmd.v upload_trace_info upload_trace_term
 
 let default_term =
   Cmdliner.Term.(ret (const (`Error (true, "Missing command"))))
 
-let default_info = Cmdliner.Term.info "cs-api" ~version:"%%VERSION_NUM%%"
-
-let default_cmd = (default_term, default_info)
+let default_info = Cmdliner.Cmd.info "cs-api" ~version:"%%VERSION_NUM%%"
+let default_cmd = default_info
 
 let () =
-  Cmdliner.Term.eval_choice default_cmd
+  Cmdliner.Cmd.group ~default:default_term default_cmd
     [analyze_cmd; list_profiles_cmd; upload_trace_cmd]
-  |> Cmdliner.Term.exit_status
+  |> Cmdliner.Cmd.eval'
+  |> Stdlib.exit

cs_api_client.opam

@@ -14,13 +14,13 @@ run-test: [
 depends: [
   "alcotest" {with-test}
   "base64"
-  "cmdliner" {= "1.0.4"}
+  "cmdliner" {>= "1.2.0"}
   "containers" {>= "3.6"}
   "dune" {>= "2.7.0"}
   "lwt"
   "lwt_ppx"
-  "ocaml" {>= "4.13.0"}
-  "ocamlformat" {= "0.19.0" & with-test}
+  "ocaml" {>= "4.14.0"}
+  "ocamlformat" {= "0.25.1" & with-test}
   "ocurl" {< "0.9.2"}  # For compilation with old libcurl
   "ppx_deriving"
   "terminal_size" {>= "0.2.0"}  # For compilation on Windows

cs_api_core/cs_api_core.ml

@@ -17,6 +17,7 @@ module Graphql = struct
         generateTraceUploadPost(input: {}) {
           url
           formData
+          method
         }
       }
     |}
@@ -146,6 +147,7 @@ let parse_s3_signature_request ~body =
   let json = Yojson.Basic.from_string body in
   let data = json |> member "data" |> member "generateTraceUploadPost" in
   let url = data |> member "url" |> to_string_option in
+  let method_ = data |> member "method" |> to_string_option in
   let formData =
     match data |> member "formData" with
     | `String str -> Yojson.Basic.from_string str
@@ -162,28 +164,46 @@ let parse_s3_signature_request ~body =
     formData |> member "success_action_status" |> to_int_option
   in
   url >>= fun url ->
-  signature >>= fun signature ->
-  key >>= fun key ->
-  credential >>= fun credential ->
-  date >>= fun date ->
-  algorithm >>= fun algorithm ->
-  policy >>= fun policy ->
-  acl >>= fun acl ->
-  success_action_status >|= fun success_action_status ->
-  ( url
-  , [ ("x-amz-signature", signature)
-    ; ("x-amz-credential", credential)
-    ; ("x-amz-algorithm", algorithm)
-    ; ("x-amz-date", date)
-    ; ("key", key)
-    ; ("policy", policy)
-    ; ("acl", acl)
-    ; ("success_action_status", string_of_int success_action_status) ] )
+  method_ >>= fun method_ ->
+  if String.equal method_ "POST" then
+    signature >>= fun signature ->
+    key >>= fun key ->
+    credential >>= fun credential ->
+    date >>= fun date ->
+    algorithm >>= fun algorithm ->
+    policy >>= fun policy ->
+    acl >>= fun acl ->
+    success_action_status >|= fun success_action_status ->
+    ( url
+    , Api.Method.Post
+    , [ ("x-amz-signature", signature)
+      ; ("x-amz-credential", credential)
+      ; ("x-amz-algorithm", algorithm)
+      ; ("x-amz-date", date)
+      ; ("key", key)
+      ; ("policy", policy)
+      ; ("acl", acl)
+      ; ("success_action_status", string_of_int success_action_status) ] )
+  else if String.equal method_ "PUT" then
+    Some (url, Api.Method.Put, [])
+  else
+    raise (Invalid_argument ("Unknown method: " ^ method_))
 
 let parse_s3_response ~body =
-  let key_extractor = Str.regexp "<Key>\\([^<>]*\\)</Key>" in
-  let _ = Str.search_forward key_extractor body 0 in
-  Str.matched_group 1 body
+  try
+    let key_extractor = Str.regexp "<Key>\\([^<>]*\\)</Key>" in
+    let _ = Str.search_forward key_extractor body 0 in
+    Ok (Str.matched_group 1 body)
+  with
+  | Not_found -> Error "Key could not be extracted from S3 response."
+
+let parse_s3_url url =
+  try
+    let key_extractor = Str.regexp "/uploads/\\([a-z0-9]+\\)" in
+    let _ = Str.search_forward key_extractor url 0 in
+    Ok ("uploads/" ^ Str.matched_group 1 url)
+  with
+  | Not_found -> Error "Key could not be extracted from S3 URL."
 
 let build_s3_signed_post_request ~api =
   let {Api.endpoint; key} = api in
@@ -197,17 +217,27 @@ let build_s3_signed_post_request ~api =
              [ ("query", `String Graphql.generate_trace_upload_post)
              ; ("variables", `Assoc []) ])) }
 
-let build_file_upload_request ~s3_url ~s3_signature ~(file : Api.File.t) =
+let build_file_upload_request
+    ~s3_url
+    ~s3_method
+    ~s3_signature
+    ~(file : Api.File.t) =
   let direct_fields =
     Api.Data.multipart_from_assoc
       (s3_signature
       @ [ ("Content-Type", "")
         ; ("x-amz-meta-filename", Filename.basename file.path) ])
   in
-  { Api.Request.url = s3_url
-  ; header = []
-  ; method_ = Post
-  ; data = Multipart (direct_fields @ [{name = "file"; content = File file}]) }
+  match s3_method with
+  | Api.Method.Post ->
+    { Api.Request.url = s3_url
+    ; header = []
+    ; method_ = Post
+    ; data = Multipart (direct_fields @ [{name = "file"; content = File file}])
+    }
+  | Put ->
+    {Api.Request.url = s3_url; header = []; method_ = Put; data = File file}
+  | Get -> raise (Invalid_argument "Unsupported method: GET")
 
 let build_trace_import_request
     ~api

cs_api_core/cs_api_core.mli

@@ -1,20 +1,17 @@
 module Graphql : sig
   val to_global_id : type_:string -> id:int -> string
-
   val generate_trace_upload_post : string
-
   val create_trace : string
-
   val analyze_trace : string
-
   val list_profiles : string
 end
 
 val parse_s3_signature_request :
-  body:string -> (string * Api.S3Signature.t) option
+  body:string -> (string * Api.Method.t * Api.S3Signature.t) option
 (** Response parsing functions **)
 
-val parse_s3_response : body:string -> string
+val parse_s3_response : body:string -> (string, string) result
+val parse_s3_url : string -> (string, string) result
 
 val build_s3_signed_post_request : api:Api.t -> Api.Request.t
 (** Request building functions **)
@@ -25,11 +22,11 @@ val build_search_project_by_name_request :
   api:Api.t -> name:string -> Api.Request.t
 
 val parse_list_profiles_response : body:string -> (string * int * string) list
-
 val parse_search_project_by_name_response : body:string -> int option
 
 val build_file_upload_request :
      s3_url:string
+  -> s3_method:Api.Method.t
   -> s3_signature:Api.S3Signature.t
   -> file:Api.File.t
   -> Api.Request.t
@@ -47,5 +44,4 @@ val build_analyze_request :
   api:Api.t -> trace_id:int -> profile_id:int -> Api.Request.t
 
 val get_id_from_trace_import_response_body : body:string -> int
-
 val get_info_from_analyze_response_body : body:string -> string * int