325 lines
14 KiB
Scheme
325 lines
14 KiB
Scheme
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;; 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 (ice-9 receive)
|
||
|
|
#: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 'submodule-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"))
|
||
|
|
;;TODO figure out how to use non parameter options from the command
|
||
|
|
;; line instead of this.
|
||
|
|
(switch
|
||
|
|
(name 'base) (default "") (test string?)
|
||
|
|
(synopsis "Base folder different from working dir."))
|
||
|
|
;; 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))
|
||
|
|
;; Init repo from url if requested.
|
||
|
|
(if (not (string=? (option-ref options 'init-from) ""))
|
||
|
|
(repo-clone (option-ref options 'init-from)
|
||
|
|
(if (not (string=? (option-ref options 'base) ""))
|
||
|
|
(option-ref options 'base)
|
||
|
|
(getcwd))))
|
||
|
|
(let* ((folder (if (not (string=? (option-ref options 'base) ""))
|
||
|
|
(option-ref options 'base)
|
||
|
|
(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)))))
|
||
|
|
;; Update the source repository if requested.
|
||
|
|
(if (option-ref options 'submodule-update)
|
||
|
|
(repo-update-src folder))
|
||
|
|
|
||
|
|
;; 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 repo definition files.
|
||
|
|
(cp-repo-file repo
|
||
|
|
""
|
||
|
|
"autogen"
|
||
|
|
"README-repo.org"
|
||
|
|
(option-ref options 'verbosity))
|
||
|
|
(cp-repo-file repo
|
||
|
|
""
|
||
|
|
"autogen"
|
||
|
|
"metadata"
|
||
|
|
(option-ref options 'verbosity))
|
||
|
|
(cp-repo-file repo
|
||
|
|
""
|
||
|
|
"autogen"
|
||
|
|
"profiles"
|
||
|
|
(option-ref options 'verbosity))
|
||
|
|
(cp-repo-file repo
|
||
|
|
""
|
||
|
|
"autogen"
|
||
|
|
"repositories.xml"
|
||
|
|
(option-ref options 'verbosity))
|
||
|
|
(cp-repo-file repo
|
||
|
|
""
|
||
|
|
"autogen/"
|
||
|
|
".gitignore-repo"
|
||
|
|
(option-ref options 'verbosity)
|
||
|
|
#:file-dst ".gitignore")
|
||
|
|
|
||
|
|
;; Preform ebuild generation.
|
||
|
|
(let ((pkg-list (build-pkg-list repo folder #t)))
|
||
|
|
(if (>= (option-ref options 'verbosity)
|
||
|
|
verbosity-warn)
|
||
|
|
(begin (display "package-list:") (newline)
|
||
|
|
(pretty-print pkg-list)))
|
||
|
|
(let ((cache-files-used
|
||
|
|
(append-map (lambda (pkg)
|
||
|
|
(let ((name (string->symbol (assoc-ref pkg 'name)))
|
||
|
|
(cat (string->symbol (assoc-ref pkg 'category))))
|
||
|
|
(if (>= (option-ref options 'verbosity)
|
||
|
|
verbosity-notice)
|
||
|
|
(begin (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))
|
||
|
|
(distfiles-used '())
|
||
|
|
(pkgfiles-used
|
||
|
|
(if pkg-mod
|
||
|
|
(let ((releases
|
||
|
|
(if (module-variable pkg-mod 'get-releases)
|
||
|
|
((module-ref pkg-mod 'get-releases)
|
||
|
|
(append parms pkg))
|
||
|
|
'())))
|
||
|
|
(append
|
||
|
|
;; 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.
|
||
|
|
(receive (pkg-files dist-files)
|
||
|
|
(if (module-variable pkg-mod 'generate-ebuilds)
|
||
|
|
((module-ref pkg-mod 'generate-ebuilds)
|
||
|
|
pkg-parms
|
||
|
|
releases)
|
||
|
|
(ebuild-gen pkg-parms
|
||
|
|
releases))
|
||
|
|
(set! distfiles-used
|
||
|
|
(append distfiles-used dist-files))
|
||
|
|
pkg-files)))
|
||
|
|
(setup-pkg pkg-parms))))
|
||
|
|
(if (option-ref options 'ebuild-clean)
|
||
|
|
(clean-files pkgfiles-used
|
||
|
|
(string-join (list repo
|
||
|
|
(assoc-ref pkg 'category)
|
||
|
|
(assoc-ref pkg 'name))
|
||
|
|
file-name-separator-string)
|
||
|
|
(option-ref options 'verbosity)))
|
||
|
|
(display "Done with package: ")
|
||
|
|
(display (assoc-ref pkg 'category))
|
||
|
|
(display "/")
|
||
|
|
(display (assoc-ref pkg 'name))
|
||
|
|
(newline)
|
||
|
|
distfiles-used))
|
||
|
|
#:unwind? (< 1 (length pkg-list)))))
|
||
|
|
pkg-list)))
|
||
|
|
;; Clean deprecated cache files if requested.
|
||
|
|
(if (>= (option-ref options 'verbosity)
|
||
|
|
verbosity-notice)
|
||
|
|
(begin (display "distfiles-used:") (newline)
|
||
|
|
(pretty-print cache-files-used)
|
||
|
|
(display "\"") (newline)))
|
||
|
|
(if (and (or (string=? folder repo)
|
||
|
|
(string=? folder
|
||
|
|
(string-join (list repo "autogen")
|
||
|
|
file-name-separator-string)))
|
||
|
|
(option-ref options 'cache-clean))
|
||
|
|
(clean-files cache-files-used
|
||
|
|
(option-ref options 'filecache-path)
|
||
|
|
(option-ref options 'verbosity))))
|
||
|
|
|
||
|
|
;; The extra folders in repo not in src.
|
||
|
|
(let ((repo-pkgs (build-pkg-list repo folder #f)))
|
||
|
|
(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 "Absolute 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)))))
|