405 lines
17 KiB
Scheme
405 lines
17 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; cli.scm
|
|
;; Copyright (C) 2025, 2026 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 (srfi srfi-19)
|
|
#:use-module (dql dql)
|
|
#:use-module (ebuild defs)
|
|
#:use-module (ebuild repo)
|
|
#:use-module (ebuild gen)
|
|
#:use-module (ebuild utils)
|
|
#: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 submodule 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"))
|
|
(switch
|
|
(name 'min-interval) (default "7d") (test string?)
|
|
(example "7D")
|
|
(synopsis "Minimum interval in witch to update packages in Seconds Minutes Hours or Days"))
|
|
;;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."))
|
|
(setting
|
|
(name 'curl-retries) (default 3) (character #f)
|
|
(example "3") (handler string->number) (test integer?)
|
|
(synopsis "curl retry count.")
|
|
(description "The amount of retries for curl."))))
|
|
(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))
|
|
(cons 'age-limit
|
|
(if (or (option-ref options 'pkg-clean)
|
|
(option-ref options 'ebuild-clean)
|
|
(option-ref options 'cache-clean))
|
|
(begin (display "Warning, ignoring min-interval to clean files!")
|
|
(current-time))
|
|
(subtract-duration
|
|
(current-time)
|
|
(string->duration
|
|
(option-ref options
|
|
'min-interval))))))))
|
|
;; 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))))
|
|
|
|
;; The curl retries setting.
|
|
(set! parms
|
|
(assoc-set! parms
|
|
'curl-retries
|
|
(option-ref options 'curl-retries)))
|
|
|
|
(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)
|
|
#:file-dst "README.org")
|
|
(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")
|
|
(cp-repo-file repo
|
|
""
|
|
"autogen/"
|
|
"eclass"
|
|
(option-ref options 'verbosity)
|
|
#:required #f)
|
|
(cp-repo-file repo
|
|
""
|
|
"autogen/"
|
|
"license"
|
|
(option-ref options 'verbosity)
|
|
#:required #f)
|
|
|
|
;; Preform ebuild generation.
|
|
(let ((pkg-list (build-pkg-list repo folder #t))
|
|
(same-pkg? (lambda (a b)
|
|
(and (string=? (assoc-ref a 'category)
|
|
(assoc-ref b 'category))
|
|
(string=? (assoc-ref a 'name)
|
|
(assoc-ref b 'name))))))
|
|
(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))
|
|
(pkgfiles-used
|
|
(if pkg-mod
|
|
;; Setup the folder and links for the package.
|
|
(let* ((setup-files ((if (module-variable pkg-mod 'setup-package)
|
|
(module-ref pkg-mod 'setup-package)
|
|
setup-pkg)
|
|
pkg-parms))
|
|
;; Fetch the releases.
|
|
(releases
|
|
(if (module-variable pkg-mod 'get-releases)
|
|
((module-ref pkg-mod 'get-releases)
|
|
pkg-parms)
|
|
'()))
|
|
;; Generate the ebuilds.
|
|
(pkg-gen ((if (module-variable pkg-mod 'generate-ebuilds)
|
|
(module-ref pkg-mod 'generate-ebuilds)
|
|
ebuild-gen)
|
|
(assoc-set! pkg-parms
|
|
'pkgfiles
|
|
setup-files)
|
|
releases)))
|
|
;; Populate package if no ebuilds generated.
|
|
(if (null? pkg-gen)
|
|
(list (list (cons 'category (assoc-ref pkg-parms 'category))
|
|
(cons 'name (assoc-ref pkg-parms 'name))
|
|
(cons 'pkgfiles setup-files)))
|
|
pkg-gen))
|
|
(setup-pkg pkg-parms))))
|
|
(display "Done with package: ")
|
|
(display (assoc-ref pkg 'category))
|
|
(display "/")
|
|
(display (assoc-ref pkg 'name))
|
|
(newline)
|
|
(if (>= (option-ref options 'verbosity)
|
|
verbosity-notice)
|
|
(begin (display "package results:") (newline)
|
|
(pretty-print pkgfiles-used)))
|
|
pkgfiles-used))
|
|
#:unwind? (< 1 (length pkg-list)))))
|
|
pkg-list))
|
|
(unique-pkgfiles
|
|
(map (lambda (pkg)
|
|
(set! pkg
|
|
(assoc-set! pkg
|
|
'pkgfiles
|
|
(delete-duplicates
|
|
(append-map (lambda (p)
|
|
(if (same-pkg? pkg p)
|
|
(if (assoc-ref p 'pkgfiles)
|
|
(assoc-ref p 'pkgfiles)
|
|
'())
|
|
'()))
|
|
cache-files-used)
|
|
string=?)))
|
|
(set! pkg (assoc-set! pkg
|
|
'distfiles
|
|
(delete-duplicates
|
|
(append-map (lambda (p)
|
|
(if (same-pkg? pkg p)
|
|
(if (assoc-ref p 'distfiles)
|
|
(assoc-ref p 'distfiles)
|
|
'())
|
|
'()))
|
|
cache-files-used)
|
|
string=?)))
|
|
pkg)
|
|
(delete-duplicates cache-files-used
|
|
same-pkg?))))
|
|
;; Clean deprecated pkgfiles.
|
|
(if (option-ref options 'ebuild-clean)
|
|
(clean-ebuilds unique-pkgfiles
|
|
repo
|
|
(option-ref options 'verbosity)))
|
|
;; Clean deprecated cache files if requested.
|
|
(if (>= (option-ref options 'verbosity)
|
|
verbosity-notice)
|
|
(begin ;; (display "generated results:") (newline)
|
|
;; (pretty-print cache-files-used)
|
|
(display "generated pkgs:") (newline)
|
|
(pretty-print unique-pkgfiles)))
|
|
(if (and (or (string=? folder repo)
|
|
(string=? folder
|
|
(string-join (list repo "autogen")
|
|
file-name-separator-string)))
|
|
(option-ref options 'cache-clean))
|
|
(clean-cache cache-files-used
|
|
(option-ref options 'filecache-path)
|
|
(option-ref options 'verbosity)))
|
|
;; The extra folders in repo not in src.
|
|
(if (and (or (string=? folder repo)
|
|
(string=? folder
|
|
(string-join (list repo "autogen")
|
|
file-name-separator-string)))
|
|
(option-ref options 'pkg-clean))
|
|
(let ((repo-pkgs (build-pkg-list repo folder #f)))
|
|
(map (lambda (pkg)
|
|
(if (not (any (lambda (list-pkg)
|
|
(same-pkg? list-pkg pkg))
|
|
cache-files-used))
|
|
(begin (if (>= (option-ref options 'verbosity)
|
|
verbosity-warn)
|
|
(begin (display "Absolute pkg ")
|
|
(display (assoc-ref pkg 'category))
|
|
(display "/")
|
|
(display (assoc-ref pkg 'name))
|
|
(display " deleted.")
|
|
(newline)))
|
|
(delete-file (string-join (list repo
|
|
(assoc-ref pkg 'category)
|
|
(assoc-ref pkg 'name))
|
|
file-name-separator-string)))))
|
|
repo-pkgs)))))
|
|
|
|
;; Commit and push the updates to master if requested.
|
|
(if (option-ref options 'remote-push)
|
|
(repo-push-master repo))
|
|
|
|
(display "Completed successfully ...") (newline)))))
|