(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 (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #: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-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 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))
       (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 (if payload (scm->json payload) #f)))
         (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 (alist-cons 'page next-page query-params) #: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 (api-call client http-get "/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 (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))
         (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))