ray/guile-anarres
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement create-merge-request

Browse source
This commit is contained in:
Ray Miller 2025-06-25 19:48:17 +00:00
parent 6c7374d791
commit dfa8c98779
1 changed files with 132 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

138
anarres/gitlab.scm
View file

@ -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)))