251 lines
10 KiB
Scheme
251 lines
10 KiB
Scheme
(define-module (anarres gitlab)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (ice-9 exceptions)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 optargs)
|
|
#:use-module (ice-9 string-fun)
|
|
#:use-module (json)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (srfi srfi-69)
|
|
#:use-module (srfi srfi-71)
|
|
#:use-module (web client)
|
|
#:use-module (web response)
|
|
#:use-module (web uri)
|
|
#:export (api-error?
|
|
api-error-endpoint
|
|
api-error-status-code
|
|
|
|
gitlab-client?
|
|
gitlab-client-base-url
|
|
set-gitlab-client-base-url!
|
|
gitlab-client-token
|
|
set-gitlab-client-token!))
|
|
|
|
(define-syntax ->
|
|
(syntax-rules ()
|
|
((_ a) a)
|
|
((_ a (b c ...)) (b a c ...))
|
|
((_ a b) (b a))
|
|
((_ a b c) (-> (-> a b) c))
|
|
((_ a b ... c) (-> (-> a b ...) c))))
|
|
|
|
(define-exception-type &api-error &external-error
|
|
make-api-error
|
|
api-error?
|
|
(endpoint api-error-endpoint)
|
|
(status-code api-error-status-code)
|
|
(body api-error-body))
|
|
|
|
(define-record-type <gitlab>
|
|
(make-gitlab-client base-url token)
|
|
gitlab-client?
|
|
(base-url gitlab-client-base-url set-gitlab-client-base-url!)
|
|
(token gitlab-client-token set-gitlab-client-token!))
|
|
|
|
(define*-public (gitlab-client #:key (base-url "https://gitlab.com/api/v4") (token (getenv "GITLAB_TOKEN")))
|
|
(make-gitlab-client base-url (string-trim-both token)))
|
|
|
|
(define (encode-query alist)
|
|
"Encode an association list as a query string. The keys should be symbols and the
|
|
values strings or #f, in which case the parameter is skipped."
|
|
(fold (match-lambda*
|
|
(((k . v) s)
|
|
(if v
|
|
(string-append s
|
|
(if (zero? (string-length s)) "" "&")
|
|
(if (symbol? k) (symbol->string k) k)
|
|
"="
|
|
(uri-encode v))
|
|
s)))
|
|
""
|
|
alist))
|
|
|
|
(define (memoize-client-call proc)
|
|
(let ((memo (make-hash-table equal?)))
|
|
(lambda (client . args)
|
|
(unless (hash-table-exists? memo args)
|
|
(let ((v (apply proc client args)))
|
|
(hash-table-set! memo args v)))
|
|
(hash-table-ref memo args))))
|
|
|
|
(define forward-slash (char-set #\/))
|
|
|
|
(define (strip-leading-slash s)
|
|
(string-trim s forward-slash))
|
|
|
|
(define (strip-trailing-slash s)
|
|
(string-trim-right s forward-slash))
|
|
|
|
(define (json-response? res)
|
|
(eq? 'application/json (car (response-content-type res))))
|
|
|
|
(define (json-ok? res)
|
|
(and (<= 200 (response-code res) 299)
|
|
(json-response? res)))
|
|
|
|
(define* (api-call client method endpoint #:key query payload return-headers? (ok? json-ok?) (post-proc identity))
|
|
(let* ((base-url (gitlab-client-base-url client))
|
|
(token (gitlab-client-token client))
|
|
(res body (method (if query
|
|
(string-append base-url endpoint "?" (encode-query query))
|
|
(string-append base-url endpoint))
|
|
#:headers `((private-token . ,token)
|
|
(content-type . (application/json (charset . "utf-8"))))
|
|
#:body (and=> payload scm->json-string)))
|
|
(body (if (json-response? res) (call-with-input-bytevector body json->scm) body)))
|
|
(if (ok? res)
|
|
(let ((body (post-proc body)))
|
|
(if return-headers?
|
|
(values body (response-headers res))
|
|
body))
|
|
(raise-exception (make-api-error endpoint (response-code res) body)))))
|
|
|
|
(define (ensure-per-page params page-size)
|
|
(if (assoc 'per_page params)
|
|
params
|
|
(alist-cons 'per_page page-size params)))
|
|
|
|
(define* (get-paged client endpoint #:key (query '()) (post-proc identity))
|
|
(let ((query-params (ensure-per-page query "100")))
|
|
(define (get-pages accum next-page)
|
|
(let* ((body headers (api-call client http-get endpoint
|
|
#:query (assoc-set! query-params 'page next-page)
|
|
#:post-proc post-proc
|
|
#:return-headers? #t))
|
|
(accum (append accum body))
|
|
(next-page (assoc-ref headers 'x-next-page)))
|
|
(if (and (string? next-page) (> (string-length next-page) 0))
|
|
(get-pages accum next-page)
|
|
accum)))
|
|
(get-pages '() #f)))
|
|
|
|
(define-public (list-merge-requests client params)
|
|
(get-paged client "/merge_requests" #:query params #:post-proc vector->list))
|
|
|
|
(define-public (find-group client group-path)
|
|
(let* ((group-path (strip-leading-slash group-path))
|
|
(groups (get-paged client "/groups" #:query `((search . ,group-path)) #:post-proc vector->list))
|
|
(group (find (lambda (g) (string=? (assoc-ref g "full_path") group-path)) groups)))
|
|
(or group (error (format #f "find-group: group ~a not found" group-path)))))
|
|
|
|
(define-public get-group-id (memoize-client-call (compose (cut assoc-ref <> "id") find-group)))
|
|
|
|
(define-public (find-project client project-path)
|
|
(let* ((project-path (strip-leading-slash project-path))
|
|
(group-id (get-group-id client (dirname project-path)))
|
|
(project-name (basename project-path))
|
|
(projects (get-paged client (format #f "/groups/~a/projects" group-id) #:query `((search . ,project-name)) #:post-proc vector->list))
|
|
(project (find (lambda (p) (string=? (assoc-ref p "path_with_namespace") project-path)) projects)))
|
|
(or project (error (format #f "find-project: project ~a not found" project-path)))))
|
|
|
|
(define-public get-project-id (memoize-client-call (compose (cut assoc-ref <> "id") find-project)))
|
|
|
|
(define-public (find-user client username)
|
|
(let ((users (get-paged client "/users" #:query `((username . ,username)) #:post-proc vector->list)))
|
|
(or (find (lambda (u) (string=? (assoc-ref u "username") username)) users)
|
|
(error (format #f "find-user: username ~a not found" username)))))
|
|
|
|
(define-public get-user-id (memoize-client-call (compose (cut assoc-ref <> "id") find-user)))
|
|
|
|
(define merge-request-template "\
|
|
## Change description
|
|
|
|
@@title@@
|
|
|
|
@@description@@
|
|
|
|
## Type of change
|
|
|
|
- [@@fix@@] Fix (a bug fix)
|
|
- [@@update@@] Update (a backwards-compatible enhancement)
|
|
- [@@new@@] New (implemented a new feature)
|
|
- [@@breaking@@] Breaking (a backwards-incompatible enhancement or feature)
|
|
- [@@docs@@] Docs (changes to documentation only)
|
|
- [@@build@@] Build (changes to build process only
|
|
- [@@upgrade@@] Upgrade (a dependency upgrade)
|
|
- [@@chore@@] Chore (refactoring, adding tests, etc. - anything that isn't user-facing)
|
|
|
|
## Related issues
|
|
|
|
@@issues@@
|
|
|
|
## Checklists
|
|
|
|
### Development
|
|
|
|
- [ ] Lint rules pass locally
|
|
- [ ] Application changes have been tested thoroughly
|
|
- [ ] Automated tests covering modified code pass
|
|
|
|
### Security
|
|
|
|
- [ ] Security impact of change has been considered
|
|
- [ ] Code follows company security practices and guidelines
|
|
|
|
### Network
|
|
|
|
- [ ] Changes to network configurations have been reviewed
|
|
- [ ] Any newly exposed public endpoints or data have gone through security review
|
|
|
|
### Code review
|
|
|
|
- [ ] Pull request has a descriptive title and context useful to a reviewer. Screenshots or screencasts are attached as necessary
|
|
- [ ] *Ready for review* label attached and reviewers assigned
|
|
- [ ] Changes have been reviewed by at least one other contributor
|
|
- [ ] Pull request linked to task tracker where applicable
|
|
")
|
|
|
|
(define* (build-merge-request-description #:key title (description "") (related-issues '()))
|
|
(define (get-tag s)
|
|
(let ((i (string-index s #\:)))
|
|
(and i (substring s 0 i))))
|
|
(define (format-issue x)
|
|
(format #f "* ~a [~a](~a)~%"
|
|
(assoc-ref x 'type)
|
|
(assoc-ref x 'name)
|
|
(assoc-ref x 'url)))
|
|
(let ((tag (get-tag title))
|
|
(issues (if (null? related-issues)
|
|
"n/a"
|
|
(string-join (map format-issue related-issues) "\n")))
|
|
(s merge-request-template))
|
|
(define (tag-selected x) (if (string=? x tag) "X" " "))
|
|
(-> s
|
|
(string-replace-substring "@@title@@" title)
|
|
(string-replace-substring "@@description@@\n" description)
|
|
(string-replace-substring "@@fix@@" (tag-selected "Fix"))
|
|
(string-replace-substring "@@update@@" (tag-selected "Update"))
|
|
(string-replace-substring "@@new@@" (tag-selected "New"))
|
|
(string-replace-substring "@@breaking@@" (tag-selected "Breaking"))
|
|
(string-replace-substring "@@docs@@" (tag-selected "Docs"))
|
|
(string-replace-substring "@@build@@" (tag-selected "Build"))
|
|
(string-replace-substring "@@upgrade@@" (tag-selected "Upgrade"))
|
|
(string-replace-substring "@@chore@@" (tag-selected "Chore"))
|
|
(string-replace-substring "@@issues@@" issues))))
|
|
|
|
(define*-public (create-merge-request client
|
|
#:key project-path
|
|
source-branch
|
|
target-branch
|
|
title
|
|
(description "")
|
|
(related-issues '())
|
|
assignee
|
|
reviewers
|
|
(remove-source-branch #t)
|
|
(squash #t))
|
|
(let* ((project-id (get-project-id client project-path))
|
|
(assignee-id (and=> assignee (cut get-user-id client <>)))
|
|
(reviewer-ids (map (cut get-user-id client <>) reviewers))
|
|
(payload `((source_branch . ,source-branch)
|
|
(target_branch . ,target-branch)
|
|
(title . ,title)
|
|
(assignee_id . ,assignee-id)
|
|
(reviewer_ids . ,(list->vector reviewer-ids))
|
|
(description . ,(build-merge-request-description #:title title #:description description #:related-issues related-issues))
|
|
(remove_source_branch . ,remove-source-branch)
|
|
(squash . ,squash))))
|
|
(api-call client http-post (format #f "/projects/~a/merge_requests" project-id)
|
|
#:payload payload)))
|