Rework download failures for better error reporting

master_changes.md

@@ -114,6 +114,7 @@ users)
 
 ## Internal
   * Stop using polymorphic comparison when comparing `OpamTypes.switch_selections` [#6102 @kit-ty-kate]
+  * Structured download error types [#6107 @Keryan-dev]
 
 ## Internal: Windows
 

src/client/opamAction.ml

@@ -245,7 +245,7 @@ let download_shared_source st url nvs =
          | None, _ | _, [_] -> ""
          | Some url, _ -> " " ^ OpamUrl.to_string (OpamFile.URL.url url))) url;
   if OpamStateConfig.(!r.dryrun) || OpamClientConfig.(!r.fake)
-  then Done None else
+  then Done (Result ()) else
   let nvs =
     (* filter out version-pinned packages since we already have their source *)
     List.filter (fun nv ->
@@ -259,7 +259,7 @@ let download_shared_source st url nvs =
                OpamFile.OPAM.version_opt) = Some nv.version))
       nvs
   in
-  if nvs = [] then Done None
+  if nvs = [] then Done (Up_to_date ())
   else
   let print_action =
     OpamConsole.msg "%s retrieved %s  (%s)\n"
@@ -290,49 +290,53 @@ let download_shared_source st url nvs =
   OpamProcess.Job.catch (fun e ->
       let na =
         match e with
-        | OpamDownload.Download_fail (s,l) -> (s,l)
-        | e -> (None, Printexc.to_string e)
+        | OpamDownload.Download_fail failure -> failure
+        | e -> Generic_failure
+                 { short_reason = None; long_reason = Printexc.to_string e }
       in
-      Done (Some na))
+      Done (Not_available na))
   @@ fun () ->
   OpamUpdate.download_shared_package_source st url nvs @@| function
-  | Some (Not_available (s, l)), _ ->
-    let msg = OpamStd.Option.default l s in
+  | Some (Not_available failure), _ ->
+    let r = OpamTypesBase.get_dl_failure_reason failure in
+    let msg = OpamStd.Option.default r.long_reason r.short_reason in
     OpamConsole.error "Failed to get sources of %s%s: %s"
       (labelise OpamPackage.to_string)
       (match url, nvs with
        | None, _ | _, [_] -> ""
        | Some url, _ ->
          Printf.sprintf " (%s)" (OpamUrl.to_string (OpamFile.URL.url url)))
       msg;
-    Some (s, l)
-  | _, ((nv, name, Not_available (s, l)) :: _) ->
-    let msg = match s with None -> l | Some s -> s in
+    Not_available failure
+  | _, ((nv, name, Not_available failure) :: _) ->
+    let r = OpamTypesBase.get_dl_failure_reason failure in
+    let msg = OpamStd.Option.default r.long_reason r.short_reason in
     OpamConsole.error "Failed to get extra source \"%s\" of %s: %s"
       name (OpamPackage.to_string nv) msg;
-    Some (s, l)
+    Not_available failure
   | Some (Result msg), _ ->
-    print_full_action msg; None
+    print_full_action msg; Result ()
   | Some (Up_to_date msg), _ ->
-    print_full_action msg; None
-  | None, [] -> None
+    print_full_action msg; Up_to_date ()
+  | None, [] -> Up_to_date ()
   | None, (e :: es as extras) ->
     if List.for_all (function _, _, Up_to_date _ -> true | _ -> false) extras then
-      print_full_action "cached"
+      (print_full_action "cached";
+       Up_to_date ())
     else
