;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2026 Maxim Cournoyer ;;; ;;; 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 . (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: ;; ). #: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 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!)))))