Initial commit.
This commit is contained in:
commit
878d52ee27
26 changed files with 3341 additions and 0 deletions
317
ebuild/fetchers/github.scm
Normal file
317
ebuild/fetchers/github.scm
Normal file
|
|
@ -0,0 +1,317 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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)))
|
||||
eos)
|
||||
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))
|
||||
(values extracted-path (basename file-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)))
|
||||
eos)
|
||||
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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue