;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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-nar)
  #:use-module (guix tests)
  #:use-module (guix nar)
  #:use-module (guix serialization)
  #:use-module (guix store)
  #:use-module ((guix hash)
                #:select (open-sha256-port op</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>refs</a><a href='/guix/log/gnu/packages'>log</a><a href='/guix/tree/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>tree</a><a class='active' href='/guix/commit/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>commit</a><a href='/guix/diff/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/packages'>
<input type='hidden' name='id' value='d5c34f9b18087ee462512eed21e6d4a332f2235a'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/commit/?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>root</a>/<a href='/guix/commit/gnu?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>gnu</a>/<a href='/guix/commit/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>packages</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='d5c34f9b18087ee462512eed21e6d4a332f2235a'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><table summary='commit info' class='commit-info'>
<tr><th>author</th><td>rsiddharth &lt;s@ricketyspace.net&gt;</td><td class='right'>2018-03-21 03:45:04 +0000</td></tr>
<tr><th>committer</th><td>Ludovic Courtès &lt;ludo@gnu.org&gt;</td><td class='right'>2018-03-31 19:27:40 +0200</td></tr>
<tr><th>commit</th><td colspan='2' class='oid'><a href='/guix/commit/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>d5c34f9b18087ee462512eed21e6d4a332f2235a</a> (<a href='/guix/patch/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>patch</a>)</td></tr>
<tr><th>tree</th><td colspan='2' class='oid'><a href='/guix/tree/?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>9fda99d7857dfe953f23606f45707c1b095885df</a> /<a href='/guix/tree/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>gnu/packages</a></td></tr>
<tr><th>parent</th><td colspan='2' class='oid'><a href='/guix/commit/gnu/packages?id=8434594d6d76c27bccf61b6c6d91d11e9869c0b1'>8434594d6d76c27bccf61b6c6d91d11e9869c0b1</a> (<a href='/guix/diff/gnu/packages?id=d5c34f9b18087ee462512eed21e6d4a332f2235a&amp;id2=8434594d6d76c27bccf61b6c6d91d11e9869c0b1'>diff</a>)</td></tr><tr><th>download</th><td colspan='2' class='oid'><a href='/guix/snapshot/guix-d5c34f9b18087ee462512eed21e6d4a332f2235a.tar.gz'>guix-d5c34f9b18087ee462512eed21e6d4a332f2235a.tar.gz</a><br/><a href='/guix/snapshot/guix-d5c34f9b18087ee462512eed21e6d4a332f2235a.zip'>guix-d5c34f9b18087ee462512eed21e6d4a332f2235a.zip</a><br/></td></tr></table>
<div class='commit-subject'>gnu: Add ghc-unliftio-core.</div><div class='commit-msg'>* gnu/packages/haskell.scm (ghc-unliftio-core): New variable.

