Fix inference of gh URIs

CHANGES.md

@@ -49,6 +49,8 @@
 
 ### Fixed
 
+- Fix a bug where `opam submit` would try to parse the custom URI provided through
+  `--distrib-uri` as a github repo URI instead of using the dev-repo (#358, @NathanReb)
 - Fix the priority of the `--distrib-uri` option in `dune-release opam pkg`.
   It used to have lower precendence than the url file written by `dune-release publish`
   and therefore made it impossible to overwrite it if needed. (#255, @NathanReb)

bin/opam.ml

@@ -59,7 +59,7 @@ let archive_url ~dry_run ~opam_file pkg =
   else if dry_run && not opam_file_exists then Ok D.distrib_uri
   else (
     Logs.warn (fun l -> l "Could not find %a." Text.Pp.path url_file);
-    Pkg.infer_distrib_uri pkg >>= fun uri ->
+    Pkg.infer_github_distrib_uri pkg >>= fun uri ->
     Logs.warn (fun l ->
         l
           "using %s for as url.src. Note that it might differ from the one \
@@ -164,8 +164,8 @@ let open_pr ~dry_run ~changes ~remote_repo ~user ~distrib_user ~branch ~token
         | Ok () -> Ok 0
         | Error _ -> msg ())
 
-let submit ?distrib_uri ~token ~dry_run ~yes ~opam_repo ~user local_repo
-    remote_repo pkgs auto_open ~draft =
+let submit ~token ~dry_run ~yes ~opam_repo ~user local_repo remote_repo pkgs
+    auto_open ~draft =
   List.fold_left
     (fun acc pkg ->
       get_pkg_dir pkg >>= fun pkg_dir ->
@@ -197,27 +197,25 @@ let submit ?distrib_uri ~token ~dry_run ~yes ~opam_repo ~user local_repo
   list_map Pkg.name pkgs >>= fun names ->
   let title = strf "[new release] %a (%s)" (pp_list Fmt.string) names version in
   Pkg.publish_msg pkg >>= fun changes ->
-  (match distrib_uri with Some uri -> Ok uri | None -> Pkg.infer_repo_uri pkg)
-  >>= Uri.Github.get_user_and_repo
-  >>= fun (distrib_user, repo) ->
+  Pkg.infer_github_repo pkg >>= fun { owner; repo } ->
   let user =
     match user with
     | Some user -> user (* from the .yaml configuration file *)
     | None -> (
         match Github.Parse.user_from_remote remote_repo with
         | Some user -> user (* trying to infer it from the remote repo URI *)
-        | None -> distrib_user)
+        | None -> owner)
   in
-  let changes = Text.rewrite_github_refs ~user:distrib_user ~repo changes in
+  let changes = Text.rewrite_github_refs ~user:owner ~repo changes in
   let msg = strf "%s\n\n%s\n" title changes in
   App_log.status (fun l ->
       l "Preparing %a to %a" Text.Pp.maybe_draft (draft, "pull request")
         pp_opam_repo opam_repo);
   Opam.prepare ~dry_run ~msg ~local_repo ~remote_repo ~opam_repo ~version ~tag
     names
   >>= fun branch ->
-  open_pr ~dry_run ~changes ~remote_repo ~user ~distrib_user ~branch ~token
-    ~title ~opam_repo ~auto_open ~yes ~draft pkg
+  open_pr ~dry_run ~changes ~remote_repo ~user ~distrib_user:owner ~branch
+    ~token ~title ~opam_repo ~auto_open ~yes ~draft pkg
 
 let field pkgs field =
   match field with
@@ -270,8 +268,8 @@ let pkg ?distrib_uri ~dry_run ~pkgs () =
       | (Error _ as e), _ | _, (Error _ as e) -> e)
     (Ok 0) pkgs
 
-let submit ?distrib_uri ?local_repo ?remote_repo ?opam_repo ?user ?token
-    ~dry_run ~pkgs ~pkg_names ~no_auto_open ~yes ~draft () =
+let submit ?local_repo ?remote_repo ?opam_repo ?user ?token ~dry_run ~pkgs
+    ~pkg_names ~no_auto_open ~yes ~draft () =
   let opam_repo =
     match opam_repo with None -> ("ocaml", "opam-repository") | Some r -> r
   in
@@ -295,8 +293,8 @@ let submit ?distrib_uri ?local_repo ?remote_repo ?opam_repo ?user ?token
   >>= fun token ->
   App_log.status (fun m ->
       m "Submitting %a" Fmt.(list ~sep:sp Text.Pp.name) pkg_names);
-  submit ?distrib_uri ~token ~dry_run ~yes ~opam_repo ~user:config.user
-    local_repo remote_repo pkgs auto_open ~draft
+  submit ~token ~dry_run ~yes ~opam_repo ~user:config.user local_repo
+    remote_repo pkgs auto_open ~draft
 
 let field ~pkgs ~field_name = field pkgs field_name
 
@@ -315,8 +313,8 @@ let opam_cli () (`Dry_run dry_run) (`Build_dir build_dir)
         | `Descr -> descr ~pkgs
         | `Pkg -> pkg ~dry_run ?distrib_uri ~pkgs ()
         | `Submit ->
-            submit ?distrib_uri ?local_repo ?remote_repo ?opam_repo ?user ?token
-              ~dry_run ~pkgs ~pkg_names ~no_auto_open ~yes ~draft ()
+            submit ?local_repo ?remote_repo ?opam_repo ?user ?token ~dry_run
+              ~pkgs ~pkg_names ~no_auto_open ~yes ~draft ()
         | `Field -> field ~pkgs ~field_name)
   |> Cli.handle_error
 

bin/opam.mli

@@ -41,7 +41,6 @@ val pkg :
     for success, 1 for failure) or error messages. *)
 
 val submit :
-  ?distrib_uri:string ->
   ?local_repo:string ->
   ?remote_repo:string ->
   ?opam_repo:string * string ->

bin/undraft.ml

@@ -39,8 +39,8 @@ let update_opam_file ~dry_run ~url pkg =
   App_log.success (fun m ->
       m "Wrote opam package description %a" Text.Pp.path dest_opam_file)
 
-let undraft ?opam ?distrib_uri ?distrib_file ?opam_repo ?user ?token ?local_repo
-    ?remote_repo ?build_dir ?pkg_names ~dry_run ~yes:_ () =
+let undraft ?opam ?distrib_file ?opam_repo ?user ?token ?local_repo ?remote_repo
+    ?build_dir ?pkg_names ~dry_run ~yes:_ () =
   let pkg = Pkg.v ?opam ?distrib_file ?build_dir ~dry_run:false () in
   Pkg.name pkg >>= fun pkg_name ->
   Pkg.build_dir pkg >>= fun build_dir ->
@@ -66,16 +66,14 @@ let undraft ?opam ?distrib_uri ?distrib_file ?opam_repo ?user ?token ?local_repo
       | Some r -> Ok r
       | None -> R.error_msg "Unknown remote repository."))
   >>= fun remote_repo ->
-  (match distrib_uri with Some uri -> Ok uri | None -> Pkg.infer_repo_uri pkg)
-  >>= Uri.Github.get_user_and_repo
-  >>= fun (distrib_user, repo) ->
+  Pkg.infer_github_repo pkg >>= fun { owner; repo } ->
   let user =
     match config.user with
     | Some user -> user (* from the .yaml configuration file *)
     | None -> (
         match Github.Parse.user_from_remote remote_repo with
         | Some user -> user (* trying to infer it from the remote repo URI *)
-        | None -> distrib_user)
+        | None -> owner)
   in
   (match token with Some t -> Ok t | None -> Config.token ~dry_run ())
   >>= fun token ->
