Add support for gitlab/bitbucket sources

It's just as easy to support them as github

Signed-off-by: Rudi Grinberg <[email protected]>

CHANGES.md

@@ -16,11 +16,15 @@ Unreleased
 - Add the `executable` field to `inline_tests` to customize the compilation
   flags of the test runner executable (#3747, fixes #3679, @lubegasimon)
 
-- Add (enabled_if ...) to (copy_files ...) (#3756, @nojb)
+- Add `(enabled_if ...)` to `(copy_files ...)` (#3756, @nojb)
 
 - Make sure Dune cleans up the status line before exiting (#3767,
   fixes #3737, @alan-j-hu)
 
+- Add `{gitlab,bitbucket}` as options for defining project sources with `source`
+  stanza `(source (<host> user/repo))` in the `dune-project` file.  (#3813,
+  @rgrinberg)
+
 2.7.1 (2/09/2020)
 -----------------
 

src/dune_engine/package.ml

@@ -225,33 +225,95 @@ module Dependency = struct
 end
 
 module Source_kind = struct
+  module Host = struct
+    type kind =
+      | Github
+      | Bitbucket
+      | Gitlab
+
+    let to_string = function
+      | Github -> "github"
+      | Bitbucket -> "bitbucket"
+      | Gitlab -> "gitlab"
+
+    type t =
+      { user : string
+      ; repo : string
+      ; kind : kind
+      }
+
+    let dyn_of_kind kind = kind |> to_string |> Dyn.Encoder.string
+
+    let to_dyn { user; repo; kind } =
+      let open Dyn.Encoder in
+      record
+        [ ("kind", dyn_of_kind kind)
+        ; ("user", string user)
+        ; ("repo", string repo)
+        ]
+
+    let host_of_kind = function
+      | Github -> "github.com"
+      | Bitbucket -> "bitbucket.org"
+      | Gitlab -> "gitlab.com"
+
+    let homepage { kind; user; repo } =
+      let host = host_of_kind kind in
+      sprintf "https://%s/%s/%s" host user repo
+
+    let bug_reports t =
+      homepage t
+      ^
+      match t.kind with
+      | Bitbucket
+      | Github ->
+        "/issues"
+      | Gitlab -> "/-/issues"
+
+    let enum k =
+      [ ("GitHub", Github, None)
+      ; ("Bitbucket", Bitbucket, Some (2, 8))
+      ; ("Gitlab", Gitlab, Some (2, 8))
+      ]
+      |> List.map ~f:(fun (name, kind, since) ->
+             let decode =
+               let of_string ~loc s =
+                 match String.split ~on:'/' s with
+                 | [ user; repo ] -> k { kind; user; repo }
+                 | _ ->
+                   User_error.raise ~loc
+                     [ Pp.textf "%s repository must be of form user/repo" name ]
+               in
+               let open Dune_lang.Decoder in
+               ( match since with
+               | None -> return ()
+               | Some v -> Dune_lang.Syntax.since Stanza.syntax v )
+               >>> plain_string of_string
+             in
+             let constr = to_string kind in
+             (constr, decode))
+
+    let to_string { user; repo; kind } =
+      sprintf "git+https://%s/%s/%s.git" (host_of_kind kind) user repo
+  end
+
   type t =
-    | Github of string * string
+    | Host of Host.t
     | Url of string
 
   let to_dyn =
     let open Dyn.Encoder in
     function
-    | Github (user, repo) -> constr "Github" [ string user; string repo ]
+    | Host h -> constr "Host" [ Host.to_dyn h ]
     | Url url -> constr "Url" [ string url ]
 
   let to_string = function
-    | Github (user, repo) ->
-      sprintf "git+https://github.com/%s/%s.git" user repo
+    | Host h -> Host.to_string h
     | Url u -> u
 
   let decode =
     let open Dune_lang.Decoder in
-    sum
-      [ ( "github"
-        , plain_string (fun ~loc s ->
-              match String.split ~on:'/' s with
-              | [ user; repo ] -> Github (user, repo)
-              | _ ->
-                User_error.raise ~loc
-                  [ Pp.textf "GitHub repository must be of form user/repo" ]) )
-      ; ("uri", string >>| fun s -> Url s)
-      ]
+    sum (("uri", string >>| fun s -> Url s) :: Host.enum (fun x -> Host x))
 end
 
 module Info = struct
@@ -273,14 +335,12 @@ module Info = struct
 
   let homepage t =
     match (t.homepage, t.source) with
-    | None, Some (Github (user, repo)) ->
-      Some (sprintf "https://github.com/%s/%s" user repo)
+    | None, Some (Host h) -> Some (Source_kind.Host.homepage h)
     | s, _ -> s
 
   let bug_reports t =
     match (t.bug_reports, t.source) with
-    | None, Some (Github (user, repo)) ->
-      Some (sprintf "https://github.com/%s/%s/issues" user repo)
+    | None, Some (Host h) -> Some (Source_kind.Host.bug_reports h)
     | s, _ -> s
 
   let documentation t = t.documentation

src/dune_engine/package.mli

@@ -59,8 +59,23 @@ module Dependency : sig
 end
 
 module Source_kind : sig
+  module Host : sig
+    type kind =
+      | Github
+      | Bitbucket
+      | Gitlab
+
+    type t =
+      { user : string
+      ; repo : string
+      ; kind : kind
+      }
+
+    val homepage : t -> string
+  end
+
   type t =
-    | Github of string * string
+    | Host of Host.t
     | Url of string
 
   val to_dyn : t Dyn.Encoder.t

src/dune_rules/watermarks.ml

@@ -230,6 +230,9 @@ let make_watermark_map ~commit ~version ~dune_project ~package =
   in
   let name = Dune_project.name dune_project in
   let info = package.Package.info in
+  (* XXX these error messages aren't particularly good as these values do not
+     necessarily come from the project file. It's possible for them to be
+     defined in the .opam file directly*)
   let make_value name = function
     | None -> Error (sprintf "variable %S not found in dune-project file" name)
     | Some value -> Ok value
@@ -239,8 +242,8 @@ let make_watermark_map ~commit ~version ~dune_project ~package =
     | Some value -> Ok (String.concat ~sep value)
   in
   let make_dev_repo_value = function
-    | Some (Package.Source_kind.Github (user, repo)) ->
-      Ok (sprintf "https://github.com/%s/%s" user repo)
+    | Some (Package.Source_kind.Host h) ->
+      Ok (Package.Source_kind.Host.homepage h)
     | Some (Package.Source_kind.Url url) -> Ok url
     | None -> Error (sprintf "variable dev-repo not found in dune-project file")
   in