-      (match e, es with
-       | (_, _, Result msg), [] -> print_full_action msg
-       | _, _ ->
-         print_single_actions
-           (List.map (fun (nv, _, _) ->
-                nv,
-                (Printf.sprintf "%d extra sources"
-                   (List.length
-                      (List.filter (fun (nv',_,_) ->
-                           OpamPackage.compare nv nv' = 0)
-                          extras))))
-               extras));
-    None
+      ((match e, es with
+          | (_, _, Result msg), [] -> print_full_action msg
+          | _, _ ->
+            print_single_actions
+              (List.map (fun (nv, _, _) ->
+                   nv,
+                   (Printf.sprintf "%d extra sources"
+                      (List.length
+                         (List.filter (fun (nv',_,_) ->
+                              OpamPackage.compare nv nv' = 0)
+                             extras))))
+                  extras));
+       Result ())
 
 let download_package st nv =
   download_shared_source st
@@ -468,7 +472,9 @@ let prepare_package_source st nv dir =
         (OpamFile.URL.url urlf :: OpamFile.URL.mirrors urlf)
       @@| function
       | Result () | Up_to_date () -> None
-      | Not_available (_,msg) -> Some (Failure msg)
+      | Not_available failure ->
+          let r = OpamTypesBase.get_dl_failure_reason failure in
+          Some (Failure r.long_reason)
     in
     List.fold_left (fun job dl ->
         job @@+ function

src/client/opamAction.mli

@@ -21,14 +21,14 @@ open OpamStateTypes
     This doesn't update dev packages that already have a locally cached
     source. *)
 val download_package:
-  rw switch_state -> package -> (string option * string) option OpamProcess.job
+  rw switch_state -> package -> unit download OpamProcess.job
 
 (** [download_same_source_package t url packages]
     As [download_package], download upstream shared source [url] between
     [packages]. *)
 val download_shared_source:
   rw switch_state -> OpamFile.URL.t option -> package list ->
-  (string option * string) option OpamProcess.job
+  unit download OpamProcess.job
 
 (** [prepare_package_source t pkg dir] updates the given source [dir] with the
     extra downloads, overlays and patches from the package's metadata

src/client/opamAdminCommand.ml

@@ -175,7 +175,8 @@ let package_files_to_cache repo_root cache_dir cache_urls
               checksums
               (OpamFile.URL.url urlf :: OpamFile.URL.mirrors urlf)
             @@| fun r -> match OpamRepository.report_fetch_result nv r with
-            | Not_available (_,m) -> Some m
+            | Not_available failure ->
+              Some failure
             | Up_to_date () | Result () -> None
         in
         error_opt @@| function
@@ -285,8 +286,13 @@ let cache_command cli =
            (OpamPackage.Map.keys errors));
       OpamConsole.errmsg "%s"
         (OpamStd.Format.itemize (fun (nv,el) ->
+             let reasons =
+               List.map (fun e ->
+                   (OpamTypesBase.get_dl_failure_reason e).long_reason)
+                 el
+             in
              Printf.sprintf "[%s] %s" (OpamPackage.to_string nv)
-               (String.concat "\n" el))
+               (String.concat "\n" reasons))
             (OpamPackage.Map.bindings errors))
     );
 

src/client/opamCommands.ml

@@ -3336,9 +3336,10 @@ let pin ?(unpin_only=false) cli =
             ~cache_dir:(OpamRepositoryPath.download_cache
                           OpamStateConfig.(!r.root_dir))
             basename pin_cache_dir [] [url] @@| function
-          | Not_available (_,u) ->
+          | Not_available failure ->
+            let r = OpamTypesBase.get_dl_failure_reason failure in
             OpamConsole.error_and_exit `Sync_error
-              "Could not retrieve %s" u
+              "Could not retrieve %s" r.long_reason
           | Result _ | Up_to_date _ ->
             let pkgs =
               OpamAuxCommands.opams_of_dir ?locked ~recurse ?subpath
@@ -3715,8 +3716,10 @@ let source cli =
                   (OpamPackage.to_string nv) dir []
                   [url])
            with
-           | Not_available (_,u) ->
-             OpamConsole.error_and_exit `Sync_error "%s is not available" u
+           | Not_available failure ->
+             let r = OpamTypesBase.get_dl_failure_reason failure in
+             OpamConsole.error_and_exit `Sync_error "%s is not available"
+               r.long_reason
            | Result _ | Up_to_date _ ->
              OpamConsole.formatted_msg
                "Successfully fetched %s development repo to %s\n"
@@ -3726,8 +3729,11 @@ let source cli =
         (let job =
            let open OpamProcess.Job.Op in
            OpamUpdate.download_package_source t nv dir @@+ function
-           | Some (Not_available (_,s)), _ | _, (_, Not_available (_, s)) :: _ ->
-             OpamConsole.error_and_exit `Sync_error "Download failed: %s" s
+           | Some (Not_available failure), _
+           | _, (_, Not_available failure) :: _ ->
+             let r = OpamTypesBase.get_dl_failure_reason failure in
+             OpamConsole.error_and_exit `Sync_error "Download failed: %s"
+               r.long_reason
            | None, _ | Some (Result _ | Up_to_date _), _ ->
              OpamAction.prepare_package_source t nv dir @@| function
              | None ->

src/client/opamPinCommand.ml

@@ -64,8 +64,6 @@ let read_opam_file_for_pinning ?locked ?(quiet=false) name f url =
   >>| OpamFile.OPAM.with_locked_opt locked
 
 
-exception Fetch_Fail of string
-
 let get_source_definition ?version ?subpath ?locked st nv url =
   let root = st.switch_global.root in
   let srcdir = OpamPath.Switch.pinned_package root st.switch nv.name in
@@ -87,11 +85,11 @@ let get_source_definition ?version ?subpath ?locked st nv url =
     | _, _ -> url
   in
   OpamUpdate.fetch_dev_package url srcdir ?subpath nv @@| function
-  | Not_available (_,s) -> raise (Fetch_Fail s)
+  | Not_available _ as err -> err
   | Up_to_date _ | Result _ ->
     let srcdir = OpamFilename.SubPath.(srcdir /? subpath) in
     match OpamPinned.find_opam_file_in_source ?locked nv.name srcdir with
-    | None -> None
+    | None -> Result None
     | Some (f, locked) ->
       match read_opam_file_for_pinning nv.name ?locked f (OpamFile.URL.url url) with
       | None ->
@@ -100,8 +98,8 @@ let get_source_definition ?version ?subpath ?locked st nv url =
             (OpamPath.Switch.Overlay.tmp_opam root st.switch nv.name)
         in
         OpamFilename.copy ~src:(OpamFile.filename f) ~dst;
-        None
-      | Some opam -> Some (fix opam)
+        Result None
+      | Some opam -> Result (Some (fix opam))
 
 let copy_files st opam =
   let name = OpamFile.OPAM.name opam in
@@ -530,16 +528,20 @@ and source_pin
   OpamFilename.remove (OpamFile.filename temp_file);
 
   let opam_opt =
-    try
-      opam_opt >>+ fun () ->
-      urlf >>= fun url ->
+    opam_opt >>+ fun () ->
+    urlf >>= fun url ->
+    match
       OpamProcess.Job.run @@ get_source_definition ?version ?subpath ?locked st nv url
-    with Fetch_Fail err ->
+    with
+    | Result o | Up_to_date o -> o
+    | Not_available failure ->
       if force then None else
         (OpamConsole.error_and_exit `Sync_error
            "Error getting source from %s:\n%s"
            (OpamStd.Option.to_string OpamUrl.to_string target_url)
-           (OpamStd.Format.itemize (fun x -> x) [err]));
+           (OpamStd.Format.itemize (fun x ->
+                (OpamTypesBase.get_dl_failure_reason x).long_reason)
+               [failure]))
   in
   let opam_opt = opam_opt >>| OpamFormatUpgrade.opam_file in
 