@@ -143,12 +141,12 @@ let undraft ?opam ?distrib_uri ?distrib_file ?opam_repo ?user ?token ?local_repo
         Text.Pp.name pkg_name Text.Pp.version version url);
   Ok 0
 
-let undraft_cli () (`Dist_uri distrib_uri) (`Dist_opam opam)
-    (`Dist_file distrib_file) (`Opam_repo opam_repo) (`User user) (`Token token)
-    (`Local_repo local_repo) (`Remote_repo remote_repo) (`Build_dir build_dir)
-    (`Package_names pkg_names) (`Dry_run dry_run) (`Yes yes) =
-  undraft ?opam ?distrib_uri ?distrib_file ?opam_repo ?user ?token ?local_repo
-    ?remote_repo ?build_dir ~pkg_names ~dry_run ~yes ()
+let undraft_cli () (`Dist_opam opam) (`Dist_file distrib_file)
+    (`Opam_repo opam_repo) (`User user) (`Token token) (`Local_repo local_repo)
+    (`Remote_repo remote_repo) (`Build_dir build_dir) (`Package_names pkg_names)
+    (`Dry_run dry_run) (`Yes yes) =
+  undraft ?opam ?distrib_file ?opam_repo ?user ?token ?local_repo ?remote_repo
+    ?build_dir ~pkg_names ~dry_run ~yes ()
   |> Cli.handle_error
 
 (* Command line interface *)
@@ -189,7 +187,7 @@ let man =
 
 let cmd =
   ( Term.(
-      pure undraft_cli $ Cli.setup $ Cli.dist_uri $ Cli.dist_opam
-      $ Cli.dist_file $ Cli.opam_repo $ Cli.user $ Cli.token $ Cli.local_repo
-      $ Cli.remote_repo $ Cli.build_dir $ Cli.pkg_names $ Cli.dry_run $ Cli.yes),
+      pure undraft_cli $ Cli.setup $ Cli.dist_opam $ Cli.dist_file
+      $ Cli.opam_repo $ Cli.user $ Cli.token $ Cli.local_repo $ Cli.remote_repo
+      $ Cli.build_dir $ Cli.pkg_names $ Cli.dry_run $ Cli.yes),
     Term.info "undraft" ~doc ~sdocs ~exits ~envs ~man ~man_xrefs )

lib/check.ml

@@ -51,7 +51,7 @@ let pkg_creation_check ?tag ?version ~keep_v ?build_dir dir =
 
 let opam_file_check ~dir pkg =
   let check () =
-    let ok_needed = Pkg.infer_repo_uri pkg >>= Uri.Github.get_user_and_repo in
+    let ok_needed = Pkg.infer_github_repo pkg in
     Pkg.opam pkg >>| fun main_opam ->
     (* Pkg.opam only returns an error if something is wrong internally *)
     match ok_needed with

lib/config.ml

@@ -94,8 +94,7 @@ let create_config ~user ~remote_repo ~local_repo pkgs file =
   | Some u -> Ok u
   | None ->
       let pkg = List.hd pkgs in
-      Pkg.infer_repo_uri pkg >>= Uri.Github.get_user_and_repo >>= fun (u, _) ->
-      Ok u)
+      Pkg.infer_github_repo pkg >>= fun { owner; _ } -> Ok owner)
   >>= fun default_user ->
   let user = read_string default_user ~descr:"What is your GitHub ID?" in
   let default_remote =

lib/delegate.ml

@@ -34,7 +34,10 @@ let publish_distrib ?token ?distrib_uri ~dry_run ~msg ~archive ~yes ~draft pkg =
       Pkg.tag pkg >>= fun version ->
       (match distrib_uri with
       | Some uri -> Ok uri
-      | None -> Pkg.infer_distrib_uri pkg)
+      | None ->
+          (* This is an absolute non-sense but we're keeping it to preserve the
+             behaviour until 2.0 and removal of delegates *)
+          Pkg.infer_github_distrib_uri pkg)
       >>= fun distrib_uri ->
       run_delegate ~dry_run del
         Cmd.(
@@ -63,7 +66,7 @@ let publish_alt ?distrib_uri ~dry_run ~kind ~msg ~archive p =
       Pkg.version p >>= fun version ->
       (match distrib_uri with
       | Some uri -> Ok uri
-      | None -> Pkg.infer_distrib_uri p)
+      | None -> Pkg.infer_github_distrib_uri p)
       >>= fun distrib_uri ->
       run_delegate ~dry_run del
         Cmd.(

lib/github.ml

@@ -135,7 +135,8 @@ let publish_in_git_branch ~dry_run ~remote ~branch ~name ~version ~docdir ~dir
         Ok ()
 
 let publish_doc ~dry_run ~msg:_ ~docdir ~yes p =
-  (if dry_run then Ok D.(user, repo, dir) else Pkg.doc_user_repo_and_path p)
+  (if dry_run then Ok D.(user, repo, dir)
+  else Pkg.github_doc_owner_repo_and_path p)
   >>= fun (user, repo, dir) ->
   Pkg.name p >>= fun name ->
   Pkg.version p >>= fun version ->
@@ -447,11 +448,13 @@ let create_release ~dry_run ~yes ~dev_repo ~token ~msg ~tag ~version ~user ~repo
       Ok id
 
 let publish_distrib ?token ~dry_run ~msg ~archive ~yes ~draft p =
-  Pkg.infer_repo_uri p >>= fun uri ->
-  (match Uri.Github.get_user_and_repo uri with
-  | Error _ as e -> if dry_run then Ok (D.user, D.repo) else e
-  | r -> r)
-  >>= fun (user, repo) ->
+  (match Pkg.infer_github_repo p with
+  | Ok r -> Ok r
+  | Error _ as e ->
+      (* It probably does not make sense for dry-run to push any further
+         if the github repo cannot be infered, we should remove in 2.0. *)
+      if dry_run then Ok { owner = D.user; repo = D.repo } else e)
+  >>= fun { owner; repo } ->
   Pkg.tag p >>= fun tag ->
   assert_tag_exists ~dry_run tag >>= fun () ->
   Vcs.get () >>= fun vcs ->
@@ -463,8 +466,8 @@ let publish_distrib ?token ~dry_run ~msg ~archive ~yes ~draft p =
   push_tag ~dry_run ~yes ~dev_repo vcs tag >>= fun () ->
   (match token with Some t -> Ok t | None -> Config.token ~dry_run ())
   >>= fun token ->
-  create_release ~dry_run ~yes ~dev_repo ~token ~version ~msg ~tag ~user ~repo
-    ~draft
+  create_release ~dry_run ~yes ~dev_repo ~token ~version ~msg ~tag ~user:owner
+    ~repo ~draft
   >>= fun id ->
   (if draft then
    Config.Draft_release.set ~dry_run ~build_dir ~name ~version
@@ -479,7 +482,7 @@ let publish_distrib ?token ~dry_run ~msg ~archive ~yes ~draft p =
   App_log.status (fun l ->
       l "Uploading %a as a release asset for %a via github's API" Text.Pp.path
         archive Text.Pp.version version);
-  curl_upload_archive ~token ~dry_run ~yes archive user repo id
+  curl_upload_archive ~token ~dry_run ~yes archive owner repo id
   >>= fun (url, asset_name) ->
   (if draft then
    Config.Release_asset_name.set ~dry_run ~build_dir ~name ~version asset_name

lib/github_repo.ml

@@ -0,0 +1,67 @@
+open Bos_setup
+
+type t = { owner : string; repo : string }
+
+let equal t t' =
+  let { owner; repo } = t in
+  let { owner = owner'; repo = repo' } = t' in
+  String.equal owner owner' && String.equal repo repo'
+
+let pp fmt { owner; repo } =
+  Format.fprintf fmt "@[<hov 2>{ owner = %S;@ repo = %S }@]" owner repo
+
+let drop_git_ext repo =
+  let affix = ".git" in
+  if String.is_suffix ~affix repo then
+    let len = String.length repo - String.length affix in
+    StringLabels.sub ~pos:0 ~len repo
+  else repo
+
+let from_uri uri =
+  let uri = Uri_helpers.parse uri in
+  match uri with
+  | Some
+      {
+        scheme = Some ("git+https" | "https") | None;
+        domain = [ "com"; "github" ];
+        path = [ owner; repo ];
+      }
+  | Some
+      {
+        scheme = Some "https" | None;
+        domain = [ "io"; "github"; owner ];
+        path = repo :: _;
+      }
+  | Some
+      {
+        scheme = Some ("git+ssh" | "ssh") | None;
+        domain = [ "com"; "git@github" ];
+        path = [ owner; repo ];
+      } ->
+      let repo = drop_git_ext repo in
+      Some { owner; repo }
+  | _ -> None
+
+let fpath_of_list l =
+  let rec aux acc l =
+    match l with [] | [ "" ] -> acc | hd :: tl -> aux Fpath.(acc / hd) tl
+  in
+  match l with [] | [ "" ] -> Fpath.v "." | hd :: tl -> aux (Fpath.v hd) tl
+
+let from_gh_pages uri =
+  let uri = Uri_helpers.parse uri in
+  match uri with
+  | Some
+      {
+        scheme = Some "https" | None;
+        domain = [ "io"; "github"; owner ];
+        path = repo :: rest;
+      } ->
+      Some ({ owner; repo }, fpath_of_list rest)
+  | _ -> None
+
+let https_uri { owner; repo } =
+  Printf.sprintf "https://github.com/%s/%s" owner repo
+
+let ssh_uri { owner; repo } =
+  Printf.sprintf "git@github.com:%s/%s.git" owner repo

lib/github_repo.mli

@@ -0,0 +1,21 @@
+type t = { owner : string; repo : string }
+
+val equal : t -> t -> bool
+
+val pp : Format.formatter -> t -> unit
+
+val from_uri : string -> t option
+(** Parse a github URI into owner and repo. Return [None] if the given URI isn't
+    a github one. *)
+
+val from_gh_pages : string -> (t * Fpath.t) option
+(** Parse a github pages URI of the form <owner>.github.io/<repo>/<extra_path>
+    into [({owner; repo}, extra_path)]. [extra_path] is [Fpath.v "."] if there
+    is no such component in the URI. Return [None] if the URI isn't a gh-pages
+    one. *)
+
+val https_uri : t -> string
+(** Returns the HTTPS URI, in string form for the given repo *)
+
+val ssh_uri : t -> string
+(** Returns the ["git@github"] SSH URI, in string form for the given repo *)

lib/lint.ml

@@ -88,7 +88,7 @@ let lint_opam_doc pkg =
       App_log.report_status `Ok (fun l ->
           l "Skipping doc field linting, no doc field found")
   | Ok _ ->
-      let pass = R.is_ok (Pkg.doc_user_repo_and_path pkg) in
+      let pass = R.is_ok (Pkg.github_doc_owner_repo_and_path pkg) in
       let status = if pass then `Ok else `Fail in
       let verdict = if pass then "can" else "cannot" in
       App_log.report_status status (fun l ->
@@ -100,7 +100,7 @@ let lint_opam_home_and_dev pkg =
     ~msgf:(fun l ->
       l "opam fields %a and %a can be parsed by dune-release" pp_field
         "homepage" pp_field "dev-repo")
-    (Pkg.infer_repo_uri pkg >>= Uri.Github.get_user_and_repo)
+    (Pkg.infer_github_repo pkg)
 
 let lint_opam_github_fields pkg = lint_opam_doc pkg + lint_opam_home_and_dev pkg