Initial commit.
This commit is contained in:
commit
878d52ee27
26 changed files with 3341 additions and 0 deletions
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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue