(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))))
  (let ((tag (get-tag title))
        (issues (if (null? related-issues)
                    "n/a"
                    (string-join (map (cut format #f "* ~a~%" <>) 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)))