diff --git a/anarres/gitlab.scm b/anarres/gitlab.scm index 06271f7..227bdbe 100644 --- a/anarres/gitlab.scm +++ b/anarres/gitlab.scm @@ -3,10 +3,12 @@ #: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) @@ -21,6 +23,14 @@ 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? @@ -52,6 +62,14 @@ values strings or #f, in which case the parameter is skipped." "" 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) @@ -64,7 +82,7 @@ values strings or #f, in which case the parameter is skipped." (eq? 'application/json (car (response-content-type res)))) (define (json-ok? res) - (and (= 200 (response-code 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)) @@ -75,7 +93,7 @@ values strings or #f, in which case the parameter is skipped." (string-append base-url endpoint)) #:headers `((private-token . ,token) (content-type . (application/json (charset . "utf-8")))) - #:body (if payload (scm->json payload) #f))) + #: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))) @@ -105,18 +123,126 @@ values strings or #f, in which case the parameter is skipped." (define-public (find-group client group-path) (let* ((group-path (strip-leading-slash group-path)) - (groups (api-call client http-get "/groups" #:query `((search . ,group-path)) #:post-proc vector->list)) + (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 (compose (cut assoc-ref <> "id") find-group)) +(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 (api-call client http-get (format #f "/groups/~a/projects" group-id) #:query `((search . ,project-name)) #:post-proc vector->list)) + (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 (compose (cut assoc-ref <> "id") find-project)) +(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)))