315 lines
15 KiB
Scheme
315 lines
15 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; github.scm
|
|
;; Copyright (C) 2025 Cor Legemaat <cor@cor.za.net>
|
|
;;
|
|
;; This file is part of ebuild-autogen: you can redistribute it and/or modify it
|
|
;; under the terms of the GNU Affero General Public License as published by the
|
|
;; Free Software Foundation, version 3 of the License.
|
|
;;
|
|
;; ebuild-autogen is distributed in the hope that it will be useful, but WITHOUT
|
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
|
|
;; more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License along with
|
|
;; ebuild-autogen. If not, see <https://www.gnu.org/licenses/>.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define-module (ebuild fetchers github)
|
|
#:use-module (ebuild defs)
|
|
#:use-module (ebuild fetchers raw)
|
|
#:use-module (ebuild utils)
|
|
#:use-module (curl)
|
|
#:use-module (json)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (oop goops)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-43)
|
|
#:use-module (rx irregex)
|
|
#:use-module (dql dql))
|
|
|
|
(define api-base-url "https://api.github.com/repos/")
|
|
|
|
(define check-github-errors
|
|
(lambda (responce)
|
|
""
|
|
(cond ((string-contains responce "API rate limit exceeded for")
|
|
(error (string-append "error: GitHub API rate limit exceeded, "
|
|
"please setup a token.")))
|
|
((string-contains responce
|
|
(string-append "Request forbidden by administrative"
|
|
" rules. Please make sure your "
|
|
"request has a User-Agent header"))
|
|
(error (string-append "error: GitHub API requires a user agent, "
|
|
"should have been supplied!"))))))
|
|
|
|
(define fetch-github-pages
|
|
(lambda* (url token verbosity #:optional (page 1))
|
|
""
|
|
(let ((curl-handle (curl-easy-init)))
|
|
(curl-easy-setopt curl-handle
|
|
'url
|
|
(string-append url
|
|
"?per_page=100&page="
|
|
(number->string page)))
|
|
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
|
(if (string<> token "")
|
|
(curl-easy-setopt curl-handle
|
|
'httpheader
|
|
(list (string-append "Authorization: token "
|
|
token))))
|
|
(let* ((responce (curl-easy-perform curl-handle)))
|
|
(if (>= verbosity verbosity-debug)
|
|
(begin (display "json = ") (display responce) (newline)))
|
|
(if responce
|
|
(begin (check-github-errors responce)
|
|
(let ((scm-responce (json-string->scm responce)))
|
|
(if (< 100 (vector-length scm-responce))
|
|
(vector-append (fetch-github-pages url
|
|
verbosity
|
|
(+1 page)))
|
|
(begin (if (>= verbosity verbosity-info)
|
|
(pretty-print scm-responce))
|
|
scm-responce))))
|
|
(error (string-append "GitHub fetch failed with error "
|
|
(curl-error-string)
|
|
"\n")))))))
|
|
|
|
(define get-releases
|
|
(lambda (user repo token version-filter verbosity)
|
|
""
|
|
((dql (select (filter (where version-filter
|
|
"tag_name"))
|
|
(parm-as "version" "tag_name")
|
|
(parm-as "date" "created_at")))
|
|
(fetch-github-pages (string-append api-base-url
|
|
user
|
|
"/"
|
|
repo
|
|
"/releases")
|
|
token
|
|
verbosity))))
|
|
|
|
(define get-tags
|
|
(lambda (user repo token version-filter verbosity)
|
|
""
|
|
((dql (select (filter (where version-filter
|
|
"name"))
|
|
(parm-as "version" "name")
|
|
(parm "commit" "sha")))
|
|
(fetch-github-pages (string-append api-base-url
|
|
user
|
|
"/"
|
|
repo
|
|
"/tags")
|
|
token
|
|
verbosity))))
|
|
|
|
(define get-rel-assets
|
|
(lambda (user repo token name-prefix version-alter releases)
|
|
""
|
|
;; (display "for-releases:") (newline)
|
|
;; (pretty-print releases)
|
|
(map (lambda (release)
|
|
;; (display "for-release:") (newline)
|
|
;; (pretty-print release)
|
|
(let* ((version (assoc-ref release "version"))
|
|
(version-final (version-alter version))
|
|
(curl-handle (curl-easy-init))
|
|
(base-asset-url (string-append "https://github.com/"
|
|
user
|
|
"/"
|
|
repo))
|
|
(sha "")
|
|
(sha7 "")
|
|
(json "")
|
|
(scm ""))
|
|
(curl-easy-setopt curl-handle
|
|
'url
|
|
(string-append api-base-url
|
|
user
|
|
"/"
|
|
repo
|
|
"/git/refs/tags/"
|
|
version))
|
|
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
|
(if (string<> token "")
|
|
(curl-easy-setopt curl-handle
|
|
'httpheader
|
|
(list (string-append "Authorization: token "
|
|
token))))
|
|
;;(curl-easy-setopt curl-handle 'max-time 120)
|
|
;;(curl-easy-setopt curl-handle 'connect-timeout 30)
|
|
(set! json (curl-easy-perform curl-handle))
|
|
;; (display "json=") (display json) (newline)
|
|
(if (not json)
|
|
(error (string-append "GitHub release asset fetch "
|
|
"failed with error "
|
|
(curl-error-string)
|
|
"\n")))
|
|
(check-github-errors json)
|
|
(set! scm (json-string->scm json))
|
|
(display "scm:") (newline) (pretty-print scm)
|
|
(set! sha (assoc-ref (car ((dql (select (parm "object" "sha")))
|
|
(list scm)))
|
|
"sha"))
|
|
(display "sha=") (display sha) (newline)
|
|
(set! sha7 (string-take sha 7))
|
|
(assoc-set! release "version" version-final)
|
|
(append release
|
|
(list (cons "sha" sha))
|
|
(list (cons "github-user" user))
|
|
(list (cons "github-repo" repo))
|
|
(list (cons "sha7" sha7))
|
|
;;TODO append this with list of custom assets.
|
|
(list
|
|
(list "assets"
|
|
(list (cons "uri" (string-append base-asset-url
|
|
"/tarball/"
|
|
sha7))
|
|
(cons "name" (string-append name-prefix
|
|
"-"
|
|
version-final
|
|
"-"
|
|
sha7
|
|
".tar.gz"))
|
|
(cons "type" "tar.gz"))
|
|
(list (cons "uri" (string-append base-asset-url
|
|
"/zipball/"
|
|
sha7))
|
|
(cons "name" (string-append name-prefix
|
|
"-"
|
|
version-final
|
|
"-"
|
|
sha7
|
|
".zip"))
|
|
(cons "type" "zip")))))))
|
|
releases)))
|
|
|
|
(define get-tag-assets
|
|
(lambda (user repo name-prefix version-alter tags)
|
|
;; (display "tags = ")
|
|
;; (pretty-print tags)
|
|
(map (lambda (tag)
|
|
(let* ((sha (assoc-ref tag "sha"))
|
|
(sha7 (string-take sha 7))
|
|
(version (assoc-ref tag "version"))
|
|
(version-final (version-alter version))
|
|
(base-asset-url (string-append "https://github.com/"
|
|
user
|
|
"/"
|
|
repo)))
|
|
(assoc-set! tag "version" version-final)
|
|
(append tag
|
|
(list (cons "github-user" user))
|
|
(list (cons "github-repo" repo))
|
|
(list (cons "sha7" sha7))
|
|
(list
|
|
(list "assets"
|
|
(list (cons "uri" (string-append base-asset-url
|
|
"/tarball/"
|
|
sha7))
|
|
(cons "name" (string-append name-prefix
|
|
"-"
|
|
version-final
|
|
"-"
|
|
sha7
|
|
".tar.gz"))
|
|
(cons "type" "tar.gz"))
|
|
(list (cons "uri" (string-append base-asset-url
|
|
"/zipball/"
|
|
sha7))
|
|
(cons "name" (string-append name-prefix
|
|
"-"
|
|
version-final
|
|
"-"
|
|
sha7
|
|
".zip"))
|
|
(cons "type" "zip")))))))
|
|
tags)))
|
|
|
|
(define-public fetch-github
|
|
(lambda* (user repo token querry verbosity #:key
|
|
(version-filter (lambda (version)
|
|
(irregex-search
|
|
'(seq bos
|
|
(+ num)
|
|
(* (seq "." (+ num))))
|
|
version)))
|
|
(version-alter (lambda (version)
|
|
(let ((my-match (irregex-search
|
|
'(seq (+ num)
|
|
(* (seq "." (+ num))))
|
|
version)))
|
|
(if my-match
|
|
(irregex-match-substring my-match)
|
|
#f))))
|
|
(file-prefix repo))
|
|
""
|
|
(display "Fetching ")
|
|
(display repo)
|
|
(display " from ")
|
|
(display user)
|
|
(display " at github.")
|
|
(newline)
|
|
(letrec* ((releases
|
|
(case querry
|
|
((releases) (get-releases user
|
|
repo
|
|
token
|
|
version-filter
|
|
verbosity))
|
|
((tags) (get-tags user repo token version-filter verbosity))
|
|
(else (error (string-append "Error github can only "
|
|
"querry tags or releases.")))))
|
|
(assets (case querry
|
|
((releases) (get-rel-assets user repo token
|
|
file-prefix version-alter
|
|
releases))
|
|
((tags) (get-tag-assets user repo
|
|
file-prefix version-alter
|
|
releases))
|
|
(else '()))))
|
|
assets)))
|
|
|
|
(define-public extract-github-release
|
|
(lambda (release)
|
|
(let* ((sha7 (assoc-ref release "sha7"))
|
|
(extracted-path (string-append (assoc-ref release 'tmp-path)
|
|
"/"
|
|
(assoc-ref release "github-user")
|
|
"-"
|
|
(assoc-ref release "github-repo")
|
|
"-" sha7))
|
|
(file-path (fetch-raw-release release "tar.gz")))
|
|
(if (access? extracted-path F_OK)
|
|
(system* "/bin/rm" "-r" extracted-path))
|
|
(mkpath (assoc-ref release 'tmp-path))
|
|
(system* "/bin/tar"
|
|
"-xf" file-path "--directory"
|
|
(assoc-ref release 'tmp-path))
|
|
extracted-path)))
|
|
|
|
(define-public fetch-github-prefixed
|
|
(lambda* (user repo token querry verbosity prefix #:key
|
|
(file-prefix repo)
|
|
(display-data #f))
|
|
""
|
|
(fetch-github user repo token querry verbosity
|
|
#:version-filter
|
|
(lambda (version)
|
|
(irregex-search
|
|
`(seq ,prefix
|
|
(+ num)
|
|
(* (seq "." (+ num))))
|
|
version))
|
|
#:version-alter
|
|
(lambda (version)
|
|
(let ((my-match (irregex-search
|
|
`(seq (look-behind ,prefix)
|
|
(+ num)
|
|
(* (seq "." (+ num))))
|
|
version)))
|
|
(if my-match
|
|
(irregex-match-substring my-match)
|
|
#f)))
|
|
#:file-prefix file-prefix)))
|