aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
;;; Copyright © 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 (test-gem)
  #:use-module (guix import gem)
  #:use-module (guix upstream)
  #:use-module ((guix download) #:select (url-fetch))
  #:use-module ((guix build-system ruby) #:select (rubygems-uri))
  #:use-module (guix base32)
  #:use-module (gcrypt hash)
  #:use-module (guix tests)
  #:use-module ((guix build utils) #:select (delete-file-recursively))
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match))

(define test-foo-json
  "{
  \"name\": \"foo\",
  \"version\": \"1.0.0\",
  \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\",
  \"info\": \"A cool gem\",
  \"homepage_uri\": \"https://example.com\",
  \"dependencies\": {
    \"runtime\": [
      { \"name\": \"bundler\" },
      { \"name\": \"bar\" }
    ]
  },
  \"licenses\": [\"MIT\", \"Apache 2.0\"]
}")

(define test-foo-v2-json
  "{
  \"name\": \"foo\",
  \"version\": \"2.0.0\",
  \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\",
  \"info\": \"A cool gem\",
  \"homepage_uri\": \"https://example.com\",
  \"dependencies\": {
    \"runtime\": [
      { \"name\": \"bundler\" },
      { \"name\": \"bar\" }
    ]
  },
  \"licenses\": [\"MIT\", \"Apache 2.0\"]
}")

(define test-bar-json
  "{
  \"name\": \"bar\",
  \"version\": \"1.0.0\",
  \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\",
  \"info\": \"Another cool gem\",
  \"homepage_uri\": \"https://example.com\",
  \"dependencies\": {
    \"runtime\": [
      { \"name\": \"bundler\" }
    ]
  },
  \"licenses\": null
}")

(define test-bundler-json
  "{
  \"name\": \"bundler\",
  \"version\": \"1.14.2\",
  \"sha\": \"3bb53e03db0a8008161eb4c816ccd317120d3c415ba6fee6f90bbc7f7eec8690\",
  \"info\": \"Ruby gem bundler\",
  \"homepage_uri\": \"https://bundler.io/\",
  \"dependencies\": {
    \"runtime\": []
  },
  \"licenses\": [\"MIT\"]
}")

(test-begin "gem")

