;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012-2016, 2018-2022 Ludovic Courtès ;;; ;;; 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 (test-records) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (guix records)) (define (te
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2018, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020-2022 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 (gnu packages gsasl)
  #:use-module (gnu packages)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages libidn)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages nettle)
  #:use-module (gnu packages kerberos)
  #:use-module (gnu packages tls)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system gnu))

(define-public libntlm
  (package
    (name "libntlm")
    (version "1.6")
    (source (origin
              (method url-fetch)
              (uri (string-append "https://www.nongnu.org/libntlm/releases/"
                                  "libntlm-" version ".tar.gz"))
              (sha256
               (base32
                "08b83nss16jsn213j326yhn1vnrz10k15fwq6jm5b1vdn23nndzj"))))
    (build-system gnu-build-system)
    (synopsis "Library that implements NTLM authentication")
    (description
     "Libntlm is a library that implements NTLM authentication.")
    (license license:lgpl2.1+)
    (home-page "https://www.nongnu.org/libntlm/")))

(define-public gss
  (package
   (name "gss")
   (version "1.0.4")
   (source (origin
            (method url-fetch)
            (uri (string-append "mirror://gnu/gss/gss-" version
                                ".tar.gz"))
            (sha256 (base32
                     "0www841ax21f5f61pdjk9fjdn9s2xf1wnblb47kzrqyaykgapkpc"))))
   (build-system gnu-build-system)
   (inputs (list nettle shishi zlib))
   (synopsis "Generic Security Service library")
   (description
    "The GNU Generic Security Service provides a free implementation of the
GSS-API specification.  It provides a generic application programming
interface for programs to access security services.  Security services present
a generic, GSS interface, with which the calling application interacts via
this library, freeing the application developer from needing to know about
the underlying security implementation.")
   (license license:gpl3+)
   (home-page "https://www.gnu.org/software/gss/")))

(define-public gsasl
  (package
   (name "gsasl")
   (version "2.2.0")
   (source (origin
            (method url-fetch)
            (uri (string-append "mirror://gnu/gsasl/gsasl-" version
                                ".tar.gz"))
            (sha256
             (base32
              "0nbp62isfdfrsnp34vfkwinfjyw9x05clacvsn2c8vcpp7inif3r"))))
   (build-system gnu-build-system)
   (arguments
    `(#:configure-flags '("--with-gssapi-impl=mit"
                          "--disable-static")))
   (inputs
    (list libgcrypt libidn libntlm mit-krb5 zlib))
   (native-inputs
    (list ;; Needed for cross compiling.
          libgcrypt))
   (propagated-inputs
    ;; Propagate GnuTLS because libgnutls.la reads `-lnettle', and Nettle is a
    ;; propagated input of GnuTLS.
    (list gnutls))
   (synopsis "Simple Authentication and Security Layer library")
   (description
    "GNU SASL is an implementation of the Simple Authentication and
Security Layer framework.  On network servers such as IMAP or SMTP servers,
SASL is used to handle client/server authentication.  This package contains
both a library and a command-line tool to access the library.")
   (license license:gpl3+)
   (home-page "https://www.gnu.org/software/gsasl/")))
it x) (bar -2))) (z (foo (inherit x) (baz -2)))) (and (= -2 (foo-bar y)) (= 0 (foo-baz y)) (= 40 (foo-bar z)) (= -2 (foo-baz z)))))) (test-assert "define-record-type* & thunked & inherit & custom this" (let () (define-record-type* foo make-foo foo? this-foo (thing foo-thing (thunked))) (define-record-type* bar make-bar bar? this-bar (baz bar-baz (thunked))) ;; Nest records and test the two self references. (let* ((x (foo (thing (bar (baz (list this-bar this-foo)))))) (y (foo-thing x))) (match (bar-baz y) ((first second) (and (eq? second x) (bar? first) (eq? first y))))))) (test-assert "define-record-type* & delayed" (begin (define-record-type* foo make-foo foo? (bar foo-bar (delayed))) (let* ((calls 0) (x (foo (bar (begin (set! calls (1+ calls)) 3))))) (and (zero? calls) (equal? (foo-bar x) 3) (= 1 calls) (equal? (foo-bar x) 3) (= 1 calls) (equal? (foo-bar x) 3) (= 1 calls))))) (test-assert "define-record-type* & delayed & default" (let ((mark #f)) (define-record-type* foo make-foo foo? (bar foo-bar (delayed) (default mark))) (let ((x (foo))) (set! mark 42) (and (equal? (foo-bar x) 42) (begin (set! mark 7) (equal? (foo-bar x) 42)))))) (test-assert "define-record-type* & delayed & inherited" (begin (define-record-type* foo make-foo foo? (bar foo-bar (delayed)) (baz foo-baz (delayed))) (let* ((m 1) (n #f) (x (foo (bar m) (baz n))) (y (foo (inherit x) (baz 'b)))) (set! n 'a) (and (equal? (foo-bar x) 1) (eq? (foo-baz x) 'a) (begin (set! m 777) (equal? (foo-bar y) 1)) ;promise was already forced (eq? (foo-baz y) 'b))))) (test-assert "define-record-type* & sanitize" (begin (define-record-type* foo make-foo foo? (bar foo-bar (default "bar") (sanitize (lambda (x) (string-append x "!"))))) (let* ((p (foo)) (q (foo (inherit p))) (r (foo (inherit p) (bar "baz"))) (s (foo (bar "baz")))) (and (string=? (foo-bar p) "bar!") (equal? q p) (string=? (foo-bar r) "baz!") (equal? s r))))) (test-equal "define-record-type* & sanitize without default value" 42 (begin (define-record-type* foo make-foo foo? (bar foo-bar (sanitize 1+))) (foo-bar (foo (bar 41))))) (test-assert "define-record-type* & sanitize & thunked" (let ((sanitized 0)) (define-record-type* foo make-foo foo? (bar foo-bar (default "bar") (sanitize (lambda (x) (set! sanitized (+ 1 sanitized)) (string-append x "!"))))) (let ((p (foo))) (and (string=? (foo-bar p) "bar!") (string=? (foo-bar p) "bar!") ;twice (= sanitized 1) ;sanitizer was called at init time only (let ((q (foo (bar "baz")))) (and (string=? (foo-bar q) "baz!") (string=? (foo-bar q) "baz!") ;twice (= sanitized 2) (let ((r (foo (inherit q)))) (and (string=? (foo-bar r) "baz!") (= sanitized 2))))))))) ;no re-sanitization (test-assert "define-record-type* & wrong field specifier" (let ((exp '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42)) (baz foo-baz)) (foo (baz 1 2 3 4 5)))) ;syntax error (loc (current-source-location))) ;keep this alignment! (catch 'syntax-error (lambda () (eval exp (test-module)) #f) (lambda (key proc message location form subform . _) (and (eq? proc 'foo) (string-match "invalid field" message) (equal? subform '(baz 1 2 3 4 5)) (equal? form '(foo (baz 1 2 3 4 5))) ;; Make sure the location is that of the field specifier. ;; See . (lset= equal? (pk 'expected-loc `((line . ,(- (assq-ref loc 'line) 1)) ,@(alist-delete 'line loc))) (pk 'actual-loc (location-alist location)))))))) (test-assert "define-record-type* & wrong field specifier, identifier" (let ((exp '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42)) (baz foo-baz)) (foo baz))) ;syntax error (loc (current-source-location))) ;keep this alignment! (catch 'syntax-error (lambda () (eval exp (test-module)) #f) (lambda (key proc message location form subform . _) (and (eq? proc 'foo) (string-match "invalid field" message) (equal? subform 'baz) (equal? form '(foo baz)) ;; Here the location is that of the parent form. (lset= equal? (pk 'expected-loc `((line . ,(- (assq-ref loc 'line) 2)) ,@(alist-delete 'line loc))) (pk 'actual-loc (location-alist location)))))))) (test-assert "define-record-type* & missing initializers" (catch 'syntax-error (lambda () (eval '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42)) (baz foo-baz)) (foo)) (test-module)) #f) (lambda (key proc message location form . args) (and (eq? proc 'foo) (string-match "missing .*initialize.*baz" message) (equal? form '(foo)))))) (test-assert "define-record-type* & extra initializers" (catch 'syntax-error (lambda () (eval '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42))) (foo (baz 'what?))) (test-module)) #f) (lambda (key proc message location form . args) (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) (test-assert "define-record-type* & inherit & extra initializers" (catch 'syntax-error (lambda () (eval '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42))) (foo (inherit (foo)) (baz 'what?))) (test-module)) #f) (lambda (key proc message location form . args) (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) (test-assert "define-record-type* & duplicate initializers" (let ((exp '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42))) (foo (bar 1) (bar 2)))) (loc (current-source-location))) ;keep this alignment! (catch 'syntax-error (lambda () (eval exp (test-module)) #f) (lambda (key proc message location form . args) (and (string-match "duplicate.*initializer" message) (eq? proc 'foo) ;; Make sure the location is that of the field specifier. (lset= equal? (pk 'expected-loc `((line . ,(- (assq-ref loc 'line) 1)) ,@(alist-delete 'line loc))) (pk 'actual-loc (location-alist location)))))))) (test-assert "ABI checks" (let ((module (test-module))) (eval '(begin (define-record-type* foo make-foo foo? (bar foo-bar (default 42))) (define (make-me-a-record) (foo))) module) (unless (eval '(foo? (make-me-a-record)) module) (error "what?" (eval '(make-me-a-record) module))) ;; Redefine with an additional field. (eval '(define-record-type* foo make-foo foo? (baz foo-baz) (bar foo-bar (default 42))) module) ;; Now 'make-me-a-record' is out of sync because it does an ;; 'allocate-struct' that corresponds to the previous definition of . (catch 'record-abi-mismatch-error (lambda () (eval '(foo? (make-me-a-record)) module) #f) (match-lambda* ((key 'abi-check (? string? message) (rtd) . _) (eq? rtd (eval ' module))))))) (test-equal "recutils->alist" '((("Name" . "foo") ("Version" . "0.1") ("Synopsis" . "foo bar") ("Something_else" . "chbouib")) (("Name" . "bar") ("Version" . "1.5"))) (let ((p (open-input-string " # Comment following an empty line, and # preceding a couple of empty lines, all of # which should be silently consumed. Name: foo Version: 0.1 # Comment right in the middle, # spanning two lines. Synopsis: foo bar Something_else: chbouib # Comment right before. Name: bar Version: 1.5 # Comment at the end."))) (list (recutils->alist p) (recutils->alist p)))) (test-equal "recutils->alist with + lines" '(("Name" . "foo") ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space.")) (recutils->alist (open-input-string " Name: foo Description: 1st line, + 2nd line, + 3rd line with extra space, +4th line without space."))) (test-equal "alist->record" '((1 2) b c) (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2)) list '("a" "b" "c") '("a"))) (test-equal "match-record, simple" '((1 2) (a b)) (let () (define-record-type* foo make-foo foo? (first foo-first (default 1)) (second foo-second)) (list (match-record (foo (second 2)) (first second) (list first second)) (match-record (foo (first 'a) (second 'b)) (second (first first/new-var)) (list first/new-var second))))) (test-equal "match-record, unknown field" 'syntax-error (catch 'syntax-error (lambda () (eval '(begin (use-modules (guix records)) (define-record-type* foo make-foo foo? (first foo-first (default 1)) (second foo-second)) (match-record (foo (second 2)) (one two) #f)) (make-fresh-user-module))) (lambda (key . args) key))) (test-equal "match-record, delayed field" "foo bar bar foo" (begin (define-record-type* with-delayed make-with-delayed with-delayed? (delayed with-delayed-delayed (delayed))) (let ((rec (with-delayed (delayed "foo bar bar foo")))) (match-record rec (delayed) delayed)))) (test-equal "match-record, thunked field" '("foo" "foobar") (begin (define-record-type* with-thunked make-with-thunked with-thunked? (normal with-thunked-normal) (thunked with-thunked-thunked (thunked))) (let ((rec (with-thunked (normal "foo") (thunked (string-append (with-thunked-normal this-record) "bar"))))) (match-record rec (normal thunked) (list normal thunked))))) (test-equal "match-record, ellipsis in body" #t (begin (define-record-type* foo make-foo foo? (value foo-value)) (define bar (foo (value '(1 2 3)))) (match-record bar (value) (match value ((one two ...) #t) (_ #f))))) (test-equal "match-record-lambda" '("thing: foo" "thing: bar") (begin (define-record-type* with-text make-with-text with-text? (text with-text-text)) (map (match-record-lambda (text) (string-append "thing: " text)) (list (with-text (text "foo")) (with-text (text "bar")))))) (test-end)