300 lines
14 KiB
Scheme
300 lines
14 KiB
Scheme
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; 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)))
|