(test-assert "gem->guix-package"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v1/gems/foo.json"
              (values (open-input-string test-foo-json)
                      (string-length test-foo-json)))
             (_ (error "Unexpected URL: " url)))))
    (match (gem->guix-package "foo")
      (`(package
          (name "ruby-foo")
          (version "1.0.0")
          (source (origin
                    (method url-fetch)
                    (uri (rubygems-uri "foo" version))
                    (sha256
                     (base32
                      "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
          (build-system ruby-build-system)
          (propagated-inputs (list bundler ruby-bar))
          (synopsis "A cool gem")
          (description "This package provides a cool gem.")
          (home-page "https://example.com")
          (license (list license:expat license:asl2.0)))
       #t)
      (x
       (pk 'fail x #f)))))

(test-assert "gem->guix-package with a specific version"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v2/rubygems/foo/versions/2.0.0.json"
              (values (open-input-string test-foo-v2-json)
                      (string-length test-foo-v2-json)))
             (_ (error "Unexpected URL: " url)))))
    (match (gem->guix-package "foo" #:version "2.0.0")
      (`(package
          (name "ruby-foo")
          (version "2.0.0")
          (source (origin
                    (method url-fetch)
                    (uri (rubygems-uri "foo" version))
                    (sha256
                     (base32
                      "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
          (build-system ruby-build-system)
          (propagated-inputs (list bundler ruby-bar))
          (synopsis "A cool gem")
          (description "This package provides a cool gem.")
          (home-page "https://example.com")
          (license (list license:expat license:asl2.0)))
       #t)
      (x
       (pk 'fail x #f)))))

(test-assert "gem-recursive-import"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v1/gems/foo.json"
              (values (open-input-string test-foo-json)
                      (string-length test-foo-json)))
             ("https://rubygems.org/api/v1/gems/bar.json"
              (values (open-input-string test-bar-json)
                      (string-length test-bar-json)))
             ("https://rubygems.org/api/v1/gems/bundler.json"
              (values (open-input-string test-bundler-json)
                      (string-length test-bundler-json)))
             (_ (error "Unexpected URL: " url)))))
        (match (gem-recursive-import "foo")
          (`((package
               (name "ruby-bar")
               (version "1.0.0")
               (source
                (origin
                  (method url-fetch)
                  (uri (rubygems-uri "bar" version))
                  (sha256
                   (base32
                    "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
               (build-system ruby-build-system)
               (propagated-inputs (list bundler))
               (synopsis "Another cool gem")
               (description "Another cool gem.")
               (home-page "https://example.com")
               (license #f))                      ;no licensing info
             (package
               (name "ruby-foo")
               (version "1.0.0")
               (source
                (origin
                  (method url-fetch)
                  (uri (rubygems-uri "foo" version))
                  (sha256
                   (base32
                    "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
               (build-system ruby-build-system)
               (propagated-inputs (list bundler ruby-bar))
               (synopsis "A cool gem")
               (description "This package provides a cool gem.")
               (home-page "https://example.com")
               (license (list license:expat license:asl2.0))))
           #t)
          (x
           (pk 'fail x #f)))))

(test-assert "gem-recursive-import with a specific version"
  ;; Replace network resources with sample data.
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v2/rubygems/foo/versions/2.0.0.json"
              (values (open-input-string test-foo-v2-json)
                      (string-length test-foo-v2-json)))
             ("https://rubygems.org/api/v1/gems/bar.json"
              (values (open-input-string test-bar-json)
                      (string-length test-bar-json)))
             ("https://rubygems.org/api/v1/gems/bundler.json"
              (values (open-input-string test-bundler-json)
                      (string-length test-bundler-json)))
             (_ (error "Unexpected URL: " url)))))
        (match (gem-recursive-import "foo" "2.0.0")
          (`((package
               (name "ruby-bar")
               (version "1.0.0")
               (source
                (origin
                  (method url-fetch)
                  (uri (rubygems-uri "bar" version))
                  (sha256
                   (base32
                    "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
               (build-system ruby-build-system)
               (propagated-inputs (list bundler))
               (synopsis "Another cool gem")
               (description "Another cool gem.")
               (home-page "https://example.com")
               (license #f))                      ;no licensing info
             (package
               (name "ruby-foo")
               (version "2.0.0")
               (source
                (origin
                  (method url-fetch)
                  (uri (rubygems-uri "foo" version))
                  (sha256
                   (base32
                    "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
               (build-system ruby-build-system)
               (propagated-inputs (list bundler ruby-bar))
               (synopsis "A cool gem")
               (description "This package provides a cool gem.")
               (home-page "https://example.com")
               (license (list license:expat license:asl2.0))))
           #t)
          (x
           (pk 'fail x #f)))))

(test-equal "package-latest-release"
  (list '("https://rubygems.org/downloads/foo-1.0.0.gem")
        (list (upstream-input
               (name "bundler")
               (downstream-name name)
               (type 'propagated))
              (upstream-input
               (name "bar")
               (downstream-name "ruby-bar")
               (type 'propagated))))
  (mock ((guix http-client) http-fetch
         (lambda (url . rest)
           (match url
             ("https://rubygems.org/api/v1/gems/foo.json"
              (values (open-input-string test-foo-json)
                      (string-length test-foo-json)))
             (_ (error "Unexpected URL: " url)))))
        (let ((source (package-latest-release
                       (dummy-package "ruby-foo"
                                      (version "0.1.2")
                                      (source (dummy-origin
                                               (method url-fetch)
                                               (uri (rubygems-uri "foo"
                                                                  version))))))))
          (list (upstream-source-urls source)
                (upstream-source-inputs source)))))

(test-end "gem")
generated by cgit
) ":17169:::::: nobody:!:0::::::\n")) (test-begin "accounts") (test-equal "write-passwd" %passwd-sample (call-with-output-string (lambda (port) (write-passwd (list (password-entry (name "root") (uid 0) (gid 0) (real-name "Admin") (directory "/root") (shell "/bin/sh")) (password-entry (name "charlie") (uid 1000) (gid 998) (real-name "Charlie") (directory "/home/charlie") (shell "/bin/sh"))) port)))) (test-equal "write-passwd with duplicate entry" %passwd-sample (call-with-output-string (lambda (port) (let ((charlie (password-entry (name "charlie") (uid 1000) (gid 998) (real-name "Charlie") (directory "/home/charlie") (shell "/bin/sh")))) (write-passwd (list (password-entry (name "root") (uid 0) (gid 0) (real-name "Admin") (directory "/root") (shell "/bin/sh")) charlie charlie) port))))) (test-equal "read-passwd + write-passwd" %passwd-sample (call-with-output-string (lambda (port) (write-passwd (call-with-input-string %passwd-sample read-passwd) port)))) (test-equal "write-group" %group-sample (call-with-output-string (lambda (port) (write-group (list (group-entry (name "root") (gid 0)) (group-entry (name "wheel") (gid 999) (members '("alice" "bob"))) (group-entry (name "hackers") (gid 65000) (members '("alice" "charlie")))) port)))) (test-equal "read-group + write-group" %group-sample (call-with-output-string (lambda (port) (write-group (call-with-input-string %group-sample read-group) port)))) (test-equal "write-shadow" %shadow-sample (call-with-output-string (lambda (port) (write-shadow (list (shadow-entry (name "root") (password (crypt "secret" "$6$abc")) (last-change 17169)) (shadow-entry (name "charlie") (password (crypt "hey!" "$6$abc")) (last-change 17169)) (shadow-entry (name "nobody"))) port)))) (test-equal "read-shadow + write-shadow" %shadow-sample (call-with-output-string (lambda (port) (write-shadow (call-with-input-string %shadow-sample read-shadow) port)))) (define allocate-groups (@@ (gnu build accounts) allocate-groups)) (define allocate-passwd (@@ (gnu build accounts) allocate-passwd)) (test-equal "allocate-groups" ;; Allocate GIDs in a stateless fashion. (list (group-entry (name "s") (gid %system-id-max)) (group-entry (name "x") (gid 900)) (group-entry (name "t") (gid 899)) (group-entry (name "a") (gid %id-min) (password "foo") (members '("alice" "bob"))) (group-entry (name "b") (gid (+ %id-min 1)) (members '("charlie")))) (allocate-groups (list (user-group (name "s") (system? #t)) (user-group (name "x") (id 900)) (user-group (name "t") (system? #t)) (user-group (name "a") (password "foo")) (user-group (name "b"))) (alist->vhash `(("a" . "bob") ("a" . "alice") ("b" . "charlie"))))) (test-equal "allocate-groups with requested GIDs" ;; Make sure the requested GID for "b" is honored. (list (group-entry (name "a") (gid (+ 1 %id-min))) (group-entry (name "b") (gid %id-min)) (group-entry (name "c") (gid (+ 2 %id-min)))) (allocate-groups (list (user-group (name "a")) (user-group (name "b") (id %id-min)) (user-group (name "c"))) vlist-null)) (test-equal "allocate-groups with previous state" ;; Make sure bits of state are preserved: password, GID, no reuse of ;; previously-used GIDs. (list (group-entry (name "s") (gid (- %system-id-max 1))) (group-entry (name "t") (gid (- %system-id-max 2))) (group-entry (name "a") (gid 30000) (password #f) (members '("alice" "bob"))) (group-entry (name "b") (gid 30001) (password "bar") (members '("charlie")))) (allocate-groups (list (user-group (name "s") (system? #t)) (user-group (name "t") (system? #t)) (user-group (name "a") (password "foo")) (user-group (name "b"))) (alist->vhash `(("a" . "bob") ("a" . "alice") ("b" . "charlie"))) (list (group-entry (name "a") (gid 30000)) (group-entry (name "b") (gid 30001) (password "bar")) (group-entry (name "removed") (gid %system-id-max))))) (test-equal "allocate-groups with previous state, looping" ;; Check that allocation starts after the highest previously-used GID, and ;; loops back to the lowest GID. (list (group-entry (name "a") (gid (- %id-max 1))) (group-entry (name "b") (gid %id-min)) (group-entry (name "c") (gid (+ 1 %id-min)))) (allocate-groups (list (user-group (name "a")) (user-group (name "b")) (user-group (name "c"))) vlist-null (list (group-entry (name "d") (gid (- %id-max 2)))))) (test-equal "allocate-passwd" ;; Allocate UIDs in a stateless fashion. (list (password-entry (name "alice") (uid %id-min) (gid 1000) (real-name "Alice") (shell "/bin/sh") (directory "/home/alice")) (password-entry (name "bob") (uid (+ 1 %id-min)) (gid 1001) (real-name "Bob") (shell "/bin/gash") (directory "/home/bob")) (password-entry (name "sshd") (uid %system-id-max) (gid 500) (real-name "sshd") (shell "/nologin") (directory "/var/empty")) (password-entry (name "guix") (uid 30000) (gid 499) (real-name "Guix") (shell "/nologin") (directory "/var/empty"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") (shell "/bin/sh") (group "users")) (user-account (name "bob") (comment "Bob") (shell "/bin/gash") (group "wheel")) (user-account (name "sshd") (system? #t) (comment "sshd") (home-directory "/var/empty") (shell "/nologin") (group "sshd")) (user-account (name "guix") (system? #t) (comment "Guix") (home-directory "/var/empty") (shell "/nologin") (group "guix") (uid 30000))) (list (group-entry (name "users") (gid 1000)) (group-entry (name "wheel") (gid 1001)) (group-entry (name "sshd") (gid 500)) (group-entry (name "guix") (gid 499))))) (test-equal "allocate-passwd with previous state" ;; Make sure bits of state are preserved: UID, no reuse of previously-used ;; UIDs, and shell. (list (password-entry (name "alice") (uid 1234) (gid 1000) (real-name "Alice Smith") (shell "/bin/sh") (directory "/home/alice")) (password-entry (name "charlie") (uid 1236) (gid 1000) (real-name "Charlie") (shell "/bin/sh") (directory "/home/charlie"))) (allocate-passwd (list (user-account (name "alice") (comment "Alice") (shell "/bin/sh") ;honored (group "users")) (user-account (name "charlie") (comment "Charlie") (shell "/bin/sh") (group "users"))) (list (group-entry (name "users") (gid 1000))) (list (password-entry (name "alice") (uid 1234) (gid 9999) (real-name "Alice Smith") (shell "/gnu/.../bin/gash") ;ignored (directory "/home/alice")) (password-entry (name "bob") (uid 1235) (gid 1001) (real-name "Bob") (shell "/bin/sh") (directory "/home/bob"))))) (test-equal "user+group-databases" ;; The whole shebang. (list (list (group-entry (name "a") (gid %id-min) (members '("bob"))) (group-entry (name "b") (gid (+ 1 %id-min)) (members '("alice"))) (group-entry (name "s") (gid %system-id-max))) (list (password-entry (name "alice") (real-name "Alice") (uid %id-min) (gid %id-min) (directory "/a")) (password-entry (name "bob") (real-name "Bob") (uid (+ 1 %id-min)) (gid (+ 1 %id-min)) (directory "/b")) (password-entry (name "nobody") (uid 65534) (gid %system-id-max) (directory "/var/empty"))) (list (shadow-entry (name "alice") (last-change 100) (password (crypt "initial pass" "$6$"))) (shadow-entry (name "bob") (last-change 50) (password (crypt "foo" "$6$"))) (shadow-entry (name "nobody") (last-change 100)))) (call-with-values (lambda () (user+group-databases (list (user-account (name "alice") (comment "Alice") (home-directory "/a") (group "a") (supplementary-groups '("b")) (password (crypt "initial pass" "$6$"))) (user-account (name "bob") (comment "Bob") (home-directory "/b") (group "b") (supplementary-groups '("a"))) (user-account (name "nobody") (group "s") (uid 65534) (home-directory "/var/empty"))) (list (user-group (name "a")) (user-group (name "b")) (user-group (name "s") (system? #t))) #:current-passwd '() #:current-shadow (list (shadow-entry (name "bob") (password (crypt "foo" "$6$")) (last-change 50))) #:current-groups '() #:current-time (lambda (type) (make-time type 0 (* 24 3600 100))))) list)) (test-end "accounts")
generated by cgit