cor/ebuild-autogen
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit.

Browse source
This commit is contained in:
Cor Legemaat 2025-06-30 16:15:39 +02:00
commit e74b648989
26 changed files with 2996 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

61
ebuild/Makefile.am Normal file
View file

@ -0,0 +1,61 @@
################################################################################
# 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/>.
################################################################################
SUBDIRS = fetchers
moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/ebuild
objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/ebuild
#https://www.gnu.org/software/automake/manual/html_node/Scripts.html
bin_SCRIPTS=ebuild-autogen
SOURCES = \
bash-utils.scm \
cli.scm \
defs.scm \
gen.scm \
repo.scm \
utils.scm \
version.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) \
version.scm.in
CLEANFILES = $(GOBJECTS) ${bin_SCRIPTS}
GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
GUILE_OPTS = -L $(abs_top_builddir)
SUFFIXES = .scm .go .in
version.scm: version.scm.in
$(file >$@,$(subst {{version}},$(VERSION),$(file <$<)))
ebuild-autogen: ebuild-autogen.in
$(file >$@,$(subst {{guile-bin}},$(GUILE),$(file <$<)))
.scm.go:
$(GUILD) compile $(GUILE_TARGET) $(GUILE_OPTS) $(GUILE_WARNINGS) -o "$@" "$<"

61
ebuild/bash-utils.scm Normal file
View file

