332 lines
14 KiB
Scheme
332 lines
14 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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 (ice-9 pretty-print)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (git bindings)
|
|
#:use-module (git repository)
|
|
#:use-module (git clone)
|
|
#:use-module (git checkout)
|
|
#:use-module (git submodule)
|
|
#: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))))
|
|
|
|
(define-public repo-clone
|
|
(lambda (url folder)
|
|
""
|
|
(clone url folder)))
|
|
|
|
(define-public repo-update-src
|
|
(lambda (path)
|
|
""
|
|
(let ((repo (submodule-lookup (repository-open path)
|
|
"autogen"))
|
|
(old-cwd (getcwd)))
|
|
;;Not working for updates only init?
|
|
;;(submodule-update repo)
|
|
(system* "/usr/bin/git" "submodule" "update" "autogen")
|
|
(chdir (string-join (list path "autogen")
|
|
file-name-separator-string))
|
|
(system* "/usr/bin/git" "checkout" "main")
|
|
(chdir old-cwd))))
|
|
|
|
;; TODO guile-git method...
|
|
;; https://stackoverflow.com/questions/572549/difference-between-git-add-a-and-git-add
|
|
(define-public repo-push-master
|
|
(lambda (path)
|
|
""
|
|
(chdir path)
|
|
(system* "/usr/bin/git" "add" "-A")
|
|
(system* "/usr/bin/git" "commit" "-m" "ebuild-autogen update")
|
|
(system* "/usr/bin/git" "push" "origin" "master")))
|
|
|
|
(define-public cp-repo-file
|
|
(lambda* (repo folder-dst folder-src file verbosity #:key
|
|
(file-dst file)
|
|
(sub-folder ""))
|
|
""
|
|
(let ((file-in (string-join (list repo folder-src file)
|
|
file-name-separator-string))
|
|
(file-out (string-join (list repo folder-dst file-dst)
|
|
file-name-separator-string))
|
|
(for-each-file
|
|
(lambda (files)
|
|
(append-map (lambda (sub-file)
|
|
(if (not (char=? (car (string->list sub-file)) #\.))
|
|
(cp-repo-file repo
|
|
(string-join (list folder-dst file-dst)
|
|
file-name-separator-string)
|
|
(string-join (list folder-src file)
|
|
file-name-separator-string)
|
|
sub-file
|
|
verbosity
|
|
#:sub-folder (string-join (if (string=? sub-folder "")
|
|
(list file)
|
|
(list sub-folder file))
|
|
file-name-separator-string))
|
|
'()))
|
|
files)))
|
|
(finish (lambda ()
|
|
(if (string-suffix? ".ebuild" file-dst)
|
|
(system* "ebuild"
|
|
(string-join (list folder-dst
|
|
file-dst)
|
|
file-name-separator-string)
|
|
"manifest"))
|
|
(list (string-join (if (string=? sub-folder "")
|
|
(list file-dst)
|
|
(list sub-folder file))
|
|
file-name-separator-string)))))
|
|
(if (eq? (stat:type (stat file-in)) 'directory)
|
|
(if (file-exists? file-out)
|
|
(if (eq? (stat:type (stat file-out)) 'directory)
|
|
(for-each-file (scandir file-in))
|
|
(begin (if (>= verbosity verbosity-critical)
|
|
(begin (display "warning: \"")
|
|
(display file-in)
|
|
(display "\" not a folder and won't ")
|
|
(display "represent autogen source data!")
|
|
(newline)))
|
|
'()))
|
|
(begin (mkdir file-out)
|
|
(for-each-file (scandir file-in))))
|
|
(begin (if (file-exists? file-out)
|
|
(let* ((port-in (open-input-file file-in))
|
|
(port-out (open-input-file file-out))
|
|
(data-in (get-string-all port-in))
|
|
(data-out (get-string-all port-out)))
|
|
(close port-in)
|
|
(close port-out)
|
|
(if (diff? data-in data-out)
|
|
(let ((output-port (open-output-file file-out)))
|
|
(if (>= verbosity verbosity-warn)
|
|
(begin (display "Destination differs for \"")
|
|
(display file)
|
|
(display "\" overriding.")
|
|
(newline)))
|
|
(display data-in output-port)
|
|
(close output-port))
|
|
(finish)))
|
|
(copy-file file-in file-out))
|
|
(finish))))))
|
|
|
|
(define-public folder-list
|
|
(lambda (path ignore-meta)
|
|
""
|
|
(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))))
|
|
(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.
|
|
(if (file-exists? dst-path)
|
|
(if (>= (assoc-ref parms 'verbosity) verbosity-notice)
|
|
(begin (display "Folder for ")
|
|
(display (assoc-ref parms 'category))
|
|
(display "/")
|
|
(display (assoc-ref parms 'name))
|
|
(display " already exist.")
|
|
(newline)))
|
|
(mkpath dst-path))
|
|
;;cp each ebuild and the files folder.
|
|
(let ((test (append-map
|
|
(lambda (file)
|
|
(let ((ret (cp-repo-file
|
|
(assoc-ref parms 'repo)
|
|
(string-join (list (assoc-ref parms 'category)
|
|
(assoc-ref parms 'name))
|
|
file-name-separator-string)
|
|
(string-join (list "autogen"
|
|
(assoc-ref parms 'category)
|
|
(assoc-ref parms 'name))
|
|
file-name-separator-string)
|
|
file
|
|
(assoc-ref parms 'verbosity))))
|
|
ret))
|
|
(filter-map
|
|
(lambda (file)
|
|
(if (irregex-search '(or (seq bos "files" eos)
|
|
(seq ".ebuild" eos ))
|
|
file)
|
|
file
|
|
#f))
|
|
(scandir src-path)))))
|
|
test)
|
|
)))
|
|
|
|
(define-public clean-files
|
|
(lambda (file-list file-folder verbosity)
|
|
(letrec* ((for-each-file
|
|
(lambda (sub-path)
|
|
(append-map
|
|
(lambda (file)
|
|
(let ((path (string-join (list file-folder sub-path file)
|
|
file-name-separator-string)))
|
|
(if (not (or (char=? (car (string->list file)) #\.)
|
|
(string=? file "Manifest")))
|
|
(if (eq? (stat:type (stat path)) 'directory)
|
|
(for-each-file (string-join (if (string=? sub-path "")
|
|
(list file)
|
|
(list sub-path file))
|
|
file-name-separator-string))
|
|
(list (string-join (if (string=? sub-path "")
|
|
(list file)
|
|
(list sub-path file))
|
|
file-name-separator-string)))
|
|
'())))
|
|
(scandir (string-join (list file-folder sub-path)
|
|
file-name-separator-string))))))
|
|
;; (display "file-list:") (newline)
|
|
;; (pretty-print file-list)
|
|
;; (display "each-file:") (newline)
|
|
;; (pretty-print (for-each-file ""))
|
|
;; (display "to-clean:") (newline)
|
|
;; (pretty-print (filter-map (lambda (file)
|
|
;; (if (any (lambda (a)
|
|
;; (string=? a file))
|
|
;; file-list)
|
|
;; #false file))
|
|
;; (for-each-file "")))
|
|
(for-each (lambda (absolute-file)
|
|
(if (>= verbosity verbosity-notice)
|
|
(begin (display "Cleaned absolute file \"")
|
|
(display absolute-file) (display "\"")
|
|
(newline)))
|
|
(delete-file (string-join (list file-folder absolute-file)
|
|
file-name-separator-string)))
|
|
(filter-map (lambda (file)
|
|
(if (any (lambda (a)
|
|
(string=? a file))
|
|
file-list)
|
|
#false file))
|
|
(for-each-file ""))))))
|