;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2026 Maxim Cournoyer <maxim@guixotic.coop>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix import gradle)
  #:use-module (gnu packages base)      ;FOR TESTING
  #:use-module (gnu packages java)
  #:use-module ((gnu packages rust-apps) #:select (mitm-cache))
  #:use-module ((gnu packages tls) #:select (openssl))
  #:use-module (gnu system file-systems)
  #:use-module (gnu system linux-container)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module ((guix build utils) #:select (%store-directory))
  #:use-module (guix gexp)
  #:use-module (guix import utils)
  #:use-module (guix modules)
  #:use-module ((guix git) #:select (latest-repository-commit))
  #:use-module (guix store)
   #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:use-module (json)
  ;; FIXME: Switch to properly bootstrapped Guix gradle package (see:
  ;; <https://codeberg.org/guixotic/guix/issues/13>).
  #:use-module ((nongnu packages gradle) #:select (gradle))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:export (cache.json->entries
            gradle-project->cache.json
            gradle-project-url->guix-package))


;;;
;;; mitm-cache JSON file generation.
;;;

(define (gradle-project->cache.json directory)
  "Given DIRECTORY, a directory containing the sources of a Gradle project,
return the @file{cache.json} file produced by the @command{mitm-cache}
command."
  (define directory-name (basename
                          (if (string-suffix? "/" directory)
                              (string-drop-right directory 1)
                              directory)))
  (define cache.json (tmpnam))

  (define home "/home/mitm")

  (define mappings
    (append (list (file-system-mapping
                    (source cache.json)
                    (target (string-append home "/cache.json"))
                    (writable? #t))
                  (file-system-mapping
                    (source directory)
                    (target source))
                  ;; TLS certificates are required.
                  (file-system-mapping
                    (source "/etc/ssl")
                    (target source))
                  ;; This is to expose the symbolic link targets of the certs.
                  (file-system-mapping
                    (source (%store-directory))
                    (target source))
                  ;; For debugging.
                  ;; (file-system-mapping
                  ;;   (source "/bin/sh")
                  ;;   (target source))
                  )
            %network-file-mappings))

  (define mounts
    (list (file-system                  ;writable home
            (device "none")
            (mount-point home)
            (type "tmpfs")
            (options "mode=700")
            (check? #f))
          %writable-/tmp))              ;/tmp is required by Gradle

  (define build
    (with-imported-modules (source-module-closure
                            '((guix build synchronization)
                              (guix build gradle-build-system)))
      #~(begin
          (use-modules (guix build gradle-build-system)
                       (guix build utils)
                       (ice-9 match))
          (setenv "PATH" (string-join (list #$(file-append coreutils "/bin")
                                            #$(file-append findutils "/bin")
                                            #$(file-append gradle "/bin")
                                            #$(file-append mitm-cache "/bin")
                                            #$(file-append openssl "/bin")
                                            #$(file-append openjdk24 "/bin"))
                                      ":"))
          (setenv "SSL_CERT_DIR" "/etc/ssl/certs")
          (setenv "SSL_CERT_FILE" "/etc/ssl/certs/ca-certificates.crt")

          (define start-mitm-cache
            (assoc-ref %standard-phases 'start-mitm-cache))

          (define stop-mitm-cache
            (assoc-ref %standard-phases 'stop-mitm-cache))

          (define build
            (assoc-ref %standard-phases 'build))

          (chdir #$home)                ;run in writable HOME
          (start-mitm-cache #:mode 'record)

          (let ((source (string-append #$home "/source")))
            (mkdir source)
            (copy-recursively #$directory source)
            (with-directory-excursion source
              (build)))

          (stop-mitm-cache))))

  (dynamic-wind
    (lambda ()
      (call-with-output-file cache.json (const #t)))
    (lambda ()
      (with-store store
        (unless (zero? (run-with-store store
                         (eval/container build
                                         #:mappings mappings
                                         #:mounts mounts
                                         #:namespaces
                                         (delq 'net %namespaces))))
          (error "failed to compute cache.json"))
        (add-to-store store (string-append directory-name "-cache.json")
                      #f "sha256" cache.json)))
    (lambda ()
      (delete-file cache.json))))


;;;
;;; mitm-cache JSON file parsing.
;;;

(define (sha256->nix-base32-hash hash)
  "Return the Nix base32 hash variant from a sha256 raw HASH."
  (bytevector->nix-base32-string
   (base64-decode (string-drop hash (string-length "sha256-")))))

;;; Avoid inlining to allow whitebox testing.
(set! sha256->nix-base32-hash sha256->nix-base32-hash)

(define (cache.json->entries file)
  "Parse FILE into a list of corresponding (URL . HASH) pairs.
The \"redirect\" entries are fully resolved so that a redirected URL points to
the final hash."
  (define call-with-input-file-or-port  ;to ease testing
    (if (port? file)
        call-with-port
        call-with-input-file))

  (define cache (call-with-input-file-or-port file json->scm))

  (define parse-item
    (match-lambda
      (((? (cut string-prefix? "!" <>)) . _)
       #f)                              ;!version or other metadata
      (((? string? url) ("hash" .
                         (? (cut string-prefix? "sha256-" <>) hash)))
       (cons url (sha256->nix-base32-hash hash)))
      (((? string? url) ("redirect" . (? string? redirect-url)))
        ;; Recurse to resolve redirect entries, if they exist.
        (and=> (assoc redirect-url cache) parse-item))
       (other (error "unexpected entry" other))))

  (filter-map parse-item cache))


;;;
;;; Guix package sexp generation.
;;;
 
 (define (cache-entry->name+origin entry)
   "Given ENTRY a (URL . HASH) pair, return a variable name and an <origin> sexp
 as a pair."
   (match entry
     ((url . hash)
      (let ((name (string->symbol
                   (downstream-package-name "gradle-blob-" (basename url)))))
        (cons name
              `(define ,name
                 (origin
                   (uri ,url)
                   (method url-fetch)
                   (sha256
                    (base32
                     ,hash))
                   (file-name
                    ;; XXX: We try to get away with a simple scheme for now.
                    ,(begin
                       (when (string-contains url "|")
                         (error "don't know how to encode URL"))
                       (string-append
                        "{grable-blob}"
                        (string-replace-substring url "/" "|")))))))))))
 
 (define (cache-entries->names+origins entries)
   "Return the name-sorted list of (NAME . SEXP) pairs, as produced by
 `cache-entry->name+origin'."
   (sort (map cache-entry->name+origin entries)
         (lambda (x y)
           (let ((name-x (symbol->string (car x)))
                 (name-y (symbol->string (car y))))
             (string>? name-x name-y)))))
 
(define (gradle-project-url->guix-package url)
  "Given URL, expected to point to the Git
source of a Gradle project, return a Guix package S-expression."
  ;; TODO: Handle file URIs too.
  (let* ((sha1 checkout hash (download-git-repository
                              url
                              ;; TODO: Support passing a commit-or-tag string.
                              '()
                              ;; Always do a recursive checkout, so that
                              ;; Gradle has access to everything.
                              #:recursive? #t))
          (cache.json (gradle-project->cache.json checkout))
          (entries (cache.json->entries cache.json))
          (names+origins (cache-entries->names+origins entries))
          (names (map car names+origins))
          (origin-sexps (map cdr names+origins)))
     `(begin
        ,@origin-sexps
        (package
          (name ,(basename url))
          (version "0.0.0")        ;TODO: Use tag if provided
          ;; TODO: Use tag if provided instead of sha1
          (source ,(git-origin url sha1 hash))
          (build-system gradle-build-system)
          (native-inputs (list ,@names))
          (synopsis find-by-yourself!)
          (description find-by-yourself!)
          (home-page ,url)
          (license find-by-yourself!)))))

Generated by apteryx using scpaste at Fri Jan 16 17:27:38 2026. JST. (original)