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

Replace object-oriented impl with struct

Browse source
This commit is contained in:
Ray Miller 2024-05-06 19:51:59 +01:00
parent 8ca2cd0c96
commit 7c36e6f49a
1 changed files with 47 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

78
gitlab.rkt
View file

@ -1,46 +1,60 @@
#lang racket #lang racket
(require net/url) (require net/url
(require (prefix-in http: net/http-easy)) (prefix-in http: net/http-easy)
(require (only-in srfi/1 alist-cons)) (only-in srfi/1 alist-cons))
(provide gitlab-client%) (provide make-client
api-url
get
get-paged
list-descendant-groups
list-group-projects
list-groups)
(struct client (url token))
(define (gitlab-token-auth token) (define (gitlab-token-auth token)
(lambda (uri headers params) (lambda (uri headers params)
(values (hash-set headers 'private-token token) params))) (values (hash-set headers 'private-token token) params)))
(define gitlab-client% (define (make-client #:url (url (string->url "https://gitlab.com")) #:token token)
(class object% (client url token))
(super-new) (define (api-url c path-parts (query-params '()))
(struct-copy url
(client-url c)
(query query-params)
(path (map (lambda (p) (path/param p '())) (append (list "api" "v4") path-parts)))))
(init-field token (define (get c path-parts (query-params '()))
(api-url (string->url "https://gitlab.com"))) (let* ((u (api-url c path-parts query-params))
(res (http:get u #:auth (gitlab-token-auth (client-token c)))))
(define/public (url-for path-parts #:query [query-params '()]) (if (>= (http:response-status-code res) 300)
(struct-copy url api-url (raise-user-error 'gitlab/get (format "GET ~a: ~a" (url->string u) (http:response-status-message res)))
[query query-params]
[path (map (lambda (p) (path/param p '())) (append (list "api" "v4") path-parts))]))
(define/public (get path-parts #:query [query-params '()])
(let* ([u (url-for path-parts #:query query-params)]
[res (http:get u #:auth (gitlab-token-auth token))])
(if (> (http:response-status-code res) 299)
(raise-user-error 'gitlab-client/get (format "GET ~a: ~a" (url->string u) (http:response-status-message res)))
res))) res)))
(define/public (get-paged path-parts #:query [query-params '((per_page . "100"))]) (define (ensure-per-page params page-size)
(define (get-pages response accum) (if (assoc 'per_page params)
(let ([accum (append accum (http:response-json response))] params
[next-page (bytes->string/utf-8 (http:response-headers-ref response 'x-next-page))]) (alist-cons 'per_page page-size params)))
(if (non-empty-string? next-page)
(get-pages (get path-parts #:query (alist-cons 'page next-page query-params)) accum)
accum)))
(get-pages (get path-parts #:query query-params) '()))
(define/public (list-descendant-groups group-id) (define (get-paged c path-parts (query-params '()))
(get-paged (list "groups" group-id "descendant_groups"))) (let ((query-parms (ensure-per-page query-params "100")))
(define (get-pages response accum)
(let ((accum (append accum (http:response-json response)))
(next-page (bytes->string/utf-8 (http:response-headers-ref response 'x-next-page))))
(if (non-empty-string? next-page)
(get-pages (get c path-parts (alist-cons 'page next-page query-params)) accum)
accum)))
(get-pages (get c path-parts query-params) '())))
(define (list-descendant-groups c group-id)
(get-paged c (list "groups" group-id "descendant_groups")))
(define (list-group-projects c group-id)
(get-paged c (list "groups" group-id "projects")))
(define (list-groups c (params '()))
(get-paged c (list "groups") params))
(define/public (list-projects group-id)
(get-paged (list "groups" group-id "projects")))))