@ -0,0 +1,61 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bash-utils.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 bash-utils)
#:use-module (rnrs io ports)
#:use-module (ice-9 expect)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim))
(define-public bash-source-vars
(lambda (source var-list)
(let* ((in-pipe (pipe))
(out-pipe (pipe O_NONBLOCK))
(pid (spawn "bash" '("bash")
#:input (car in-pipe)
#:output (cdr out-pipe)))
(answ '())
(expect-port (car out-pipe))
(expect-timeout 1))
;; Make line buffered.
(setvbuf (cdr in-pipe) 'line)
(setvbuf (cdr out-pipe) 'line)
;; Do the sourcing stuff.
(write-line source (cdr in-pipe))
;; Eliminate extra data to stdout from sourcing.
(write-line "echo \"Done sourcing!\"" (cdr in-pipe))
(expect ((lambda (s eof?)
(string=? s "Done sourcing!\n"))
(lambda () #t)))
;; Read the variables.
(set! answ
(map (lambda (var)
(write-line (string-append "echo \"${"
var
"}\"") (cdr in-pipe))
(cons var (get-line (car out-pipe))))
var-list))
;; Tel bash to exit.
(write-line "exit 0" (cdr in-pipe))
;; Close my side of the pipes
(close-port (car in-pipe))
(close-port (cdr out-pipe))
;; Close bash's side of the pipes.
(close-port (cdr in-pipe))
(close-port (car out-pipe))
;; Finish.
(waitpid pid)
answ)))

277
ebuild/cli.scm Normal file
View file

@ -0,0 +1,277 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cli.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 cli)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 format)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (dql dql)
#:use-module (ebuild defs)
#:use-module (ebuild repo)
#:use-module (ebuild gen)
#:use-module (ebuild version)
#:use-module (config)
#:use-module (config api)
#:use-module (config parser sexp))
(define config
;; Define our root configuration
(configuration
(name 'ebuild-autogen)
(keywords
(list
;; Switch to force writing non-eager configuration files
(switch
(name 'write) (default #f) (test boolean?) (character #f)
(synopsis "Write configuration file in local dir."))
(switch
(name 'verbosity) (default 3) (example "3")
(handler string->number) (test integer?)
(synopsis "The verbosity level."))
(switch
(name 'subtree-update) (default #false) (test boolean?)
(synopsis "Fetch update subtree source repo"))
(switch
(name 'pkg-clean) (default #false) (test boolean?)
(synopsis "Remove packages from repo that's not in autogen subtree."))
(switch
(name 'ebuild-clean) (default #false) (test boolean?)
(synopsis "Remove ebuilds no more active."))
(switch
(name 'cache-clean) (default #false) (test boolean?)
(synopsis "Remove files from cache no more needed in tree gen."))
(switch
(name 'remote-push) (default #false) (test boolean?)
(synopsis "Commit and push updated tree to remote."))
(switch
(name 'init-from) (default "") (test string?)
(example "https://www.cor.za.net/code/portage-overlay")
(synopsis "An url to initialize the repo from scratch"))
;; A setting in the configuration file, if it exists.
(setting
(name 'github-token) (default "")
(handler identity) (test string?)
(synopsis "The github authentication token.")
(description "The github authentication token as a string for
authentication when pulling package updates from github."))
(setting
(name 'filecache-path)
(default (if (getenv "XDG_CACHE_HOME")
(getenv "XDG_CACHE_HOME")
(string-append (getenv "HOME")
"/.cache/ebuild-autogen")))
(example (string-append (getenv "HOME")
"/.cache/ebuild-autogen"))
(handler identity) (test string?)
(synopsis "Cache files path.")
(description "Full path to the folder where to store the file cache."))
(setting
(name 'tmp-path) (default "/tmp/ebuild-autogen/")
(example "/tmp/ebuild-autogen/")
(handler identity) (test string?)
(synopsis "Temporary files path.")
(description "Full path to the folder for the temporary files."))))
(synopsis "Auto generate Gentoo ebuild's")
(description "ebuild-autogen is a Guile scheme application to auto generate
gentoo ebuild package definitions from the \"autogen.scm\" specification for
the package from the subtree source residing in the autogen folder of the
git repository.")
(parser sexp-parser)
;; Specify where we want to install configuration files
(directory (list (if (getenv "XDG_CONFIG_HOME")
(path (given (getenv "XDG_CONFIG_HOME"))
(eager? #f))
(in-home ".config/" #:wait?))))
(version version-str)
(copyright (list 2025))
(license agpl3)
(author "Cor Legemaat")))
(define-public main
(lambda (cmd-line)
(let ((options (getopt-config-auto cmd-line config)))
(when (option-ref options 'write)
(options-write options))
(let* ((folder (getcwd))
(repo (repo-root-for folder (option-ref options 'verbosity)))
(parms (list (cons 'repo repo)
(cons 'verbosity (option-ref options 'verbosity))
(cons 'cache-path (option-ref options
'filecache-path))
(cons 'tmp-path (option-ref options 'tmp-path)))))
;; Init repo from url if requested.
;; TODO.
;; Add our repository to the load path.
(add-to-load-path (string-append repo "/autogen"))
;; Add optional parameters if exist.
(if (not (string-null? (option-ref options 'github-token)))
(set! parms
(assoc-set! parms
'github-token
(option-ref options 'github-token))))
(with-exception-handler
(lambda (exception)
(if (>= (option-ref options 'verbosity)
verbosity-warn)
(begin
(display "Failed to read the repo parameters with ")
(if (exception-with-message? exception)
(display
(simple-format
#f " exception-message: \"~a\""
(exception-message exception))))
(if (and (exception-with-message? exception)
(exception-with-irritants? exception))
(display " and"))
(if (exception-with-irritants? exception)
(display
(simple-format
#f " exception-irritants: \"~a\""
(exception-irritants exception))))
(newline)))
'())
(lambda ()
(let ((repo-mod (resolve-module `(repo-local settings))))
(if (module-variable repo-mod 'parms)
(set! parms (append parms
(module-ref repo-mod 'parms))))))
#:unwind? #t)
;; Update the source repository if requested.
(if (option-ref options 'subtree-update)
(repo-update-src))
;; Test the repo definition symlinks.
(test-symlink repo
"README.org"
"autogen/README-repo.org"
(option-ref options 'verbosity))
(test-symlink repo
"metadata"
"autogen/metadata"
(option-ref options 'verbosity))
(test-symlink repo
"profiles"
"autogen/profiles"
(option-ref options 'verbosity))
(test-symlink repo
"repositories.xml"
"autogen/repositories.xml"
(option-ref options 'verbosity))
(test-symlink repo
".gitignore"
"autogen/.gitignore-repo"
(option-ref options 'verbosity))
;; Preform ebuild generation.
(let ((pkg-list (build-pkg-list repo folder #t)))
(display "package-list:") (newline)
(pretty-print pkg-list)
(let ((cache-files-used
(map (lambda (pkg)
(let ((name (string->symbol (assoc-ref pkg 'name)))
(cat (string->symbol (assoc-ref pkg 'category))))
(display "pkg:") (newline)
(pretty-print (append parms pkg))
(with-exception-handler
(lambda (exception)
(if (>= (option-ref options 'verbosity)
verbosity-error)
(begin
(display "Failed to update the package ")
(display (assoc-ref pkg 'category))
(display "/")
(display (assoc-ref pkg 'name))
(display " with")
(if (exception-with-message? exception)
(display
(simple-format
#f " exception-message: \"~a\""
(exception-message exception))))
(if (and (exception-with-message? exception)
(exception-with-irritants? exception))
(display " and"))
(if (exception-with-irritants? exception)
(display
(simple-format
#f " exception-irritants: \"~a\""
(exception-irritants exception))))
(newline)))
'())
(lambda ()
(let ((pkg-mod (resolve-module `(,cat ,name autogen)))
(pkg-parms (append parms pkg)))
(if pkg-mod
(let ((releases
(if (module-variable pkg-mod 'get-releases)
((module-ref pkg-mod 'get-releases)
(append parms pkg))
'())))
;; Setup the folder and links for the package.
(if (module-variable pkg-mod 'setup-package)
((module-ref pkg-mod 'setup-package)
pkg-parms)
(setup-pkg pkg-parms))
;; Generate the ebuilds.
(if (module-variable pkg-mod 'generate-ebuilds)
((module-ref pkg-mod 'generate-ebuilds)
pkg-parms
releases)
(ebuild-gen pkg-parms
releases)))
(setup-pkg pkg-parms))
(display "Done with package: ")
(display (assoc-ref pkg 'category))
(display "/")
(display (assoc-ref pkg 'name))
(newline)))
#:unwind? (< 1 (length pkg-list)))))
pkg-list)))
;; Clean deprecated cache files if requested.
(display "distfiles-used:") (newline)
(pretty-print cache-files-used))
;; The extra folders in repo not in src.
(let ((repo-pkgs (build-pkg-list repo folder #f)))
;;(display "repo-pkgs:") (newline) (pretty-print repo-pkgs)
(map (lambda (pkg)
(if (null? ((dql (filter (where (lambda (val)
(string=? val
(assoc-ref pkg 'category)))
'category)
(where (lambda (val)
(string=? val
(assoc-ref pkg 'name)))
'name)))
pkg-list))
(if (>= (option-ref options 'verbosity)
verbosity-warn)
(begin (display "Obsolete pkg ")
(display (assoc-ref pkg 'category))
(display "/")
(display (assoc-ref pkg 'name))
(display " found.")
(newline)))))
repo-pkgs)))
;; Commit and push the updates to master if requested.
(if (option-ref options 'repo-push)
(repo-push-master))
(display "Completed successfully ...") (newline)))))

37
ebuild/defs.scm Normal file
View file

@ -0,0 +1,37 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; defs.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 defs))
(define-public version-major 0)
(define-public version-minor 0)
(define-public version-release 0)
(define-public curl-useragent
(string-append "ebuild-autogen/"
(number->string version-major)
"."
(number->string version-minor)))
;; The verbosity level definitions.
(define-public verbosity-emergency 0)
(define-public verbosity-alert 1)
(define-public verbosity-critical 2)
(define-public verbosity-error 3)
(define-public verbosity-warn 4)
(define-public verbosity-notice 5)
(define-public verbosity-info 6)
(define-public verbosity-debug 7)

6
ebuild/ebuild-autogen.in Executable file
View file

@ -0,0 +1,6 @@
#!{{guile-bin}} \
-e main -s
!#
(add-to-load-path "/home/cor/local/share/guile/")
(use-modules (ebuild cli))

48
ebuild/fetchers/Makefile.am Normal file
View 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)/dql
objdir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/dql
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
View 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))
;;(display "file=") (display entry)(newline)
(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
(begin ;; (display (string-append var "="))
;; (display (irregex-match-substring var-match))
;; (newline)
(append! release (list (cons var (irregex-match-substring var-match))))))))
extract-vars)
(set! releases (append releases (list release)))))
;;(display "relese = ") (display release) (newline)
;;(display "releses = ") (display releases) (newline)
(close ebuild-file)))
(closedir dir)
releases)))

299
ebuild/fetchers/forgejo.scm Normal file
View 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)))

315
ebuild/fetchers/github.scm Normal file
View file

@ -0,0 +1,315 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)))

91
ebuild/fetchers/pypi.scm Normal file
View 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))))

123
ebuild/fetchers/raw.scm Normal file
View file

@ -0,0 +1,123 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 (access? file-path F_OK)
(display "File already downloaded.\n")
(system* "/usr/bin/wget" "-O" file-path uri))
file-path)))

261
ebuild/gen.scm Normal file
View file

@ -0,0 +1,261 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gen.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 gen)
#:use-module (ebuild utils)
#:use-module (ebuild defs)
#:use-module (dql dql)
#:use-module (rx irregex)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 string-fun)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-1))
;;Function to generate template from ebuild with variable substitution.
(define-public ebuild-from-tmpl
(lambda (tmpl vars out verbosity)
""
(letrec*
((input-port (open-input-file tmpl))
(output-port (open-output-file out))
(data (string-split (get-string-all input-port) #\lf))
(traverse-list
(lambda (pre no data)
(traverse (string-append (if (symbol? pre)
(symbol->string pre)
pre)
"["
(number->string no)
"]")
(car data))
(if (not (null? (cdr data)))
(traverse-list pre (1+ no) (cdr data)))))
(traverse-alist
(lambda (pre data)
(for-each (lambda (var)
(if (and (string? (car var))
(string? (cdr var)))
(replace (if (eq? (string-length pre) 0)
(car var)
(string-append pre
"."
(car var)))
(cdr var))
(traverse (if (eq? (string-length pre) 0)
(car var)
(string-append pre
"."
(car var)))
(cdr var))))
data)))
(traverse (lambda (pre data)
(cond ((alist? data)
(traverse-alist pre data))
((list? data)
(traverse-list pre 0 data))
((number? data)
(replace pre (number->string data)))
((string? data) (replace pre data))
(else (error (string-append "Error! Don't know how "
"to process \""
(object->string data)
"\" data type."))))))
(replace
(lambda (var val)
(let ((var-str (string-append "{{"
(if (symbol? var)
(symbol->string var)
var)
"}}")))
(if (>= verbosity verbosity-info)
(begin (display "Replacing \"") (display var-str)
(display "\" with \"") (display val)
(display "\"") (newline)))
(set! data (map (lambda (line)
(string-replace-substring line
var-str
val))
data))))))
(if (irregex-search '(seq (+ "#") (+ space) "-*-" (+ space))
(car data))
(set! data (cdr data)))
(traverse "" vars)
(display "# Auto generated from autogen.scm" output-port)
(newline output-port)
(display (string-join data "\n") output-port)
(close output-port)
out)))
(define-public ebuild-fkc
(lambda (vlist-in comps-in)
""
(letrec*
((base (lambda (vlist comps)
(if (null? comps)
(cdr (car vlist))
(let ((clist (sort (delete-duplicates
(map (lambda (vers)
(if (null? (car vers))
-1
(car (car vers))))
vlist))
<)))
(map (lambda (vcomp)
(append-map
(lambda (sts)
(cond ((string? sts)
(list (list vcomp) sts))
((null? (car sts))
(append (list vcomp) (cdr sts)))
((not (list? (car (car sts))))
(list (list (append (list vcomp)
(car sts))
(second sts))))
(else
(map (lambda (tst)
(list (append (list vcomp)
(car tst))
(second tst)))
sts))))
(base (map (lambda (ver)
(list (if (null? (car ver))
'()
(cdr (car ver)))
(car (cdr ver))))
(filter (lambda (vers)
(= vcomp
(if (null? (car vers))
-1
(car (car vers)))))
vlist))
(cdr comps))))
(take-right clist
(min (length clist)
;; 0=all.
(if (zero? (car comps))
(length clist)
(car comps))))))))))
;;Works, but probably only for 3 components so shit solution.
(append-map (lambda (vmaj)
vmaj)
(base vlist-in comps-in)))))
(define default-version-components
(lambda (version)
""
(map (lambda (component)
(string->number component))
(irregex-split #\.
(irregex-match-substring
(irregex-search '(seq (+ num) (+ (seq "." (+ num))))
version))))))
(define-public ebuild-version-filter
(lambda* (releases #:key
(keep-components (if (assoc-ref releases 'keep-vers-comps)
(assoc-ref releases 'keep-vers-comps)
(list 1 1 1)))
(version-components default-version-components)
(keep (lambda (version) #f))
(drop (lambda (version) #f)))
""
(let* ((vlist (map (lambda (release)
(list (version-components (assoc-ref release
"version"))
(assoc-ref release "version")))
releases))
(vlist-filtered
(append (filter (lambda (vers)
(if (keep (second vers)) vers #f))
vlist)
(filter (lambda (vers)
(if (drop (second vers)) #f vers))
(ebuild-fkc vlist keep-components)))))
(filter-map (lambda (rel)
(if (any (lambda (vers)
(string= (assoc-ref rel "version")
(second vers)))
vlist-filtered)
(append (list (cons "version-components"
(version-components
(assoc-ref rel
"version"))))
rel)
#f))
releases))))
;;Procedure to generate the required ebuild from the given releases.
(define-public ebuild-gen
(lambda* (parms releases #:key
(version-components (lambda (version)
(map (lambda (component)
(string->number component))
(string-split version #\.))))
(keep-components (list 1 1 2))
(keep (lambda (version) #f))
(drop (lambda (version) #f))
(template (string-join (list (assoc-ref parms 'repo)
"autogen"
(assoc-ref parms 'category)
(assoc-ref parms 'name)
(string-append (assoc-ref parms 'name)
".tmpl"))
file-name-separator-string))
(post-hook (lambda (ebuild-path vars)
(system* "ebuild"
ebuild-path
"manifest"))))
""
(if (>= (assoc-ref parms 'verbosity) verbosity-notice)
(begin (display "Releases:\n")
(pretty-print releases)))
(letrec* ((version-list
(map (lambda (release)
(list (version-components (assoc-ref release "version"))
(assoc-ref release "version")))
releases)))
(let ((selected-versions (ebuild-fkc version-list keep-components)))
(filter-map
(lambda (vers)
(let ((path (string-join (list (assoc-ref parms 'repo)
(assoc-ref parms 'category)
(assoc-ref parms 'name)
(string-append (assoc-ref parms 'name)
"-"
(second vers)
".ebuild"))
file-name-separator-string)))
(if (and (not (access? path F_OK))
(not (drop (second vers)))
(or (find (lambda (test-vers)
(string= (second test-vers)
(second vers)))
selected-versions)
(keep (second vers))))
(let* ((vars (car (filter (lambda (rel)
(string= (assoc-ref rel "version")
(second vers)))
releases)))
(ebuild-created (ebuild-from-tmpl
template
(append vars parms)
path
(assoc-ref parms 'verbosity))))
(post-hook ebuild-created (append parms vars))
(append vars
(list (cons "ebuild" path))))
#f)))
version-list)))))

225
ebuild/repo.scm Normal file
View file

@ -0,0 +1,225 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; repo.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 repo)
#:use-module (ebuild defs)
#:use-module (ebuild utils)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (git bindings)
#:use-module (git repository)
#:use-module (rx irregex))
;; Required initialization call.
(libgit2-init!)
(define-public repo-root-for
(lambda (path verbosity)
(let ((repo-orig
(with-exception-handler
(lambda (exception)
(display exception) (newline)
(display "error: Failed to find the repository root for \"")
(display path)
(display "\", ebuild-autogen is designed to work with ")
(display "portage overlay repositories in git!") (newline)
(display "If you are testing and don't have a git repository ")
(display "yet for your overlay, make it one by running ")
(display "'git init' in the root of the repository.")
(newline))
(lambda ()
(repository-discover path)))))
(let ((repo-root (dirname repo-orig)))
(if (>= verbosity verbosity-notice)
(begin (display "Using repository: ")
(display repo-root)
(newline)))
(if (not (file-exists? (string-append repo-root
"/autogen/")))
(raise-exception
(make-exception
(make-external-error)
(make-exception-with-message
"Can't find the \"autogen\" folder in repository root")
(make-exception-with-irritants repo-root))))
repo-root))))
;;(repo-root-for "/home/cor/Projects/portage-overlay" verbosity-notice)
(define-public repo-update-src
(lambda ()
(display "Willing to update src subtree...") (newline)
#t))
(define-public repo-push-master
(lambda ()
(display "Willing to push updates to master...") (newline)
#t))
(define-public test-symlink
(lambda (repo src dst verbosity)
""
(let ((port (open-file repo "r")))
(if (false-if-exception (statat port src AT_SYMLINK_NOFOLLOW))
;;Check if src is a symlink.
(if (eq? (stat:type (statat port src AT_SYMLINK_NOFOLLOW)) 'symlink)
(if (string=? (readlink (string-append repo "/" src)) dst)
(if (>= verbosity verbosity-notice)
(begin (display "Symlink \"")
(display src)
(display "\" ok.")
(newline)))
(if (>= verbosity verbosity-critical)
(begin (display "warning: symlink from \"")
(display src)
(display "\" not pointing to \"")
(display dst)
(display "\" but to \"")
(display (readlink (string-append repo "/" src)))
(display "\" and might deliver unexpected results!")
(newline))))
(if (>= verbosity verbosity-critical)
(begin (display "warning: \"")
(display src)
(display "\" not a symbolic link and won't ")
(display "represent autogen source data!")
(newline))))
(begin (symlinkat port dst src)
(if (>= verbosity verbosity-warn)
(begin (display "Symlink \"")
(display src)
(display "\" created.")
(newline)))))
(close-port port))))
(define-public folder-list
(lambda (path ignore-meta)
""
;;(display "path=\"") (display path) (display "\"") (newline)
(filter-map (lambda (entry)
(if (eq? 'directory
(stat:type (stat (string-append path "/" entry))))
(if (and ignore-meta
(or (string=? entry "metadata")
(string=? entry "profiles")))
#f
(if (char=? (car (string->list entry)) #\.)
#f entry))
#f))
(scandir path))))
(define-public build-pkg-list
(lambda (repo folder in-autogen)
(let* ((file-seperator (car (string->list file-name-separator-string)))
(repo-list (string-split repo file-seperator))
(repo-path-len (length repo-list))
(fpl (let ((folder-list (string-split folder file-seperator)))
(if in-autogen
;; In autogen folder, aka the source pkgs.
(if (> (length folder-list) repo-path-len)
(if (string=? (car (take-right folder-list
(- (length folder-list)
repo-path-len)))
"autogen")
folder-list
(append repo-list
(list "autogen")
(take-right folder-list
(- (length folder-list)
repo-path-len))))
(append folder-list (list "autogen")))
;; Outside autogen folder, the generated pkgs.
(if (> (length folder-list) repo-path-len)
(if (string=? (car (take-right folder-list
(- (length folder-list)
repo-path-len)))
"autogen")
(append repo-list
(take-right folder-list
(- (length folder-list)
(1+ repo-path-len))))
folder-list)
folder-list))))
(depth (- (length fpl)
repo-path-len
(if in-autogen 1 0))))
;;(display "fpl=\"") (display fpl) (display "\"") (newline)
;;(display "folder-list:") (display (folder-list (string-join fpl "/") #t)) (newline)
(cond ((= depth 2)
(list (list (cons 'category (first (take-right fpl 2)))
(cons 'name (last fpl)))))
((= depth 1)
(map (lambda (pkg)
(list (cons 'category (last fpl))
(cons 'name pkg)))
(folder-list (string-join fpl file-name-separator-string)
#t)))
((= depth 0)
(if (null? (folder-list (string-join fpl file-name-separator-string)
#t))
(list (list))
(append-map (lambda (cat)
(map (lambda (pkg)
(list (cons 'category cat)
(cons 'name pkg)))
(folder-list (string-join (append fpl
(list cat))
file-name-separator-string)
#f)))
(folder-list (string-join fpl file-name-separator-string) #t))))
(else "")))))
(define-public setup-pkg
(lambda (parms)
""
(let ((src-path (string-join (list (assoc-ref parms 'repo)
"autogen"
(assoc-ref parms 'category)
(assoc-ref parms 'name))
file-name-separator-string))
(dst-path (string-join (list (assoc-ref parms 'repo)
(assoc-ref parms 'category)
(assoc-ref parms 'name))
file-name-separator-string)))
;;Check folder exists.
(display "SRC-path=") (display src-path) (newline)
(if (file-exists? dst-path)
(if (>= (assoc-ref parms 'verbosity))
(begin (display "Folder for ")
(display (assoc-ref parms 'category))
(display "/")
(display (assoc-ref parms 'name))
(display " already exist.")
(newline)))
(mkpath dst-path))
;;symlink each ebuild and the files folder.
(for-each
(lambda (file)
(test-symlink (assoc-ref parms 'repo)
(string-join (list dst-path file)
file-name-separator-string)
(string-join (list src-path file)
file-name-separator-string)
(assoc-ref parms 'verbosity)))
(filter-map
(lambda (file)
(if (irregex-search '(or (seq bos "files" eos)
(seq ".ebuild" eos ))
file)
file
#f))
(scandir src-path))))))

71
ebuild/utils.scm Normal file
View file

@ -0,0 +1,71 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utils.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 utils)
#:use-module (srfi srfi-1))
(define-public list->str-list
(lambda* (in-list glue #:key (pre "") (post ""))
""
;;(display "in-list=") (display in-list) (newline)
(if (null? in-list)
""
(string-concatenate
(append (list pre)
(cdr (append-map (lambda (item)
(append (list glue)
(list item)))
in-list))
(list post))))))
(define-public any-str-list
(lambda (test-list val)
""
(any (lambda (test-val)
(if (string=? test-val val)
#t #f))
test-list)))
(define-public mkpath
(lambda (path)
(let* ((split-path (filter-map (lambda (str)
(if (string<> str "") str #f))
(string-split path
(car (string->list
file-name-separator-string)))))
(fixed-path (string-append (string-concatenate (map (lambda (folder)
(string-append "/" folder))
split-path))
"/"))
(path-1up (string-concatenate (map (lambda (folder)
(string-append "/" folder))
(reverse (cdr (reverse split-path)))))))
(if (not (access? fixed-path F_OK))
(if (access? path-1up F_OK)
(if (access? path-1up W_OK)
(mkdir fixed-path)
(error (string-append "Error no write permission in \""
path-1up
"\" to create \""
(car (reverse split-path))
"\" folder!")))
(begin (mkpath path-1up)
(mkdir path)))))))
(define-public cmp-str-lists
(lambda (list1 list2)
""
(every string=? list1 list2)))

29
ebuild/version.scm.in Normal file
View file

@ -0,0 +1,29 @@
;; -*- Mode: Scheme; geiser-scheme-implementation: guile; tab-width: 2 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; version.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 version))
(define-public version-str "{{version}}")
(define-public version (map string->number
(string-split version-str #\.)))
(define-public version-major (list-ref version 0))
(define-public version-minor (list-ref version 1))
(define-public version-release (list-ref version 2))