@@ -828,9 +830,10 @@ let scan ~normalise ~recurse ?subpath url =
           ~cache_dir:(OpamRepositoryPath.download_cache
                         OpamStateConfig.(!r.root_dir))
           basename pin_cache_dir [] [url] @@| function
-        | Not_available (_,u) ->
+        | Not_available failure ->
+          let r = OpamTypesBase.get_dl_failure_reason failure in
           OpamConsole.error_and_exit `Sync_error
-            "Could not retrieve %s" u
+            "Could not retrieve %s" r.long_reason
         | Result _ | Up_to_date _ ->
           pins_of_dir pin_cache_dir, Some cleanup
       with e -> OpamStd.Exn.finalise e cleanup

src/client/opamSolution.ml

@@ -20,7 +20,7 @@ module PackageAction = OpamSolver.Action
 module PackageActionGraph = OpamSolver.ActionGraph
 
 
-exception Fetch_fail of string
+exception Fetch_fail of dl_failure
 
 let post_message ?(failed=false) st action =
   match action, failed with
@@ -230,6 +230,8 @@ let display_error (n, error) =
     | Sys.Break | OpamParallel.Aborted -> ()
     | Failure s -> disp "%s" s
     | OpamSystem.Process_error e -> disp "%s" (OpamProcess.string_of_result e)
+    | Fetch_fail failure ->
+      disp "%s" (get_dl_failure_reason failure).long_reason
     | e ->
       disp "%s" (Printexc.to_string e);
       if OpamConsole.debug () then
@@ -632,10 +634,10 @@ let parallel_apply t
               | [] -> None
             in
             OpamAction.download_shared_source t url nvs) @@+ function
-       | None ->
+       | Result () | Up_to_date () ->
          store_time (); Done (`Successful (installed, removed))
-       | Some (_short_error, long_error) ->
-         Done (`Exception (Fetch_fail long_error)))
+       | Not_available failure ->
+         Done (`Exception (Fetch_fail failure)))
 
     | `Build nv ->
       if assume_built && OpamPackage.Set.mem nv requested then
@@ -762,7 +764,9 @@ let parallel_apply t
           ) OpamPackage.Map.empty results in
         if not (OpamPackage.Map.is_empty failed_downloads) then
           OpamJson.append "download-failures"
-            (`O (List.map (fun (nv, err) -> OpamPackage.to_string nv, `String err)
+            (`O (List.map (fun (nv, failure) ->
+                 let err = (get_dl_failure_reason failure).long_reason in
+                 OpamPackage.to_string nv, `String err)
                    (OpamPackage.Map.bindings failed_downloads)));
         (* Report build/install/remove failures *)
         let j =

src/format/opamTypes.mli

@@ -48,13 +48,35 @@ type std_path =
   | Lib | Bin | Sbin | Share | Doc | Etc | Man
   | Toplevel | Stublibs
 
+(** Download failure explanation *)
+type dl_fail_reason = {
+  short_reason : string option;
+  long_reason : string;
+}
+(** The usage is: [short_reason] is displayed on normal mode
+    (nothing if [None]), and [long_reason] on verbose mode. *)
+
+(** Tool download failure infos *)
+type 'a dl_tool_failure = {
+  dl_exit_code : int;
+  dl_url : string;
+  dl_reason : 'a;
+}
+
+type curl_error =
+  | Curl_empty_response
+  | Curl_error_response of string
+  | Curl_generic_error of dl_fail_reason
+
+(** Download failure kind *)
+type dl_failure =
+  | Generic_failure of dl_fail_reason
+  | Curl_failure of curl_error dl_tool_failure
+
 (** Download result *)
 type 'a download =
   | Up_to_date of 'a
-  | Not_available of string option * string
-  (** Arguments are respectively the short and long version of an error message.
-      The usage is: the first argument is displayed on normal mode (nothing
-      if [None]), and the second one on verbose mode. *)
+  | Not_available of dl_failure
   | Result of 'a
 
 (** {2 Packages} *)

src/format/opamTypesBase.ml

@@ -345,3 +345,19 @@ let switch_selections_compare x
 
 let switch_selections_equal x y =
   switch_selections_compare x y = 0
+
+let get_dl_failure_reason = function
+  | Generic_failure r -> r
+  | Curl_failure { dl_exit_code; dl_url; dl_reason } ->
+    let head_msg =
+      Printf.sprintf "curl failure while downloading %s\nExited with code %d\n"
+        dl_url dl_exit_code
+    in
+    match dl_reason with
+    | Curl_empty_response ->
+      { short_reason = Some "curl failure";
+        long_reason = head_msg^"Empty response" }
+    | Curl_error_response e ->
+      { short_reason = Some "curl failure";
+        long_reason = head_msg^"Returned code "^e }
+    | Curl_generic_error r -> { r with long_reason = head_msg^r.long_reason }

src/format/opamTypesBase.mli

@@ -117,3 +117,6 @@ val char_of_separator: separator -> char
 (* Switch selections *)
 val switch_selections_compare : switch_selections -> switch_selections -> int
 val switch_selections_equal : switch_selections -> switch_selections -> bool
+
+(* Download error helper functions *)
+val get_dl_failure_reason : dl_failure -> dl_fail_reason