Sanitize git branch names

CHANGES.md

@@ -60,6 +60,7 @@
 - Fix rewriting of github references in changelog (#330, @gpetiot)
 - Fixes a bug under cygwin where dune-release was unable to find the commit hash corresponding to the release tag (#329, @gpetiot)
 - Fixes release names by explicitly setting it to match the released version (#338, @NathanReb)
+- Fix a bug that prevented release of a package whose version number contains invalid characters for a git branch. The git branch names are now sanitized. (#271, @gpetiot)
 
 ### Security
 

bin/opam.ml

@@ -177,6 +177,7 @@ let submit ?distrib_uri ~token ~dry_run ~yes ~opam_repo ~user local_repo
   >>= fun _ ->
   let pkg = List.hd pkgs in
   Pkg.version pkg >>= fun version ->
+  Pkg.tag pkg >>= fun tag ->
   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 ->
@@ -197,7 +198,8 @@ let submit ?distrib_uri ~token ~dry_run ~yes ~opam_repo ~user local_repo
   let msg = strf "%s\n\n%s\n" title changes in
   App_log.status (fun l ->
       l "Preparing pull request to %a" pp_opam_repo opam_repo);
-  Opam.prepare ~dry_run ~msg ~local_repo ~remote_repo ~opam_repo ~version names
+  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 pkg

bin/tag.ml

@@ -7,8 +7,10 @@
 open Bos_setup
 open Dune_release
 
-let vcs_tag pkg tag ~dry_run ~commit_ish ~force ~sign ~delete ~msg ~yes =
-  Vcs.get () >>= fun repo ->
+let vcs_tag repo pkg version ~dry_run ~commit_ish ~force ~sign ~delete ~msg ~yes
+    =
+  let tag = Vcs.sanitize_tag repo version in
+  App_log.status (fun l -> l "Using tag %S" tag);
   Vcs.commit_id ~dirty:false ~commit_ish repo
   |> R.reword_error (fun (`Msg msg) ->
          R.msgf "Due to invalid commit-ish `%s`:\n%s" commit_ish msg)
@@ -63,32 +65,27 @@ let vcs_tag pkg tag ~dry_run ~commit_ish ~force ~sign ~delete ~msg ~yes =
       | Some msg -> Ok msg
       | None ->
           Pkg.publish_msg pkg >>| fun msg ->
-          strf "Distribution %s\n\n%s" tag msg)
+          strf "Distribution %s\n\n%s" version msg)
       >>= fun msg ->
       Vcs.tag repo ~dry_run ~force ~sign ~msg ~commit_ish tag >>| fun () ->
       App_log.success (fun m ->
           m "Tagged %a with version %a" Text.Pp.commit commit_ish
             Text.Pp.version tag)
 
-let tag () (`Dry_run dry_run) (`Change_log change_log) (`Version tag)
+let tag () (`Dry_run dry_run) (`Change_log change_log) (`Version version)
     (`Commit_ish commit_ish) (`Force force) (`Sign sign) (`Delete delete)
     (`Msg msg) (`Yes yes) =
   (let pkg = Pkg.v ~dry_run ?change_log () in
-   let tag =
-     match tag with
-     | Some t ->
-         App_log.status (fun l -> l "Using provided tag %S" t);
-         Ok t
-     | None ->
-         Pkg.change_log pkg >>= fun changelog ->
-         App_log.status (fun l ->
-             l "Extracting tag from first entry in %a" Text.Pp.path changelog);
-         Pkg.extract_tag pkg >>| fun t ->
-         App_log.status (fun l -> l "Using tag %S" t);
-         t
-   in
-   tag >>= fun tag ->
-   vcs_tag pkg tag ~dry_run ~commit_ish ~force ~sign ~delete ~msg ~yes
+   Vcs.get () >>= fun vcs ->
+   (match version with
+   | Some v -> Ok v
+   | None ->
+       Pkg.change_log pkg >>= fun changelog ->
+       App_log.status (fun l ->
+           l "Extracting tag from first entry in %a" Text.Pp.path changelog);
+       Pkg.extract_version pkg)
+   >>= fun version ->
+   vcs_tag vcs pkg version ~dry_run ~commit_ish ~force ~sign ~delete ~msg ~yes
    >>= fun () -> Ok 0)
   |> Cli.handle_error
 

lib/curl.ml

@@ -2,12 +2,12 @@ open Bos_setup
 
 type t = { url : string; args : Curl_option.t list }
 
-let create_release ~version ~msg ~user ~repo =
+let create_release ~version ~tag ~msg ~user ~repo =
   let json : string =
     Yojson.Basic.to_string
       (`Assoc
         [
-          ("tag_name", `String version);
+          ("tag_name", `String tag);
           ("name", `String version);
           ("body", `String msg);
         ])

lib/curl.mli

@@ -1,15 +1,15 @@
 type t = { url : string; args : Curl_option.t list }
 
 val create_release :
-  version:string -> msg:string -> user:string -> repo:string -> t
+  version:string -> tag:string -> msg:string -> user:string -> repo:string -> t
 
 val upload_archive :
   archive:Fpath.t -> user:string -> repo:string -> release_id:int -> t
 
 val open_pr :
   title:string ->
   user:string ->
-  branch:string ->
+  branch:Vcs.commit_ish ->
   body:string ->
   opam_repo:string * string ->
   t

lib/github.ml

@@ -205,9 +205,9 @@ let run_with_auth ?(default_body = `Null) ~dry_run ~auth curl_t =
         Json.from_string resp.body
     | Error e -> R.error_msgf "curl execution failed: %a" Curly.Error.pp e
 
-let curl_create_release ~token ~dry_run version msg user repo =
+let curl_create_release ~token ~dry_run ~version ~tag msg user repo =
   github_auth ~dry_run ~user token >>= fun auth ->
-  let curl_t = Curl.create_release ~version ~msg ~user ~repo in
+  let curl_t = Curl.create_release ~version ~tag ~msg ~user ~repo in
   let default_body = `Assoc [ ("id", `Int D.release_id) ] in
   run_with_auth ~dry_run ~default_body ~auth curl_t
   >>= Github_v3_api.Release_response.release_id
@@ -338,9 +338,9 @@ let publish_distrib ?token ?distrib_uri ~dry_run ~msg ~archive ~yes p =
   | r -> r)
   >>= fun (user, repo) ->
   Pkg.tag p >>= fun tag ->
+  Pkg.version p >>= fun version ->
   assert_tag_exists ~dry_run tag >>= fun () ->
   Vcs.get () >>= fun vcs ->
-  Pkg.tag p >>= fun tag ->
   check_tag ~dry_run vcs tag >>= fun () ->
   dev_repo p >>= fun dev_repo ->
   push_tag ~dry_run ~yes ~dev_repo vcs tag >>= fun () ->
@@ -349,13 +349,14 @@ let publish_distrib ?token ?distrib_uri ~dry_run ~msg ~archive ~yes p =
   Prompt.(
     confirm_or_abort ~yes
       ~question:(fun l ->
-        l "Create release %a on %a?" Text.Pp.version tag Text.Pp.url dev_repo)
+        l "Create release %a on %a?" Text.Pp.version version Text.Pp.url
+          dev_repo)
       ~default_answer:Yes)
   >>= fun () ->
   App_log.status (fun l ->
-      l "Creating release %a on %a via github's API" Text.Pp.version tag
+      l "Creating release %a on %a via github's API" Text.Pp.version version
         Text.Pp.url dev_repo);
-  curl_create_release ~token ~dry_run tag msg user repo >>= fun id ->
+  curl_create_release ~token ~dry_run ~version ~tag msg user repo >>= fun id ->
   App_log.success (fun l -> l "Succesfully created release with id %d" id);
   Prompt.(
     confirm_or_abort ~yes
@@ -364,7 +365,7 @@ let publish_distrib ?token ?distrib_uri ~dry_run ~msg ~archive ~yes p =
   >>= fun () ->
   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 tag);
+        archive Text.Pp.version version);
   curl_upload_archive ~token ~dry_run ~yes archive user repo id
 
 (*---------------------------------------------------------------------------

lib/github.mli

@@ -51,7 +51,7 @@ val open_pr :
   title:string ->
   distrib_user:string ->
   user:string ->
-  branch:string ->
+  branch:Vcs.commit_ish ->
   opam_repo:string * string ->
   string ->
   ([ `Url of string | `Already_exists ], R.msg) result

lib/opam.ml

@@ -51,7 +51,8 @@ let cmd = Cmd.of_list @@ Cmd.to_list @@ tool "opam" `Host_os
 let shortest x =
   List.hd (List.sort (fun x y -> compare (String.length x) (String.length y)) x)
 
-let prepare ~dry_run ?msg ~local_repo ~remote_repo ~opam_repo ~version names =
+let prepare ~dry_run ?msg ~local_repo ~remote_repo ~opam_repo ~version ~tag
+    names =
   let msg =
     match msg with
     | None -> Ok Cmd.empty
@@ -75,7 +76,7 @@ let prepare ~dry_run ?msg ~local_repo ~remote_repo ~opam_repo ~version names =
   in
   let remote_branch = "master" in
   let pkg = shortest names in
-  let branch = Fmt.strf "release-%s-%s" pkg version in
+  let branch = Fmt.strf "release-%s-%s" pkg tag in
   let prepare_repo () =
     App_log.status (fun l ->
         l "Fetching %a" Text.Pp.url (upstream ^ "#" ^ remote_branch));

lib/opam.mli

@@ -22,8 +22,9 @@ val prepare :
   remote_repo:string ->
   opam_repo:string * string ->
   version:string ->
+  tag:Vcs.commit_ish ->
   string list ->
-  (string, R.msg) result
+  (Vcs.commit_ish, R.msg) result
 (** [prepare ~local_repo ~version pkgs] adds the packages [pkg.version] to a new
     branch in the local opam repository [local_repo], using the commit message
     [msg] (if any). Return the new branch. *)

lib/pkg.ml

@@ -80,6 +80,28 @@ let tag p =
   | None, None -> Vcs.get () >>= fun r -> Vcs.describe ~dirty:false r
   | None, Some v -> Ok v
 
+let extract_version change_log =
+  Text.change_log_file_last_entry change_log >>= fun (version, _) -> Ok version
+
+let find_files path ~names_wo_ext =
+  OS.Dir.contents path >>| fun files ->
+  Stdext.Path.find_files files ~names_wo_ext
+
+let change_logs p =
+  match p.change_logs with
+  | Some f -> Ok f
+  | None -> find_files (Fpath.v ".") ~names_wo_ext:[ "changes"; "changelog" ]
+
+let change_log p =
+  change_logs p >>= function
+  | [] -> R.error_msgf "No change log specified in the package description."
+  | l :: _ -> Ok l
+
+let extract_version pkg = change_log pkg >>= fun cl -> extract_version cl
+
+let infer_version pkg =
+  match extract_version pkg with Ok t -> Ok t | Error _ -> tag pkg
+
 let drop_initial_v version =
   match String.head version with
   | Some ('v' | 'V') -> String.with_index_range ~first:1 version
@@ -88,7 +110,8 @@ let drop_initial_v version =
 let version p =
   match p.version with
   | Some v -> Ok v
-  | None -> tag p >>| fun t -> if p.drop_v then drop_initial_v t else t
+  | None ->
+      infer_version p >>| fun t -> if p.drop_v then drop_initial_v t else t
 
 let delegate p =
   let not_found = function
@@ -136,10 +159,6 @@ let delegate p =
 let build_dir p =
   match p.build_dir with Some b -> Ok b | None -> Ok (Fpath.v "_build")
 
-let find_files path ~names_wo_ext =
-  OS.Dir.contents path >>| fun files ->
-  Stdext.Path.find_files files ~names_wo_ext
-
 let readmes p =
   match p.readmes with
   | Some f -> Ok f
@@ -187,16 +206,6 @@ let opam_descr p =
       | Some v -> R.error_msgf "unsupported opam version: %s" v
       | None -> R.error_msgf "missing opam-version field")
 
-let change_logs p =
-  match p.change_logs with
-  | Some f -> Ok f
-  | None -> find_files (Fpath.v ".") ~names_wo_ext:[ "changes"; "changelog" ]
-
-let change_log p =
-  change_logs p >>= function
-  | [] -> R.error_msgf "No change log specified in the package description."
-  | l :: _ -> Ok l
-
 let licenses p =
   match p.licenses with
   | Some f -> Ok f
@@ -272,14 +281,14 @@ let infer_distrib_uri p =
   | _ -> Ok uri)
   >>= fun uri ->
   name p >>= fun name ->
-  tag p >>= fun tag ->
+  infer_version p >>= fun tag ->
   let defs = String.Map.(empty |> add "NAME" name |> add "TAG" tag) in
   Pat.of_string uri >>| Pat.format defs
 
 let distrib_filename ?(opam = false) p =
   let sep = if opam then '.' else '-' in
   name p >>= fun name ->
-  (if opam then version p else tag p) >>= fun version ->
+  (if opam then version p else infer_version p) >>= fun version ->
   Fpath.of_string (strf "%s%c%s" name sep version)
 
 let distrib_archive_path p =
@@ -532,7 +541,7 @@ let distrib_archive ~dry_run ~keep_dir ~include_submodules p =
   Vcs.commit_ptime_s repo_vcs ~dry_run ~commit_ish:tag >>= fun mtime ->
   Vcs.clone ~dry_run ~force:true repo_vcs ~dir:dist_build_dir >>= fun () ->
   Vcs.get ~dir:dist_build_dir () >>= fun clone_vcs ->
-  Ok (Fmt.strf "dune-release-dist-%s" tag) >>= fun branch ->
+  let branch = Fmt.strf "dune-release-dist-%s" tag in
   Vcs.checkout ~dry_run clone_vcs ~branch ~commit_ish:tag >>= fun () ->
   (if include_submodules then pull_submodules ~dry_run ~dist_build_dir
   else Ok ())
@@ -567,13 +576,6 @@ let test ~dry_run ~dir ~args ~out pkg_names =
 let build ~dry_run ~dir ~args ~out pkg_names =
   run ~dry_run ~dir ~args ~out ~default:(Sos.out "") pkg_names "build"
 
-(* tags *)
-
-let extract_version change_log =
-  Text.change_log_file_last_entry change_log >>= fun (version, _) -> Ok version
-
-let extract_tag pkg = change_log pkg >>= fun cl -> extract_version cl
-
 (*---------------------------------------------------------------------------
    Copyright (c) 2016 Daniel C. Bünzli
 

lib/pkg.mli

@@ -137,9 +137,11 @@ val test : f
 
 val build : f
 
-(** {1 Tag} *)
+(** {1 Version} *)
 
-val extract_tag : t -> (string, Sos.error) result
+val extract_version : t -> (string, Sos.error) result
+(** [extract_version p] extracts the version identifier from the changelog of
+    [p]. *)
 
 (** {1 Dev repo} *)
 

lib/text.mli

@@ -74,7 +74,7 @@ module Pp : sig
   val version : string Fmt.t
   (** [version] formats a package version. *)
 
-  val commit : string Fmt.t
+  val commit : Vcs.commit_ish Fmt.t
   (** [commit] formats a commit-ish. *)
 
   val dirty : unit Fmt.t

lib/vcs.ml

@@ -183,6 +183,35 @@ let git_ls_remote ~dry_run r ~kind ~filter upstream =
 let git_submodule_update ~dry_run r =
   run_git_quiet ~dry_run r Cmd.(v "submodule" % "update" % "--init")
 
+let unallowed_substrings = Re.(compile (alt [ str "@{"; str ".." ]))
+
+(* See the reference here: https://git-scm.com/docs/git-check-ref-format *)
+let git_sanitize_tag t =
+  let last = String.length t - 1 in
+  if String.equal t "@" then "_AT_"
+  else
+    String.fold_left
+      (fun (ret, i) c ->
+        let s =
+          match (i, c) with
+          | 0, '/' -> "_SLASH_"
+          | i, '/' when i = last -> "_SLASH_"
+          | i, '.' when i = last -> "_DOT_"
+          | _, ' ' -> "_SPACE_"
+          | _, '~' -> "_TILDE_"
+          | _, '^' -> "_CARET_"
+          | _, ':' -> "_COLON_"
+          | _, '?' -> "_QUEST_"
+          | _, '*' -> "_TIMES_"
+          | _, '[' -> "_LBRACKET_"
+          | _, '\\' -> "_BSLASH_"
+          | _ -> String.of_char c
+        in
+        (ret ^ s, i + 1))
+      ("", 0) t
+    |> fst
+    |> Re.replace_string ~all:true unallowed_substrings ~by:"__"
+
 (* Hg support *)
 
 let hg_rev commit_ish = match commit_ish with "HEAD" -> "tip" | c -> c
@@ -268,6 +297,8 @@ let hg_tag r ~force ~sign ~msg ~rev tag =
 let hg_delete_tag r tag =
   run_hg r Cmd.(v "tag" % "--remove" % tag) OS.Cmd.out_stdout
 
+let hg_sanitize_tag t = t
+
 (* Generic VCS support *)
 
 let find ?dir () =
@@ -362,6 +393,10 @@ let submodule_update ~dry_run r =
   | (`Git, _, _) as r -> git_submodule_update ~dry_run r
   | `Hg, _, _ -> R.error_msgf "submodule update is not supported with mercurial"
 
+let sanitize_tag = function
+  | `Git, _, _ -> git_sanitize_tag
+  | `Hg, _, _ -> hg_sanitize_tag
+
 (*---------------------------------------------------------------------------
    Copyright (c) 2016 Daniel C. Bünzli