tests/base32.scm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.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 (test-base32)
  #:use-module (guix hash)
  #:use-module (guix base32)
  #:use-module (guix utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

;; Test the (guix base32) module.

(define %nix-hash
  (or (and=> (getenv "NIX_HASH")
             (match-lambda
              ("" #f)
              (val val)))
      "nix-hash"))

(define %have-nix-hash?
  ;; Note: Use `system', not `system*', because of <http://bugs.gnu.org/13166>.
  (false-if-exception
   (zero? (system (string-append %nix-hash " --version")))))

(test-begin "base32")

(test-assert "bytevector->base32-string"
  (fold (lambda (bv expected result)
          (and result
               (string=? (bytevector->base32-string bv)
                         expected)))
        #t

        ;; Examples from RFC 4648.
        (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))
        '(""
          "my"
          "mzxq"
          "mzxw6"
          "mzxw6yq"
          "mzxw6ytb"
          "mzxw6ytboi")))

(test-assert "base32-string->bytevector"
  (every (lambda (bv)
           (equal? (base32-string->bytevector
                    (bytevector->base32-string bv))
                   bv))
         ;; Examples from RFC 4648.
         (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))

(test-assert "nix-base32-string->bytevector"
  (every (lambda (bv)
           (equal? (nix-base32-string->bytevector
                    (bytevector->nix-base32-string bv))
                   bv))
         ;; Examples from RFC 4648.
         (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))

(test-equal "&invalid-base32-character"
  #\e
  (guard (c ((invalid-base32-character? c)
             (invalid-base32-character-value c)))
    (nix-base32-string->bytevector
     (string-append (make-string 51 #\a) "e"))))

;; The following test requires `nix-hash' in $PATH.
(unless %have-nix-hash?
  (test-skip 1))

(test-assert "sha256 & bytevector->nix-base32-string"
  (let ((file (search-path %load-path "tests/test.drv")))
    (equal? (bytevector->nix-base32-string
             (sha256 (call-with-input-file file get-bytevector-all)))
            (let* ((c (format #f "~a --type sha256 --base32 --flat \"~a\""
                              %nix-hash file))
                   (p (open-input-pipe c))
                   (l (read-line p)))
              (close-pipe p)
              l))))

(test-end)
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.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-style)
  #:use-module (guix read-print)
  #:use-module (guix gexp)                        ;for the reader extensions
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define-syntax-rule (test-pretty-print str args ...)
  "Test equality after a round-trip where STR is passed to
'read-with-comments' and the resulting sexp is then passed to
'pretty-print-with-comments'."
  (test-equal str
    (call-with-output-string
      (lambda (port)
        (let ((exp (call-with-input-string str
                     read-with-comments)))
         (pretty-print-with-comments port exp args ...))))))

(define-syntax-rule (test-pretty-print/sequence str args ...)
  "Likewise, but read and print entire sequences rather than individual
expressions."
  (test-equal str
    (call-with-output-string
      (lambda (port)
        (let ((lst (call-with-input-string str
                     read-with-comments/sequence)))
         (pretty-print-with-comments/splice port lst args ...))))))


(test-begin "read-print")

(test-assert "read-with-comments: missing closing paren"
  (guard (c ((error? c) #t))
    (call-with-input-string "(what is going on?"
      read-with-comments)))

(test-equal "read-with-comments: dot notation"
  (cons 'a 'b)
  (call-with-input-string "(a . b)"
    read-with-comments))

(test-equal "read-with-comments: half dot notation"
  '(lambda x x)
  (call-with-input-string "(lambda (. x) x)"
    read-with-comments))

(test-equal "read-with-comments: list with blank line"
  `(list with ,(vertical-space 1) blank line)
  (call-with-input-string "\
(list with

      blank line)\n"
    read-with-comments))

(test-equal "read-with-comments: list with multiple blank lines"
  `(list with ,(comment ";multiple\n" #t)
         ,(vertical-space 3) blank lines)
  (call-with-input-string "\
(list with ;multiple


      blank lines)\n"
    read-with-comments))

(test-equal "read-with-comments: top-level blank lines"
  (list (vertical-space 2) '(a b c) (vertical-space 2))
  (call-with-input-string "

(a b c)\n\n"
    (lambda (port)
      (list (read-with-comments port)
            (read-with-comments port)
            (read-with-comments port)))))

(test-equal "read-with-comments: top-level page break"
  (list (comment ";; Begin.\n") (vertical-space 1)
        (page-break)
        (comment ";; End.\n"))
  (call-with-input-string "\
;; Begin.


;; End.\n"
    (lambda (port)
      (list (read-with-comments port)
            (read-with-comments port)
            (read-with-comments port)
            (read-with-comments port)))))

(test-pretty-print "(list 1 2 3 4)")
(test-pretty-print "((a . 1) (b . 2))")
(test-pretty-print "(a b c . boom)")
(test-pretty-print "(list 1
                          2
                          3
                          4)"
                   #:long-list 3
                   #:indent 20)
(test-pretty-print "\
(list abc
      def)"
                   #:max-width 11)
(test-pretty-print "\
(#:foo
 #:bar)"
                   #:max-width 10)

(test-pretty-print "\
(#:first 1
 #:second 2
 #:third 3)")

(test-pretty-print "\
((x
  1)
 (y
  2)
 (z
  3))"
                   #:max-width 3)

(test-pretty-print "\
(let ((x 1)
      (y 2)
      (z 3)
      (p 4))
  (+ x y))"
                   #:max-width 11)

(test-pretty-print "\
(begin
  1+ 1- 123/ 456*
  (1+ 41))")

(test-pretty-print "\
(lambda (x y)
  ;; This is a procedure.
  (let ((z (+ x y)))
    (* z z)))")

(test-pretty-print "\
(case x
  ((1)
   'one)
  ((2)
   'two))")

(test-pretty-print "\
(cond
  ((zero? x)
   'zero)
  ((odd? x)
   'odd)
  (else #f))")

(test-pretty-print "\
#~(string-append #$coreutils \"/bin/uname\")")

(test-pretty-print "\
(package
  (inherit coreutils)
  (version \"42\"))")

(test-pretty-print "\
(modify-phases %standard-phases
  (add-after 'unpack 'post-unpack
    (lambda _
      #t))
  (add-before 'check 'pre-check
    (lambda* (#:key inputs #:allow-other-keys)
      do things ...)))")

(test-pretty-print "\
(#:phases (modify-phases sdfsdf
            (add-before 'x 'y
              (lambda _
                xyz))))")

(test-pretty-print "\
(string-append \"a\\tb\" \"\\n\")")

(test-pretty-print "\
(display \"This is a very long string.
It contains line breaks, which are preserved,
because it's a long string.\")")

(test-pretty-print "\
(description \"abcdefghijkl
mnopqrstuvwxyz.\")"
                   #:max-width 30)

(test-pretty-print "\
(description
 \"abcdefghijkl
mnopqrstuvwxyz.\")"
                   #:max-width 12)

(test-pretty-print "\
(description
 \"abcdefghijklmnopqrstuvwxyz\")"
                   #:max-width 33)

(test-pretty-print "\
(list ;margin comment
      a b c)")

(test-pretty-print "\
(list
 ;; This is a line comment immediately following the list head.
 #:test-flags #~(list \"-m\" \"not external and not samples\"))")

(test-pretty-print "\
(modify-phases %standard-phases
  (replace 'build
    ;; Nicely indented in 'modify-phases' context.
    (lambda _
      #t)))")

(test-pretty-print "\
(modify-inputs inputs
  ;; Regular indentation for 'replace' here.
  (replace \"gmp\" gmp))")

(test-pretty-print "\
#~(modify-phases phases
    (add-after 'whatever 'something-else
      (lambda _
        ;; This comment appears inside a gexp.
        42)))")

(test-pretty-print "\
#~(list #$@(list coreutils ;yup
                 grep) ;margin comment
        #+sed

        ;; Line comment.
        #$grep)")

(test-pretty-print "\
(package
  ;; Here 'sha256', 'base32', and 'arguments' must be
  ;; immediately followed by a newline.
  (source (origin
            (method url-fetch)
            (sha256
             (base32
              \"not a real base32 string\"))))
  (arguments
   '(#:phases %standard-phases
     #:tests? #f)))")

;; '#:key value' is kept on the same line.
(test-pretty-print "\
(package
  (name \"keyword-value-same-line\")
  (arguments
   (list #:phases #~(modify-phases %standard-phases
                      (add-before 'x 'y
                        (lambda* (#:key inputs #:allow-other-keys)
                          (foo bar baz))))
         #:make-flags #~'(\"ANSWER=42\")
         #:tests? #f)))")

(test-pretty-print "\
(let ((x 1)
      (y 2)
      (z (let* ((a 3)
                (b 4))
           (+ a b))))
  (list x y z))")

(test-pretty-print "\
(begin
  (chmod \"foo\" #o750)
  (chmod port
         (logand #o644
                 (lognot (umask))))
  (logand #x7f xyz))")

(test-pretty-print "\
(substitute-keyword-arguments (package-arguments x)
  ((#:phases phases)
   `(modify-phases ,phases
      (add-before 'build 'do-things
        (lambda _
          #t))))
  ((#:configure-flags flags)
   `(cons \"--without-any-problem\"
          ,flags)))")

(test-pretty-print "\
(vertical-space one:

                two:


                three:


                end)")

(test-pretty-print "\
(vertical-space one

                ;; Comment after blank line.
                two)")

(test-pretty-print "\
(begin
  break

  ;; page break above
  end)")

(test-pretty-print "\
(home-environment
  (services
   (list (service-type home-bash-service-type))))")

(test-pretty-print/sequence "\
;;; This is a top-level comment.


;; Above is a page break.
(this is an sexp
      ;; with a comment
      !!)

;; The end.\n")

(test-pretty-print/sequence "
;;; Hello!
;;; Notice that there are three semicolons here.

(define-module (foo bar)
  #:use-module (guix)
  #:use-module (gnu))


;; And now, the OS.
(operating-system
  (host-name \"komputilo\")
  (locale \"eo_EO.UTF-8\")

  (services
   (cons (service mcron-service-type) %base-services)))\n"
                            #:format-comment canonicalize-comment)

(test-equal "pretty-print-with-comments, canonicalize-comment"
  "\
(list abc
      ;; Not a margin comment.
      ;; Ditto.
      ;;
      ;; There's a blank line above.
      def ;margin comment
      ghi)"
  (let ((sexp (call-with-input-string
                  "\
(list abc
  ;Not a margin comment.
  ;;;  Ditto.
  ;;;;;
  ; There's a blank line above.
  def  ;; margin comment
  ghi)"
                read-with-comments)))
    (call-with-output-string
      (lambda (port)
        (pretty-print-with-comments port sexp
                                    #:format-comment
                                    canonicalize-comment)))))

(test-equal "pretty-print-with-comments, canonicalize-vertical-space"
  "\
(list abc

      def

      ;; last one
      ghi)"
  (let ((sexp (call-with-input-string
                  "\
(list abc


  def


;; last one
  ghi)"
                read-with-comments)))
    (call-with-output-string
      (lambda (port)
        (pretty-print-with-comments port sexp
                                    #:format-vertical-space
                                    canonicalize-vertical-space)))))

(test-equal "pretty-print-with-comments, multi-line comment"
  "\
(list abc
      ;; This comment spans
      ;; two lines.
      def)"
  (call-with-output-string
    (lambda (port)
      (pretty-print-with-comments port
                                  `(list abc ,(comment "\
;; This comment spans\n
;; two lines.\n")
                                         def)))))

(test-end)