ebuild-autogen/ebuild/repo.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
						 (string-join (take-while
													 (lambda (file)
														 (not (string=? file ".git")))
													 (string-split repo-orig
																				 (car (string->list
																							 file-name-separator-string))))
													file-name-separator-string)))
        (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)
		(chdir folder)
		(system* "/usr/bin/git" "submodule" "update" "--init" "--recursive")
		;; (chdir (string-join (list folder "autogen")
		;; 										file-name-separator-string))
		;; (system* "/usr/bin/git" "checkout" "main")
		(chdir 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)
			(chdir (string-join (list path "autogen")
													file-name-separator-string))
			(system* "/usr/bin/git" "pull")
			(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 repo
																										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 ""))))))