Initial commit.
This commit is contained in:
commit
878d52ee27
26 changed files with 3341 additions and 0 deletions
48
ebuild/fetchers/Makefile.am
Normal file
48
ebuild/fetchers/Makefile.am
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
################################################################################
|
||||
# Makefile.am
|
||||
# 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/>.
|
||||
################################################################################
|
||||
|
||||
moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/ebuild/fetchers
|
||||
objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/ebuild/fetchers
|
||||
|
||||
SOURCES = \
|
||||
ebuild.scm \
|
||||
forgejo.scm \
|
||||
github.scm \
|
||||
pypi.scm \
|
||||
raw.scm
|
||||
|
||||
GOBJECTS = $(SOURCES:%.scm=%.go)
|
||||
|
||||
nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
|
||||
nobase_obj_DATA = $(GOBJECTS)
|
||||
|
||||
# Make sure source files are installed first, so that the mtime of
|
||||
# installed compiled files is greater than that of installed source
|
||||
# files. See
|
||||
# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
|
||||
# for details.
|
||||
guile_install_obj_files = install-nobase_obj_DATA
|
||||
$(guile_install_obj_files): install-nobase_mod_DATA
|
||||
|
||||
EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
|
||||
|
||||
CLEANFILES = $(GOBJECTS)
|
||||
|
||||
GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
|
||||
GUILE_OPTS = -L $(abs_top_builddir)
|
||||
SUFFIXES = .scm .go
|
||||
.scm.go:
|
||||
$(GUILD) compile $(GUILE_TARGET) $(GUILE_OPTS) $(GUILE_WARNINGS) -o "$@" "$<"
|
||||
66
ebuild/fetchers/ebuild.scm
Normal file
66
ebuild/fetchers/ebuild.scm
Normal file
|
|
@ -0,0 +1,66 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ebuild.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 ebuild)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (oop goops)
|
||||
#:use-module (rx irregex))
|
||||
|
||||
(define-public fetch-ebuilds
|
||||
(lambda* (repo category package #:key
|
||||
(version-filter (lambda (version) version))
|
||||
(version-alter (lambda (version) version))
|
||||
. extract-vars)
|
||||
""
|
||||
(let ((dir (opendir (string-append repo "/" category "/" package)))
|
||||
(releases '()))
|
||||
(do ((entry (readdir dir) (readdir dir)))
|
||||
((eof-object? entry))
|
||||
(let* ((ebuild-file (open-input-file (string-append repo "/"
|
||||
category "/"
|
||||
package "/"
|
||||
entry)))
|
||||
(version-match (irregex-search
|
||||
`(seq (look-behind ,(string-append package "-"))
|
||||
(+ (or alphanumeric "." "-"))
|
||||
(look-ahead ".ebuild"))
|
||||
entry))
|
||||
(ebuild-data (if version-match
|
||||
(get-string-all ebuild-file)
|
||||
#f))
|
||||
(release '()))
|
||||
;; Get the keywords.
|
||||
(if version-match
|
||||
(begin (set! release
|
||||
(list (cons "version"
|
||||
(irregex-match-substring version-match))))
|
||||
(map (lambda (var)
|
||||
(let* ((var-match
|
||||
(irregex-search
|
||||
`(seq (look-behind ,(string-append var "=\""))
|
||||
(+ (& (or printing num) (~ "\"")))
|
||||
(look-ahead "\""))
|
||||
ebuild-data)))
|
||||
(if var-match
|
||||
(append! release
|
||||
(list (cons var
|
||||
(irregex-match-substring
|
||||
var-match)))))))
|
||||
extract-vars)
|
||||
(set! releases (append releases (list release)))))
|
||||
(close ebuild-file)))
|
||||
(closedir dir)
|
||||
releases)))
|
||||
299
ebuild/fetchers/forgejo.scm
Normal file
299
ebuild/fetchers/forgejo.scm
Normal file
|
|
@ -0,0 +1,299 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; forgejo.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 forgejo)
|
||||
#: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 "/api/v1/repos/")
|
||||
|
||||
(define check-forgejo-errors
|
||||
(lambda (responce)
|
||||
""
|
||||
;; TODO
|
||||
'()))
|
||||
|
||||
(define fetch-forgejo-pages
|
||||
(lambda* (url auth-token verbosity #:optional (page 1))
|
||||
""
|
||||
(let ((curl-handle (curl-easy-init)))
|
||||
(if (>= verbosity verbosity-info)
|
||||
(begin (display "src-url: ") (display url) (newline)))
|
||||
(curl-easy-setopt curl-handle
|
||||
'url
|
||||
(string-append url
|
||||
"?limit=100&page="
|
||||
(number->string page)))
|
||||
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
||||
(if (string<> auth-token "")
|
||||
(curl-easy-setopt curl-handle
|
||||
'httpheader
|
||||
(list (string-append "Authorization: token "
|
||||
auth-token))))
|
||||
(let* ((responce (curl-easy-perform curl-handle)))
|
||||
(if (>= verbosity verbosity-debug)
|
||||
(begin (display "json = ") (display responce) (newline)))
|
||||
(if responce
|
||||
(begin (check-forgejo-errors responce)
|
||||
(let ((scm-responce (json-string->scm responce)))
|
||||
(if (< 100 (vector-length scm-responce))
|
||||
(vector-append (fetch-forgejo-pages url
|
||||
auth-token
|
||||
verbosity
|
||||
(+1 page)))
|
||||
(begin (if (>= verbosity verbosity-info)
|
||||
(pretty-print scm-responce))
|
||||
scm-responce))))
|
||||
(error (string-append "Forgejo fetch failed with error "
|
||||
(curl-error-string)
|
||||
"\n")))))))
|
||||
|
||||
(define get-releases
|
||||
(lambda (host user repo auth-token version-filter verbosity)
|
||||
""
|
||||
((dql (select (filter (where version-filter
|
||||
"tag_name"))
|
||||
(parm-as "version" "tag_name")
|
||||
(parm-as "date" "created_at")))
|
||||
(fetch-forgejo-pages (string-append host
|
||||
api-base-url
|
||||
user
|
||||
"/"
|
||||
repo
|
||||
"/releases")
|
||||
auth-token
|
||||
verbosity))))
|
||||
|
||||
(define get-tags
|
||||
(lambda (host user repo auth-token version-filter verbosity)
|
||||
""
|
||||
((dql (select (filter (where version-filter
|
||||
"name"))
|
||||
(parm-as "version" "name")
|
||||
(parm "commit" "sha")))
|
||||
(fetch-forgejo-pages (string-append host
|
||||
api-base-url
|
||||
user
|
||||
"/"
|
||||
repo
|
||||
"/tags")
|
||||
auth-token
|
||||
verbosity))))
|
||||
|
||||
(define get-rel-assets
|
||||
(lambda (host user repo auth-token name-prefix version-alter releases)
|
||||
"TODO Won't work!!!"
|
||||
;; (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))
|
||||
(base-asset-url (string-append host "/" user "/" repo))
|
||||
(curl-handle (curl-easy-init))
|
||||
(json "")
|
||||
(scm ""))
|
||||
(curl-easy-setopt curl-handle
|
||||
'url
|
||||
(string-append host api-base-url
|
||||
user
|
||||
"/"
|
||||
repo
|
||||
"/releases/"
|
||||
version))
|
||||
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
||||
(if (string<> auth-token "")
|
||||
(curl-easy-setopt curl-handle
|
||||
'httpheader
|
||||
(list (string-append "Authorization: token "
|
||||
auth-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-forgejo-errors json)
|
||||
(set! scm (json-string->scm json))
|
||||
(assoc-set! release "version" version-final)
|
||||
(append release
|
||||
(list (cons "repo-user" user))
|
||||
(list (cons "repo-repo" repo))
|
||||
;;TODO append this with list of custom assets.
|
||||
(list
|
||||
(list "assets"
|
||||
(list (cons "uri" (string-append base-asset-url
|
||||
"/archive/"
|
||||
version
|
||||
".tar.gz"))
|
||||
(cons "name" (string-append name-prefix
|
||||
"-"
|
||||
version-final
|
||||
".tar.gz"))
|
||||
(cons "type" "tar.gz"))
|
||||
(list (cons "uri" (string-append base-asset-url
|
||||
"/archive/"
|
||||
version
|
||||
".tar.gz"))
|
||||
(cons "name" (string-append name-prefix
|
||||
"-"
|
||||
version-final
|
||||
".zip"))
|
||||
(cons "type" "zip")))))))
|
||||
releases)))
|
||||
|
||||
(define get-tag-assets
|
||||
(lambda (host user repo name-prefix version-alter tags)
|
||||
;; (display "tags = ")
|
||||
;; (pretty-print tags)
|
||||
(map (lambda (tag)
|
||||
(let* ((version-final (version-alter (assoc-ref tag "version")))
|
||||
(version-name (assoc-ref tag "version"))
|
||||
(base-asset-url (string-append host "/" user "/" repo)))
|
||||
(assoc-set! tag "version" version-final)
|
||||
(append tag
|
||||
(list (cons "repo-user" user))
|
||||
(list (cons "repo-name" repo))
|
||||
(list
|
||||
(list "assets"
|
||||
(list (cons "uri" (string-append base-asset-url
|
||||
"/archive/"
|
||||
version-name
|
||||
".tar.gz"))
|
||||
(cons "name" (string-append name-prefix
|
||||
"-"
|
||||
version-final
|
||||
".tar.gz"))
|
||||
(cons "type" "tar.gz"))
|
||||
(list (cons "uri" (string-append base-asset-url
|
||||
"/archive/"
|
||||
version-name
|
||||
".tar.gz"))
|
||||
(cons "name" (string-append name-prefix
|
||||
"-"
|
||||
version-final
|
||||
".zip"))
|
||||
(cons "type" "zip")))))))
|
||||
tags)))
|
||||
|
||||
(define-public fetch-forgejo
|
||||
(lambda* (host user repo querry verbosity #:key
|
||||
(auth-token "")
|
||||
(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 forgejo repo ")
|
||||
(display repo)
|
||||
(display " from ")
|
||||
(display user)
|
||||
(display " at ")
|
||||
(display host)
|
||||
(newline)
|
||||
(letrec* ((releases
|
||||
(case querry
|
||||
((releases) (get-releases host
|
||||
user
|
||||
repo
|
||||
auth-token
|
||||
version-filter
|
||||
verbosity))
|
||||
((tags) (get-tags host
|
||||
user
|
||||
repo
|
||||
auth-token
|
||||
version-filter
|
||||
verbosity))
|
||||
(else (error (string-append "Error github can only "
|
||||
"querry tags or releases.")))))
|
||||
(assets (case querry
|
||||
((releases) (get-rel-assets host user repo auth-token
|
||||
file-prefix version-alter
|
||||
releases))
|
||||
((tags) (get-tag-assets host user repo
|
||||
file-prefix version-alter
|
||||
releases))
|
||||
(else '()))))
|
||||
assets)))
|
||||
|
||||
(define-public extract-forgejo-release
|
||||
(lambda (release tmp-path)
|
||||
(let* ((sha7 (assoc-ref release "sha7"))
|
||||
(extracted-path (string-append 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 tmp-path)
|
||||
(system* "/bin/tar"
|
||||
"-xf" file-path "--directory"
|
||||
tmp-path)
|
||||
extracted-path)))
|
||||
|
||||
(define-public fetch-forgejo-prefixed
|
||||
(lambda* (host user repo querry verbosity prefix #:key
|
||||
(auth-token "")
|
||||
(file-prefix repo))
|
||||
""
|
||||
(fetch-forgejo host user repo querry verbosity
|
||||
#:auth-token auth-token
|
||||
#: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)))
|
||||
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)))
|
||||
91
ebuild/fetchers/pypi.scm
Normal file
91
ebuild/fetchers/pypi.scm
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; pypi.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 pypi)
|
||||
#: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 fetch-pypi-pkg
|
||||
(lambda (pkg display-data)
|
||||
""
|
||||
(let ((curl-handle (curl-easy-init)))
|
||||
(curl-easy-setopt curl-handle
|
||||
'url
|
||||
(string-append "https://pypi.org/simple/"
|
||||
pkg
|
||||
"/"))
|
||||
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
||||
(curl-easy-setopt curl-handle
|
||||
'httpheader
|
||||
(list (string-append "Accept: "
|
||||
"application/vnd.pypi.simple.v1+json")))
|
||||
(let* ((responce (curl-easy-perform curl-handle)))
|
||||
;;(display "json = ") (display responce) (newline)
|
||||
(if responce
|
||||
(let ((scm-responce (json-string->scm responce)))
|
||||
(begin (if display-data
|
||||
(pretty-print scm-responce))
|
||||
scm-responce))
|
||||
(error (string-append "PyPI fetch failed with error "
|
||||
(curl-error-string)
|
||||
"\n")))))))
|
||||
|
||||
(define-public fetch-pypi
|
||||
(lambda* (pkg #:key (file-types (list "tar.gz")) (display-data #f))
|
||||
""
|
||||
(let* ((data (fetch-pypi-pkg pkg display-data))
|
||||
(versions (vector->list (assoc-ref data "versions")))
|
||||
(files (assoc-ref data "files")))
|
||||
(map (lambda (version)
|
||||
(list (cons "version" version)
|
||||
(car (car ((dql (select (filter (where (lambda (file-name)
|
||||
(if (string? file-name)
|
||||
(string-contains file-name
|
||||
(string-append "-"
|
||||
version
|
||||
"."
|
||||
(car file-types)))
|
||||
#f))
|
||||
"filename"))
|
||||
(parm-as "date" "upload-time")))
|
||||
files)))
|
||||
(cons "assets"
|
||||
(map (lambda (type)
|
||||
(append (car ((dql (select (filter (where (lambda (file-name)
|
||||
(if (string? file-name)
|
||||
(string-contains file-name
|
||||
(string-append "-"
|
||||
version
|
||||
"."
|
||||
type))
|
||||
#f))
|
||||
"filename"))
|
||||
(parm-as "uri" "url")
|
||||
(parm-as "name" "filename")
|
||||
(parm "hashes" "sha256")))
|
||||
files))
|
||||
(list (cons "type" type))))
|
||||
file-types))))
|
||||
versions))))
|
||||
122
ebuild/fetchers/raw.scm
Normal file
122
ebuild/fetchers/raw.scm
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; raw.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 raw)
|
||||
#:use-module (ebuild defs)
|
||||
#:use-module (ebuild utils)
|
||||
#:use-module (curl)
|
||||
#:use-module (rx irregex)
|
||||
#:use-module (ice-9 pretty-print)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 string-fun)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (dql dql))
|
||||
|
||||
(define-public fetch-raw
|
||||
(lambda* (url extract-file extract-version asset-types #:key
|
||||
(uri-prefix "")
|
||||
(version-filter (lambda (version) #t))
|
||||
(version-alter (lambda (version) version)))
|
||||
"extract-file should extract the file name till the dot before the type."
|
||||
(let ((curl-handle (curl-easy-init)))
|
||||
(curl-easy-setopt curl-handle 'url url)
|
||||
(curl-easy-setopt curl-handle 'useragent curl-useragent)
|
||||
(let ((responce (curl-easy-perform curl-handle)))
|
||||
(let ((releases (extract-file responce)))
|
||||
(filter-map
|
||||
(lambda (release)
|
||||
(let ((version (version-alter (extract-version release))))
|
||||
(if (version-filter version)
|
||||
(list (cons "version" version)
|
||||
(cons "assets"
|
||||
(map
|
||||
(lambda (type)
|
||||
(list
|
||||
(cons "uri"
|
||||
(string-append
|
||||
(if (string=? uri-prefix "")
|
||||
(if (string-match
|
||||
"^(http://|https://|ftp://)"
|
||||
release)
|
||||
"" url)
|
||||
uri-prefix)
|
||||
release type))
|
||||
(cons "name" (string-append release type))
|
||||
(cons "type" type)))
|
||||
asset-types)))
|
||||
#f)))
|
||||
releases))))))
|
||||
|
||||
(define-public fetch-raw-html
|
||||
(lambda* (url file-prefix
|
||||
asset-types #:key
|
||||
(uri-prefix "")
|
||||
(version-filter (lambda (version) #t))
|
||||
(version-alter (lambda (version) version))
|
||||
(extract-version
|
||||
(lambda (file)
|
||||
(let ((my-match (irregex-search `(seq (+ num) "."
|
||||
(+ num) "."
|
||||
(+ num))
|
||||
file)))
|
||||
(if my-match
|
||||
(irregex-match-substring my-match)))))
|
||||
(file-postfix (car asset-types)))
|
||||
""
|
||||
(fetch-raw url
|
||||
(lambda (responce)
|
||||
;; Break up in lines, otherwise rx extremely expensive.
|
||||
(filter-map
|
||||
(lambda (line)
|
||||
(let ((rx-match
|
||||
(irregex-search
|
||||
`(seq (look-behind "<a href=\"")
|
||||
,file-prefix
|
||||
(seq (+ num) "." (+ num) "." (+ num))
|
||||
"."
|
||||
(look-ahead ,(string-append file-postfix
|
||||
"\">")))
|
||||
line)))
|
||||
(if rx-match
|
||||
(irregex-match-substring rx-match)
|
||||
#f)))
|
||||
(string-split responce #\newline)))
|
||||
extract-version
|
||||
asset-types
|
||||
#:uri-prefix uri-prefix
|
||||
#:version-filter version-filter
|
||||
#:version-alter version-alter)))
|
||||
|
||||
(define-public fetch-raw-release
|
||||
(lambda (release type)
|
||||
""
|
||||
(let* ((my-file-data
|
||||
(car ((dql (select (filter (select (parm-val "assets"))
|
||||
(where (lambda (x)
|
||||
(string=? x type))
|
||||
"type"))
|
||||
(parm "uri")
|
||||
(parm "name")))
|
||||
release)))
|
||||
(uri (assoc-ref my-file-data "uri"))
|
||||
(name (assoc-ref my-file-data "name"))
|
||||
(file-path (string-append (assoc-ref release 'cache-path)
|
||||
"/"
|
||||
name)))
|
||||
(mkpath (assoc-ref release 'cache-path))
|
||||
(if (not (access? file-path F_OK))
|
||||
(system* "/usr/bin/wget" "-O" file-path uri))
|
||||
file-path)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue