Skip to content

Commit

Permalink
rework source kind types to provide strict creation
Browse files Browse the repository at this point in the history 
Signed-off-by: teague hansen <thanse23@asu.edu>
  • Loading branch information
@H-ANSEN
H-ANSEN committed Jul 25, 2024
1 parent 9331a36 commit 17f4de0
Show file tree
Hide file tree
Showing 3 changed files with 101 additions and 95 deletions.
6 changes: 1 addition & 5 deletions src/dune_lang/package_info.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,11 +43,7 @@ let empty =

let example =
{ source =
Some
(Host
{ repo = Source_kind.Host.User_repo { user = "username"; repo = "reponame" }
; kind = Source_kind.Host.Github
})
Some (Host (Source_kind.Host.Github { user = "username"; repo = "reponame" }))
; license = Some [ "LICENSE" ]
; authors = Some [ "Author Name" ]
; maintainers = Some [ "Maintainer Name" ]
Expand Down
167 changes: 90 additions & 77 deletions src/dune_lang/source_kind.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,102 +2,113 @@ open Stdune
open Dune_sexp

module Host = struct
type kind =
| Github
| Bitbucket
| Gitlab
| Sourcehut

let to_string = function
| Github -> "github"
| Bitbucket -> "bitbucket"
| Gitlab -> "gitlab"
| Sourcehut -> "sourcehut"
;;
type user_repo =
{ user : string
; repo : string
}

type repo =
| User_repo of
{ user : string
; repo : string
}
type gitlab_repo =
| User_repo of user_repo
| Org_repo of
{ org : string
; proj : string
; repo : string
}

type t =
{ repo : repo
; kind : kind
}

let dyn_of_kind kind = kind |> to_string |> Dyn.string
| Github of user_repo
| Bitbucket of user_repo
| Gitlab of gitlab_repo
| Sourcehut of user_repo

let kind_string = function
| Github _ -> "github"
| Bitbucket _ -> "bitbucket"
| Gitlab _ -> "gitlab"
| Sourcehut _ -> "sourcehut"
;;

let to_dyn { repo; kind } =
let dyn_of_user_repo kind { user; repo } =
let open Dyn in
record [ "kind", kind; "user", string user; "repo", string repo ]
;;

let dyn_of_gitlab_repo kind repo =
match repo with
| User_repo { user; repo } ->
record [ "kind", dyn_of_kind kind; "user", string user; "repo", string repo ]
| User_repo user_repo -> dyn_of_user_repo kind user_repo
| Org_repo { org; proj; repo } ->
record
[ "kind", dyn_of_kind kind
; "org", string org
; "proj", string proj
; "repo", string repo
]
let open Dyn in
record [ "kind", kind; "org", string org; "proj", string proj; "repo", string repo ]
;;

let to_dyn repo =
let kind = Dyn.string (kind_string repo) in
match repo with
| Gitlab gitlab_repo -> dyn_of_gitlab_repo kind gitlab_repo
| Github user_repo | Bitbucket user_repo | Sourcehut user_repo ->
dyn_of_user_repo kind user_repo
;;

let host_of_kind = function
| Github -> "github.com"
| Bitbucket -> "bitbucket.org"
| Gitlab -> "gitlab.com"
| Sourcehut -> "sr.ht"
let host_of_repo = function
| Github _ -> "github.com"
| Bitbucket _ -> "bitbucket.org"
| Gitlab _ -> "gitlab.com"
| Sourcehut _ -> "sr.ht"
;;

let base_uri { repo; kind } =
let host = host_of_kind kind in
let base_uri repo =
let host = host_of_repo repo in
match repo with
| User_repo { user; repo } ->
sprintf
"%s/%s/%s"
host
(match kind with
| Sourcehut -> "~" ^ user
| _ -> user)
repo
| Org_repo { org; proj; repo } -> sprintf "%s/%s/%s/%s" host org proj repo
| Gitlab (Org_repo {org; proj; repo}) -> sprintf "%s/%s/%s/%s" host org proj repo
| Sourcehut {user; repo} -> sprintf "%s/~%s/%s" host user repo
| Gitlab (User_repo {user; repo}) | Github {user; repo} | Bitbucket {user; repo} ->
sprintf "%s/%s/%s" host user repo
;;

let add_https s = "https://" ^ s
let homepage t = add_https (base_uri t)

let bug_reports t =
match t.kind with
| Sourcehut -> add_https ("todo." ^ base_uri t)
| _ ->
homepage t
^
(match t.kind with
| Sourcehut -> assert false
| Bitbucket | Github -> "/issues"
| Gitlab -> "/-/issues")
let bug_reports = function
| Gitlab _ as repo -> homepage repo ^ "/-/issues"
| Github _ as repo -> homepage repo ^ "/issues"
| Bitbucket _ as repo -> homepage repo ^ "/issues"
| Sourcehut _ as repo -> add_https ("todo." ^ base_uri repo)
;;

(* todo -- @H-ANSEN
currently each forge in the list is evaluated in order, since 'gitlab'
now has the option to specifiy a organization style repo we need some way
to identify this type and present a error in the case that the dune version
is not supported. Currently no error is thrown *)
let enum k =
[ "GitHub", Github, None
; "Bitbucket", Bitbucket, Some (2, 8)
; "Gitlab", Gitlab, Some (2, 8)
; "Sourcehut", Sourcehut, Some (3, 1)
let stub_user_repo = { user = ""; repo = "" } in
let stub_org_repo = Org_repo { org = ""; proj = ""; repo = "" } in
[ "Github", Github stub_user_repo, None
; "Bitbucket", Bitbucket stub_user_repo, Some (2, 8)
; "Sourcehut", Sourcehut stub_user_repo, Some (3, 1)
; "Gitlab", Gitlab (User_repo stub_user_repo), Some (2, 8)
; "Gitlab", Gitlab stub_org_repo, Some (3, 17)
]
|> List.map ~f:(fun (name, kind, since) ->
let of_string ~loc s =
match String.split ~on:'/' s with
| [ user; repo ] -> k { repo = User_repo { user; repo }; kind }
| [ org; proj; repo ] -> k { repo = Org_repo { org; proj; repo }; kind }
| _ ->
let of_string ~loc str =
match kind, String.split ~on:'/' str with
| Gitlab _, [ user; repo ] -> k @@ Gitlab (User_repo { user; repo })
| Gitlab _, [ org; proj; repo ] -> k @@ Gitlab (Org_repo { org; proj; repo })
| Github _, [ user; repo ] -> k @@ Github { user; repo }
| Bitbucket _, [ user; repo ] -> k @@ Bitbucket { user; repo }
| Sourcehut _, [ user; repo ] -> k @@ Sourcehut { user; repo }
| _, [ _; _; _ ] ->
User_error.raise
~loc
[ Pp.textf "%s repository must be of form user/repo or org/proj/repo" name ]
~hints:
[ Pp.textf
"The provided form 'org/proj/repo' is specific to Gitlab projects"
]
[ Pp.textf "%s repository must be of form user/repo" name ]
| _, _ ->
User_error.raise
~loc
[ Pp.textf "%s repository must be of form user/repo" name ]
in
let decode =
let open Decoder in
Expand All @@ -106,26 +117,28 @@ module Host = struct
| Some v -> Syntax.since Stanza.syntax v)
>>> plain_string of_string
in
let constr = to_string kind in
constr, decode)
kind_string kind, decode)
;;

let encode { repo; kind } =
let forge = to_string kind in
let encode repo =
let path =
match repo with
| User_repo { user; repo } -> sprintf "%s/%s" user repo
| Org_repo { org; proj; repo } -> sprintf "%s/%s/%s" org proj repo
| Gitlab (Org_repo { org; proj; repo }) -> sprintf "%s/%s/%s" org proj repo
| Gitlab (User_repo { user; repo }) -> sprintf "%s/%s" user repo
| Sourcehut { user; repo } -> sprintf "%s/%s" user repo
| Github { user; repo } -> sprintf "%s/%s" user repo
| Bitbucket { user; repo } -> sprintf "%s/%s" user repo
in
let open Encoder in
let forge = kind_string repo in
pair string string (forge, path)
;;

let to_string t =
let to_string repo =
let base_uri =
let base = base_uri t in
match t.kind with
| Sourcehut -> "git." ^ base
let base = base_uri repo in
match repo with
| Sourcehut _ -> "git." ^ base
| _ -> base ^ ".git"
in
"git+https://" ^ base_uri
Expand Down
23 changes: 10 additions & 13 deletions src/dune_lang/source_kind.mli
View file
Original file line number Diff line number Diff line change
@@ -1,25 +1,22 @@
module Host : sig
type kind =
| Github
| Bitbucket
| Gitlab
| Sourcehut
type user_repo =
{ user : string
; repo : string
}

type repo =
| User_repo of
{ user : string
; repo : string
}
type gitlab_repo =
| User_repo of user_repo
| Org_repo of
{ org : string
; proj : string
; repo : string
}

type t =
{ repo : repo
; kind : kind
}
| Github of user_repo
| Bitbucket of user_repo
| Gitlab of gitlab_repo
| Sourcehut of user_repo

val homepage : t -> string
val bug_reports : t -> string
Expand Down

0 comments on commit 17f4de0

Please sign in to comment.