Signed-off-by: Ludovic Courtès &lt;ludo@gnu.org&gt;
</div><div class='diffstat-header'><a href='/guix/diff/?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>Diffstat</a> (limited to 'gnu/packages')</div><table summary='diffstat' class='diffstat'><tr><td class='mode'>-rw-r--r--</td><td class='upd'><a href='/guix/diff/gnu/packages/haskell.scm?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>gnu/packages/haskell.scm</a></td><td class='right'>22</td><td class='graph'><table summary='file diffstat' width='22%'><tr><td class='add' style='width: 100.0%;'/><td class='rem' style='width: 0.0%;'/><td class='none' style='width: 0.0%;'/></tr></table></td></tr>
</table><div class='diffstat-summary'>1 files changed, 22 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td><div class='head'>diff --git a/gnu/packages/haskell.scm b/gnu/packages/haskell.scm<br/>index a5c86b50ce..7723eaa5ce 100644<br/>--- a/<a href='/guix/tree/gnu/packages/haskell.scm?id=8434594d6d76c27bccf61b6c6d91d11e9869c0b1'>gnu/packages/haskell.scm</a><br/>+++ b/<a href='/guix/tree/gnu/packages/haskell.scm?id=d5c34f9b18087ee462512eed21e6d4a332f2235a'>gnu/packages/haskell.scm</a></div><div class='hunk'>@@ -9299,4 +9299,26 @@ ghc-aeson.")</div><div class='ctx'> functions for the ghc-persistent package.")</div><div class='ctx'>     (license license:expat)))</div><div class='ctx'> </div><div class='add'>+(define-public ghc-unliftio-core</div><div class='add'>+  (package</div><div class='add'>+    (name "ghc-unliftio-core")</div><div class='add'>+    (version "0.1.1.0")</div><div class='add'>+    (source</div><div class='add'>+     (origin</div><div class='add'>+       (method url-fetch)</div><div class='add'>+       (uri (string-append "https://hackage.haskell.org/package/"</div><div class='add'>+                           "unliftio-core-" version "/"</div><div class='add'>+                           "unliftio-core-" version ".tar.gz"))</div><div class='add'>+       (sha256</div><div class='add'>+        (base32</div><div class='add'>+         "1193fplsjm1lcr05xwvkj1rsyzx74i755f6kw3ikmxbsv0bv0l3m"))))</div><div class='add'>+    (build-system haskell-build-system)</div><div class='add'>+    (home-page</div><div class='add'>+     "https://github.com/fpco/unliftio/tree/master/unliftio-core#readme")</div><div class='add'>+    (synopsis "The MonadUnliftIO typeclass for unlifting monads to IO")</div><div class='add'>+    (description "This Haskell package provides the core @code{MonadUnliftIO}</div><div class='add'>+typeclass, instances for base and transformers, and basic utility</div><div class='add'>+functions.")</div><div class='add'>+    (license license:expat)))</div><div class='add'>+</div><div class='ctx'> ;;; haskell.scm ends here</div></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
da () #t)
              (lambda ()
                (call-with-output-file nar
                  (lambda (port)
                    (write-file input port
                                #:select?
                                (lambda (file stat)
                                  (and (not (string=? (basename file)
                                                      "a"))
                                       (not (eq? (stat:type stat)
                                                 'symlink)))))))
                (call-with-input-file nar
                  (cut restore-file <> output))

                ;; Make sure "a" and "d" have been filtered out.
                (and (not (file-exists? (string-append output "/root/a")))
                     (file=? (string-append output "/root/b")
                             (string-append input "/root/b"))
                     (file=? (string-append output "/root/c")
                             (string-append input "/root/c"))
                     (not (file-exists? (string-append output "/root/d")))))
              (lambda ()
                (false-if-exception (delete-file nar))
                (false-if-exception (rm-rf output)))))))
      (lambda ()
        (rmdir input)))))

;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
;; relies on a Guile 2.0.10+ feature.
(test-skip (if (false-if-exception
                (open-sha256-input-port (%make-void-port "r")))
               0
               3))

(test-assert "restore-file-set (signed, valid)"
  (with-store store
    (let* ((texts (unfold (cut >= <> 10)
                          (lambda _ (random-text))
                          1+
                          0))
           (files (map (cut add-text-to-store store "text" <>) texts))
           (dump  (call-with-bytevector-output-port
                   (cut export-paths store files <>))))
      (delete-paths store files)
      (and (every (negate file-exists?) files)
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (restore-file-set source)))
             (and (equal? imported files)
                  (every (lambda (file)
                           (and (file-exists? file)
                                (valid-path? store file)))
                         files)
                  (equal? texts
                          (map (lambda (file)
                                 (call-with-input-file file
                                   get-string-all))
                               files))))))))

(test-assert "restore-file-set (missing signature)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo" (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>
                           #:sign? #f))))
        (delete-paths store (list file))
        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-signature-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-match "lacks.*signature" message)
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-assert "restore-file-set (corrupt)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo"
                                       (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>))))
        (delete-paths store (list file))

        ;; Flip a byte in the file contents.
        (let* ((index 120)
               (byte  (bytevector-u8-ref dump index)))
          (bytevector-u8-set! dump index (logxor #xff byte)))

        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-invalid-hash-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-contains message "hash")
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-end "nar")

;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
;;; End: