Implement create-merge-request

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