;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2023 Brian Cully <bjc@spork.org>
;;;
;;; 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 (tests services pam-mount)
  #:use-module (gnu services pam-mount)
  #:use-module (gnu system pam)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix grafts)
  #:use-module (guix store)
  #:use-module (guix tests)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-64))

(define pam-mount-volume-fields (@@ (gnu services pam-mount)
                                    pam-mount-volume-fields))
(define field-name->tag (@@ (gnu services pam-mount)
                            field-name->tag))

(define pam-mount-volume->sxml (@@ (gnu services pam-mount)
                                   pam-mount-volume->sxml))

(test-begin "services-pam-mount")

(test-group "field-name->tag"
  (let ((field-map '((user-name user)
                     (user-id uid)
                     (primary-group pgrp)
                     (group-id gid)
                     (secondary-group sgrp)
                     (file-system-type fstype)
                     (no-mount-as-root? noroot)
                     (server server)
                     (file-name path)
                     (mount-point mountpoint)
                     (options options)
                     (ssh? ssh)
                     (cipher cipher)
                     (file-system-key-cipher fskeycipher)
                     (file-system-key-hash fskeyhash)
                     (file-system-key-file-name fskeypath))))

    (test-equal "all fields accounted for"
      (map car field-map)
      (map configuration-field-name pam-mount-volume-fields))

    (for-each (match-lambda
                ((field-name tag-name)
                 (test-eq (format #f "~a -> ~a" field-name tag-name)
                   (field-name->tag field-name) tag-name)))
              field-map)))

(let ((tmpfs-volume (pam-mount-volume
                     (secondary-group "users")
                     (file-system-type "tmpfs")
                     (mount-point "/run/user/%(USERUID)")
                     (options "someoptions"))))
  (test-equal "tmpfs"
    '(volume (@ (sgrp "users")
                (fstype "tmpfs")
                (mountpoint "/run/user/%(USERUID)")
                (options "someoptions")))
    (pam-mount-volume->sxml tmpfs-volume)))

(test-end "services-pam-mount")
generated by cgit
ct? line) acc) ((string-prefix? "(" line) (loop (cons (cons number ;line number (- (ftell port) (string-length line) 1)) ;offset acc) (1+ number))) (else (loop acc (1+ number))))))) (define (surrounding-sexp port target-line-no) "Return the top-level S-expression surrounding the change at line number TARGET-LINE-NO in PORT." (let* ((line-numbers+offsets (lines+offsets-with-opening-parens port)) (closest-offset (or (and=> (list-index (match-lambda ((line-number . offset) (< line-number target-line-no))) line-numbers+offsets) (lambda (index) (match (list-ref line-numbers+offsets index) ((line-number . offset) offset)))) (error "Could not find surrounding S-expression for line" target-line-no)))) (seek port closest-offset SEEK_SET) (read port))) ;;; Whether the hunk contains a newly added package (definition), a removed ;;; package (removal) or something else (#false). (define hunk-types '(addition removal #false)) (define-record-type <hunk> (make-hunk file-name old-line-number new-line-number diff-lines type) hunk? (file-name hunk-file-name) ;; Line number before the change (old-line-number hunk-old-line-number) ;; Line number after the change (new-line-number hunk-new-line-number) ;; The full diff to be used with "git apply --cached" (diff-lines hunk-diff-lines) ;; Does this hunk add or remove a package? (type hunk-type)) ;one of 'hunk-types' (define* (hunk->patch hunk #:optional (port (current-output-port))) (let ((file-name (hunk-file-name hunk))) (format port "diff --git a/~a b/~a~%--- a/~a~%+++ b/~a~%~a" file-name file-name file-name file-name (string-join (hunk-diff-lines hunk) "")))) (define (diff-info) "Read the diff and return a list of <hunk> values." (let ((port (open-pipe* OPEN_READ "git" "diff-files" "--no-prefix" ;; Only include one context line to avoid lumping in ;; new definitions with changes to existing ;; definitions. "--unified=1" "--" "gnu"))) (define (extract-line-number line-tag) (abs (string->number (car (string-split line-tag #\,))))) (define (read-hunk) (let loop ((lines '()) (type #false)) (let ((line (read-line port 'concat))) (cond ((eof-object? line) (values (reverse lines) type)) ((or (string-prefix? "@@ " line) (string-prefix? "diff --git" line)) (unget-string port line) (values (reverse lines) type)) (else (loop (cons line lines) (or type (cond ((string-prefix? "+(define" line) 'addition) ((string-prefix? "-(define" line) 'removal) (else #false))))))))) (define info (let loop ((acc '()) (file-name #f)) (let ((line (read-line port))) (cond ((eof-object? line) acc) ((string-prefix? "--- " line) (match (string-split line #\space) ((_ file-name) (loop acc file-name)))) ((string-prefix? "@@ " line) (match (string-split line #\space) ((_ old-start new-start . _) (let-values (((diff-lines type) (read-hunk))) (loop (cons (make-hunk file-name (extract-line-number old-start) (extract-line-number new-start) (cons (string-append line "\n") diff-lines) type) acc) file-name))))) (else (loop acc file-name)))))) (close-pipe port) info)) (define (lines-to-first-change hunk) "Return the number of diff lines until the first change." (1- (count (lambda (line) ((negate char-set-contains?) (char-set #\+ #\-) (string-ref line 0))) (hunk-diff-lines hunk)))) (define %original-file-cache (make-hash-table)) (define (read-original-file file-name) "Return the contents of FILE-NAME prior to any changes." (let* ((port (open-pipe* OPEN_READ "git" "cat-file" "-p" (string-append "HEAD:" file-name))) (contents (get-string-all port))) (close-pipe port) contents)) (define (read-original-file* file-name) "Caching variant of READ-ORIGINAL-FILE." (or (hashv-ref %original-file-cache file-name) (let ((value (read-original-file file-name))) (hashv-set! %original-file-cache file-name value) value))) (define (old-sexp hunk) "Using the diff information in HUNK return the unmodified S-expression corresponding to the top-level definition containing the staged changes." ;; TODO: We can't seek with a pipe port... (call-with-input-string (read-original-file* (hunk-file-name hunk)) (lambda (port) (surrounding-sexp port (+ (lines-to-first-change hunk) (hunk-old-line-number hunk)))))) (define (new-sexp hunk) "Using the diff information in HUNK return the modified S-expression corresponding to the top-level definition containing the staged changes." (call-with-input-file (hunk-file-name hunk) (lambda (port) (surrounding-sexp port (+ (lines-to-first-change hunk) (hunk-new-line-number hunk)))))) (define* (change-commit-message file-name old new #:optional (port (current-output-port))) "Print ChangeLog commit message for changes between OLD and NEW." (define (get-values expr field) (match ((xpath:node-or (xpath:sxpath `(*any* *any* package ,field quasiquote *)) ;; For let binding (xpath:sxpath `(*any* *any* (*any*) package ,field quasiquote *))) (cons '*TOP* expr)) (() ;; New-style plain lists (match ((xpath:node-or (xpath:sxpath `(*any* *any* package ,field list *)) ;; For let binding (xpath:sxpath `(*any* *any* (*any*) package ,field list *))) (cons '*TOP* expr)) ((inner) inner) (_ '()))) ;; Old-style labelled inputs ((first . rest) (map cadadr first)))) (define (listify items) (match items ((one) one) ((one two) (string-append one " and " two)) ((one two . more) (string-append (string-join (drop-right items 1) ", ") ", and " (first (take-right items 1)))))) (define variable-name (second old)) (define version (and=> ((xpath:node-or (xpath:sxpath '(*any* *any* package version *any*)) ;; For let binding (xpath:sxpath '(*any* *any* (*any*) package version *any*))) (cons '*TOP* new)) first)) (format port "gnu: ~a: Update to ~a.~%~%* ~a (~a): Update to ~a.~%" variable-name version file-name variable-name version) (for-each (lambda (field) (let ((old-values (get-values old field)) (new-values (get-values new field))) (or (equal? old-values new-values) (let ((removed (lset-difference equal? old-values new-values)) (added (lset-difference equal? new-values old-values))) (format port "[~a]: ~a~%" field (break-string ;; A dependency can be a list of (pkg output). (match (list (map object->string removed) (map object->string added)) ((() added) (format #f "Add ~a." (listify added))) ((removed ()) (format #f "Remove ~a." (listify removed))) ((removed added) (format #f "Remove ~a; add ~a." (listify removed) (listify added)))))))))) '(inputs propagated-inputs native-inputs))) (define* (add-commit-message file-name variable-name #:optional (port (current-output-port))) "Print ChangeLog commit message for a change to FILE-NAME adding a definition." (format port "gnu: Add ~a.~%~%* ~a (~a): New variable.~%" variable-name file-name variable-name)) (define* (remove-commit-message file-name variable-name #:optional (port (current-output-port))) "Print ChangeLog commit message for a change to FILE-NAME removing a definition." (format port "gnu: Remove ~a.~%~%* ~a (~a): Delete variable.~%" variable-name file-name variable-name)) (define* (custom-commit-message file-name variable-name message changelog #:optional (port (current-output-port))) "Print custom commit message for a change to VARIABLE-NAME in FILE-NAME, using MESSAGE as the commit message and CHANGELOG as the body of the ChangeLog entry. If CHANGELOG is #f, the commit message is reused. If CHANGELOG already contains ': ', no colon is inserted between the location and body of the ChangeLog entry." (define (trim msg) (string-trim-right (string-trim-both msg) (char-set #\.))) (define (changelog-has-location? changelog) (->bool (string-match "^[[:graph:]]+:[[:blank:]]" changelog))) (let* ((message (trim message)) (changelog (if changelog (trim changelog) message)) (message/f (format #f "gnu: ~a: ~a." variable-name message)) (changelog/f (if (changelog-has-location? changelog) (format #f "* ~a (~a)~a." file-name variable-name changelog) (format #f "* ~a (~a): ~a." file-name variable-name changelog)))) (format port "~a~%~%~a~%" (break-string-with-newlines message/f 72) (break-string-with-newlines changelog/f 72)))) (define (add-copyright-line line) "Add the copyright line on LINE to the previous commit." (let ((author (match:substring (string-match "^\\+;;; Copyright ©[^[:alpha:]]+(.*)$" line) 1))) (format (current-output-port) "Amend and add copyright line for ~a~%" author) (system* "git" "commit" "--amend" "--no-edit"))) (define (group-hunks-by-sexp hunks) "Return a list of pairs associating all hunks with the S-expression they are modifying." (fold (lambda (sexp hunk acc) (match acc (((previous-sexp . hunks) . rest) (if (equal? sexp previous-sexp) (cons (cons previous-sexp (cons hunk hunks)) rest) (cons (cons sexp (list hunk)) acc))) (_ (cons (cons sexp (list hunk)) acc)))) '() (map new-sexp hunks) hunks)) (define (new+old+hunks hunks) (map (match-lambda ((new . hunks) (cons* new (old-sexp (first hunks)) hunks))) (group-hunks-by-sexp hunks))) (define %delay 1000) (define (main . args) (define* (change-commit-message* file-name old new #:rest rest) (let ((changelog #f)) (match args ((or (message changelog) (message)) (apply custom-commit-message file-name (second old) message changelog rest)) (_ (apply change-commit-message file-name old new rest))))) (read-disable 'positions) (match (diff-info) (() (display "Nothing to be done.\n" (current-error-port))) (hunks (let-values (((definitions changes) (partition hunk-type hunks))) ;; Additions/removals. (for-each (lambda (hunk) (and-let* ((define-line (find (cut string-match "(\\+|-)\\(define" <>) (hunk-diff-lines hunk))) (variable-name (and=> (string-tokenize define-line) second)) (commit-message-proc (match (hunk-type hunk) ('addition add-commit-message) ('removal remove-commit-message)))) (commit-message-proc (hunk-file-name hunk) variable-name) (let ((port (open-pipe* OPEN_WRITE "git" "apply" "--cached" "--unidiff-zero"))) (hunk->patch hunk port) (unless (eqv? 0 (status:exit-val (close-pipe port))) (error "Cannot apply"))) (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) (commit-message-proc (hunk-file-name hunk) variable-name port) (usleep %delay) (unless (eqv? 0 (status:exit-val (close-pipe port))) (error "Cannot commit")))) (usleep %delay)) definitions) ;; Changes. (for-each (match-lambda ((new old . hunks) (for-each (lambda (hunk) (let ((port (open-pipe* OPEN_WRITE "git" "apply" "--cached" "--unidiff-zero"))) (hunk->patch hunk port) (unless (eqv? 0 (status:exit-val (close-pipe port))) (error "Cannot apply"))) (usleep %delay)) hunks) (define copyright-line (any (lambda (line) (and=> (string-prefix? "+;;; Copyright ©" line) (const line))) (hunk-diff-lines (first hunks)))) (cond (copyright-line (add-copyright-line copyright-line)) (else (let ((port (open-pipe* OPEN_WRITE "git" "commit" "-F" "-"))) (change-commit-message* (hunk-file-name (first hunks)) old new) (change-commit-message* (hunk-file-name (first hunks)) old new port) (usleep %delay) (unless (eqv? 0 (status:exit-val (close-pipe port))) (error "Cannot commit"))))))) (new+old+hunks (match definitions ('() changes) ;reuse (_ ;; XXX: we recompute the hunks here because previous ;; insertions lead to offsets. (let-values (((definitions changes) (partition hunk-type (diff-info)))) changes))))))))) (apply main (cdr (command-line)))
generated by cgit