gnu: Add python-pyshp.
[jackhill/guix/guix.git] / gnu / packages / file-systems.scm
index d7c34cd..e2335b8 100644 (file)
@@ -8,6 +8,7 @@
 ;;; Copyright © 2020 Morgan Smith <Morgan.J.Smith@outlook.com>
 ;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
 ;;; Copyright © 2021 Stefan Reichör <stefan@xsteve.at>
+;;; Copyright © 2021 Noisytoot <noisytoot@disroot.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,6 +40,7 @@
   #:use-module (guix utils)
   #:use-module (gnu packages)
   #:use-module (gnu packages acl)
+  #:use-module (gnu packages admin)
   #:use-module (gnu packages attr)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages base)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages gnupg)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages guile)
   #:use-module (gnu packages kerberos)
   #:use-module (gnu packages libffi)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages nfs)
   #:use-module (gnu packages onc-rpc)
   #:use-module (gnu packages openldap)
+  #:use-module (gnu packages perl)
   #:use-module (gnu packages photo)
   #:use-module (gnu packages pkg-config)
   #:use-module (gnu packages python)
@@ -72,6 +76,7 @@
   #:use-module (gnu packages rsync)
   #:use-module (gnu packages sssd)
   #:use-module (gnu packages sqlite)
+  #:use-module (gnu packages time)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages valgrind)
   #:use-module (gnu packages version-control)
@@ -184,7 +189,7 @@ large and/or frequently changing (network) environment.")
     (home-page "https://bindfs.org")
     (synopsis "Bind mount a directory and alter permission bits")
     (description
-     "@command{bindfs} is a FUSE filesystem for mounting a directory to
+     "@command{bindfs} is a FUSE file system for mounting a directory to
 another location, similar to @command{mount --bind}.  It can be used for:
 @itemize
 @item Making a directory read-only.
@@ -251,9 +256,9 @@ another location, similar to @command{mount --bind}.  It can be used for:
     (description
      "The @acronym{WebDAV, Web Distributed Authoring and Versioning} extension
 to the HTTP protocol defines a standard way to author resources on a remote Web
-server.  Davfs2 exposes such resources as a typical filesystem which can be used
-by standard applications with no built-in support for WebDAV, such as the GNU
-coreutils (@command{cp}, @command{mv}, etc.) or a graphical word processor.
+server.  Davfs2 exposes such resources as a typical file system which can be
+used by standard applications with no built-in support for WebDAV, such as the
+GNU coreutils (@command{cp}, @command{mv}, etc.) or a graphical word processor.
 
 Davfs2 works with most WebDAV servers with no or little configuration.  It
 supports TLS (HTTPS), HTTP proxies, HTTP basic and digest authentication, and
@@ -340,8 +345,8 @@ from a mounted file system.")
     (license license:gpl2+)))
 
 (define-public bcachefs-tools
-  (let ((commit "bb6eccc2ecd4728871bfc70462d3a4a20daa9d68")
-        (revision "4"))
+  (let ((commit "fe1bb39aa52d9140981ba1e96f3c95ddf14006ce")
+        (revision "8"))
     (package
       (name "bcachefs-tools")
       (version (git-version "0.1" revision commit))
@@ -353,14 +358,15 @@ from a mounted file system.")
                (commit commit)))
          (file-name (git-file-name name version))
          (sha256
-          (base32 "0ziqmcxbrak6bjck6s46hqrqx44zc97yaj0kbk3amsxf18rsfs0n"))))
+          (base32 "1ks6w2v76pfpp70cv1d6znxaw1g5alz1v6hf8z9gvj15r94vgpwz"))))
       (build-system gnu-build-system)
       (arguments
        `(#:make-flags
          (list ,(string-append "VERSION=" version) ; bogus vX.Y-nogit otherwise
                (string-append "PREFIX=" (assoc-ref %outputs "out"))
                "INITRAMFS_DIR=$(PREFIX)/share/initramfs-tools"
-               "CC=gcc"
+               ,(string-append "CC=" (cc-for-target))
+               ,(string-append "PKG_CONFIG=" (pkg-config-for-target))
                "PYTEST=pytest")
          #:phases
          (modify-phases %standard-phases
@@ -472,7 +478,7 @@ from the bcachefs-tools package.  It is meant to be used in initrds.")
 (define-public exfatprogs
   (package
     (name "exfatprogs")
-    (version "1.1.0")
+    (version "1.1.2")
     (source
      (origin
        (method git-fetch)
@@ -481,7 +487,7 @@ from the bcachefs-tools package.  It is meant to be used in initrds.")
              (commit version)))
        (file-name (git-file-name name version))
        (sha256
-        (base32 "1ciy28lx7c1vr1f138qi0mkz88pzlkay6nlwmp1yjzd830x48549"))))
+        (base32 "19pbybgbfnvjb3n944ihrn1r8ch4dm8dr0d44d6w7p63dcp372xy"))))
     (build-system gnu-build-system)
     (arguments
      `(#:configure-flags
@@ -570,6 +576,7 @@ single file can be mounted.")
        (sha256
         (base32 "0kbsy2sk1jv4m82rxyl25gwrlkzvl3hzdga9gshkxkhm83v1aji4"))
        (patches (search-patches "jfsutils-add-sysmacros.patch"
+                                "jfsutils-gcc-compat.patch"
                                 "jfsutils-include-systypes.patch"))))
     (build-system gnu-build-system)
     (inputs
@@ -768,10 +775,93 @@ All of this is accomplished without a centralized metadata server.")
      "This is a file system client based on the FTP File Transfer Protocol.")
     (license license:gpl2+)))
 
+(define-public libeatmydata
+  (package
+    (name "libeatmydata")
+    (version "129")
+    (source
+     (origin
+       (method url-fetch)
+       (uri (string-append "https://www.flamingspork.com/projects/libeatmydata/"
+                           "libeatmydata-" version ".tar.gz"))
+       (sha256
+        (base32 "1qycv1cvy6fr3v5rxilnsqxllwyfbqlcairlh31x2dnjsx28jnqf"))))
+    (build-system gnu-build-system)
+    (arguments
+     ;; All tests pass---but only if the host kernel allows PTRACE_TRACEME.
+     `(#:tests? #f
+       #:configure-flags
+       (list "--disable-static")
+       #:phases
+       (modify-phases %standard-phases
+         (add-after 'unpack 'patch-file-names
+           (lambda* (#:key inputs #:allow-other-keys)
+             (substitute* (list "eatmydata.in" "eatmydata.sh.in")
+               (("basename|readlink|uname" command)
+                (string-append (assoc-ref inputs "coreutils") "/bin/" command)))))
+         (add-before 'patch-file-names 'tighten-symlink-mode
+           ;; When the ‘eatmydata’ helper detects that it's a symlink, it will
+           ;; transparently invoke the command of the same name.  However, it's
+           ;; *always* a link in Guix profiles and doesn't handle that well.
+           ;; Patch it to treat its own $name specially.
+           (lambda _
+             (substitute* "eatmydata.in"
+               (("-L \"\\$0\"" match)
+                (string-append match " ] && [ "
+                               "\"x$(basename \"$0\")\" != \"x$name\"")))))
+         (add-after 'install 'install-debian-files
+           (lambda* (#:key inputs outputs #:allow-other-keys)
+             (let* ((debian (assoc-ref inputs "debian-files"))
+                    (out    (assoc-ref outputs "out"))
+                    (share  (string-append out "/share")))
+               (invoke "tar" "xvf" debian)
+               (with-directory-excursion "debian"
+                 (install-file "eatmydata.1" (string-append share "/man/man1"))
+                 (install-file "eatmydata.bash-completion"
+                               (string-append share "/bash-completion"
+                                              "/completions")))))))))
+    (native-inputs
+     `(("debian-files"                  ; for the man page
+        ,(origin
+           (method url-fetch)
+           (uri (string-append "https://deb.debian.org/debian/pool/main/"
+                               "libe/libeatmydata/libeatmydata_" version
+                               "-1.debian.tar.xz"))
+           (sha256
+            (base32 "0q6kx1bf870jj52a2vm5p5xlrr89g2zs8wyhlpn80pys9p28nikx"))))
+       ;; For the test suite.
+       ("strace" ,strace)
+       ("which" ,which)))
+    (inputs
+     `(("coreutils" ,coreutils)))
+    (home-page "https://www.flamingspork.com/projects/libeatmydata/")
+    (synopsis "Transparently ignore calls to synchronize data safely to disk")
+    (description
+     "Libeatmydata transparently disables most ways a program might force data
+to be written to the file system, such as @code{fsync()} or @code{open(O_SYNC)}.
+
+Such synchronisation calls provide important data integrity guarantees but are
+expensive to perform and can significantly slow down software that (over)uses
+them.
+
+This price is worth paying if you care about the files being modified---which is
+typically the case---or when manipulating important components of your system.
+Please, @emph{do not} use something called ``eat my data'' in such cases!
+
+However, it does not make sense to accept this performance hit if the data is
+unimportant and you can afford to lose all of it in the event of a crash, for
+example when running a software test suite.  Adding @code{}libeatmydata.so} to
+the @env{LD_PRELOAD} environment of such tasks will override all C library data
+synchronisation functions with custom @i{no-op} ones that do nothing and
+immediately return success.
+
+A simple @command{eatmydata} script is included that does this for you.")
+    (license license:gpl3+)))
+
 (define-public libnfs
   (package
     (name "libnfs")
-    (version "3.0.0")
+    (version "4.0.0")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -780,7 +870,7 @@ All of this is accomplished without a centralized metadata server.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "115p55y2cbs92z5lmcnjx1v29lwinpgq4sha9v1kq1vd8674h404"))))
+                "0i27wd4zvhjz7620q043p4d4mkx8zv2yz9adm1byin47dynahyda"))))
     (build-system gnu-build-system)
     (home-page "https://github.com/sahlberg/libnfs")
     (native-inputs
@@ -853,6 +943,161 @@ APFS.")
       (home-page "https://github.com/sgan81/apfs-fuse")
       (license license:gpl2+))))
 
+(define-public xfstests
+  ;; The last release (1.1.0) is from 2011.
+  (let ((revision "0")
+        (commit "1c18b9ec2fcc94bd05ecdd136aa51c97bf3fa70d"))
+    (package
+      (name "xfstests")
+      (version (git-version "1.1.0" revision commit))
+      (source
+       (origin
+         (method git-fetch)
+         (uri (git-reference
+               (url "git://git.kernel.org/pub/scm/fs/xfs/xfstests-dev.git")
+               (commit commit)))
+         (file-name (git-file-name name version))
+         (sha256
+          (base32 "0rrv0rs9nhaza0jk5k0bj27w4lcd1s4a1ls8nr679qi02bgx630x"))))
+      (build-system gnu-build-system)
+      (arguments
+       `(#:phases
+         (modify-phases %standard-phases
+           (add-after 'unpack 'patch-tool-locations
+             (lambda* (#:key inputs #:allow-other-keys)
+               (substitute* "common/config"
+                 ;; Make absolute file names relative.
+                 (("(MKFS_PROG=\").*(\")" _ pre post)
+                  (string-append pre "mkfs" post)))
+               (for-each (lambda (file)
+                           (substitute* file
+                             (("( -s|#.|[= ])(/bin/sh|/bin/bash)" _ pre match)
+                              (string-append pre
+                                             (assoc-ref inputs "bash")
+                                             match))
+                             (("/bin/(rm|true)" match)
+                              (string-append (assoc-ref inputs "coreutils")
+                                             match))
+                             (("/usr(/bin/time)" _ match)
+                              (string-append (assoc-ref inputs "time")
+                                             match))))
+                         (append (find-files "common" ".*")
+                                 (find-files "tests" ".*")
+                                 (find-files "tools" ".*")
+                                 (find-files "src" "\\.(c|sh)$")))))
+           (replace 'bootstrap
+             (lambda* (#:key make-flags #:allow-other-keys)
+               (substitute* "Makefile"
+                 ;; Avoid a mysterious (to me) ‘permission denied’ error.
+                 (("cp ") "cp -f "))
+               (substitute* "m4/package_utilies.m4"
+                 ;; Fix the bogus hard-coded paths for every single binary.
+                 (("(AC_PATH_PROG\\(.*, ).*(\\))" _ pre post)
+                  (string-append pre (getenv "PATH") post)))
+               (apply invoke "make" "configure" make-flags)))
+           (add-after 'install 'wrap-xfstests/check
+             ;; Keep wrapping distinct from 'create-helper-script below: users
+             ;; must be able to invoke xfstests/check directly if they prefer.
+             (lambda* (#:key inputs outputs #:allow-other-keys)
+               (let* ((out (assoc-ref outputs "out")))
+                 (wrap-program (string-append out "/xfstests/check")
+                   ;; Prefix the user's PATH with the minimum required tools.
+                   ;; The suite has many other optional dependencies and will
+                   ;; automatically select tests based on the original PATH.
+                   `("PATH" ":" prefix
+                     ,(map (lambda (name)
+                             (let ((input (assoc-ref inputs name)))
+                               (string-append input "/bin:"
+                                              input "/sbin")))
+                           (list "acl"
+                                 "attr"
+                                 "coreutils"
+                                 "inetutils"
+                                 "xfsprogs")))))))
+           (add-after 'install 'create-helper
+             ;; Upstream installs only a ‘check’ script that's not in $PATH and
+             ;; would try to write to the store without explaining how to change
+             ;; that.  Install a simple helper script to make it discoverable.
+             (lambda* (#:key inputs outputs #:allow-other-keys)
+               (let* ((out      (assoc-ref outputs "out"))
+                      (check    (string-append out "/xfstests/check"))
+                      (bin      (string-append out "/bin"))
+                      (helper   (string-append bin "/xfstests-check")))
+                 (mkdir-p bin)
+                 (with-output-to-file helper
+                   (lambda _
+                     (format #t "#!~a --no-auto-compile\n!#\n"
+                             (string-append (assoc-ref inputs "guile")
+                                            "/bin/guile"))
+                     (write
+                      `(begin
+                         (define (try proc dir)
+                           "Try to PROC DIR.  Return DIR on success, else #f."
+                           (with-exception-handler (const #f)
+                             (lambda _ (proc dir) dir)
+                             #:unwind? #t))
+
+                         (define args
+                           (cdr (command-line)))
+
+                         (when (or (member "--help" args)
+                                   (member "-h" args))
+                           (format #t "Usage: ~a [OPTION]...
+This Guix helper sets up a new writable RESULT_BASE if it's unset, then executes
+xfstest's \"~a\" command (with any OPTIONs) as documented below.\n\n"
+                                   ,(basename helper)
+                                   ,(basename check)))
+
+                         (let* ((gotenv-base (getenv "RESULT_BASE"))
+                                (base (or gotenv-base
+                                          (let loop ((count 0))
+                                            (or (try mkdir
+                                                     (format #f "xfstests.~a"
+                                                             count))
+                                                (loop (+ 1 count))))))
+                                (result-base (if (string-prefix? "/" base)
+                                                 base
+                                                 (string-append (getcwd) "/"
+                                                                base))))
+                           (setenv "RESULT_BASE" result-base)
+                           ;; CHECK must run in its own directory or will fail.
+                           (chdir ,(dirname check))
+                           (let ((status
+                                  (status:exit-val (apply system* ,check args))))
+                             (unless gotenv-base
+                               (try rmdir result-base))
+                             status))))))
+                 (chmod helper #o755)))))))
+      (native-inputs
+       `(("autoconf" ,autoconf)
+         ("automake" ,automake)
+         ("libtool" ,libtool)))
+      (inputs
+       `(("acl" ,acl)
+         ("attr" ,attr)
+         ("guile" ,guile-3.0)           ; for our xfstests-check helper script
+         ("inetutils" ,inetutils)       ; for ‘hostname’
+         ("libuuid" ,util-linux "lib")
+         ("perl" ,perl)                 ; to automagically patch shebangs
+         ("time" ,time)
+         ("xfsprogs" ,xfsprogs)))
+      (home-page "https://git.kernel.org/pub/scm/fs/xfs/xfstests-dev.git")
+      (synopsis "File system @acronym{QA, Quality Assurance} test suite")
+      (description
+       "The @acronym{FSQA, File System Quality Assurance} regression test suite,
+more commonly known as xfstests, comprises over 1,500 tests that exercise
+(@dfn{torture}) both the user- and kernel-space parts of many different file
+systems.
+
+As the package's name subtly implies, it was originally developed to test the
+XFS file system.  Today, xfstests is the primary test suite for all major file
+systems supported by the kernel Linux including XFS, ext4, and Btrfs, but also
+virtual and network file systems such as NFS, 9P, and the overlay file system.
+
+The packaged @command{check} script is not in @env{PATH} but can be invoked
+with the included @command{xfstests-check} helper.")
+      (license license:gpl2))))
+
 (define-public zfs
   (package
     (name "zfs")
@@ -982,6 +1227,84 @@ originally developed for Solaris and is now maintained by the OpenZFS
 community.")
     (license license:cddl1.0)))
 
+(define-public zfs-auto-snapshot
+  (package
+    (name "zfs-auto-snapshot")
+    (version "1.2.4")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url
+              (string-append "https://github.com/zfsonlinux/" name))
+             (commit
+              (string-append "upstream/" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "0m4xw7h5qlbn5zdf9wb137pcr5l7hyrr7w2dgr16dfm5ay64vvfq"))))
+    (build-system gnu-build-system)
+    (inputs
+     ;; Note: if you are inheriting from the above zfs package in order
+     ;; to provide a specific stable kernel version, you should also
+     ;; inherit this package and replace the sole input below.
+     `(("zfs" ,zfs)))
+    (arguments
+     `(#:tests? #f ; No tests
+       #:phases
+       (modify-phases %standard-phases
+         (delete 'configure)
+         (delete 'build)
+         ;; Guix System may not have a traditional cron system, but
+         ;; the cron scripts installed by this package are convenient
+         ;; to use as targets for an mcron job specification, so make
+         ;; sure they can be run in-store.
+         (add-before 'install 'fix-scripts
+           (lambda* (#:key outputs inputs #:allow-other-keys)
+             (let* ((out                (assoc-ref outputs "out"))
+                    (zfs-auto-snapshot  (string-append
+                                         out
+                                         "/sbin/zfs-auto-snapshot"))
+                    (zfs-package        (assoc-ref inputs "zfs"))
+                    (zpool              (string-append
+                                         zfs-package
+                                         "/sbin/zpool"))
+                    (zfs                (string-append
+                                         zfs-package
+                                         "/sbin/zfs")))
+               (substitute* '("etc/zfs-auto-snapshot.cron.daily"
+                              "etc/zfs-auto-snapshot.cron.frequent"
+                              "etc/zfs-auto-snapshot.cron.hourly"
+                              "etc/zfs-auto-snapshot.cron.monthly"
+                              "etc/zfs-auto-snapshot.cron.weekly")
+                 (("zfs-auto-snapshot")
+                  zfs-auto-snapshot))
+               (substitute* "src/zfs-auto-snapshot.sh"
+                 (("LC_ALL=C zfs list")
+                  (string-append "LC_ALL=C " zfs " list"))
+                 (("LC_ALL=C zpool status")
+                  (string-append "LC_ALL=C " zpool " status"))
+                 (("zfs snapshot")
+                  (string-append zfs " snapshot"))
+                 (("zfs destroy")
+                  (string-append zfs " destroy"))))))
+         ;; Provide DESTDIR and PREFIX on make command.
+         (replace 'install
+           (lambda* (#:key outputs #:allow-other-keys)
+             (let ((out (assoc-ref outputs "out")))
+               (invoke "make" "install"
+                       "PREFIX="
+                       (string-append "DESTDIR=" out)))
+             #t)))))
+    (home-page "https://github.com/zfsonlinux/zfs-auto-snapshot")
+    (synopsis "Automatically create, rotate and destroy ZFS snapshots")
+    (description "An alternative implementation of the zfs-auto-snapshot
+service for Linux that is compatible with zfs-linux (now OpenZFS) and
+zfs-fuse.
+
+On Guix System, you will need to invoke the included shell scripts as
+@code{job} definitions in your @code{operating-system} declaration.")
+    (license license:gpl2+)))
+
 (define-public mergerfs
   (package
     (name "mergerfs")
@@ -1195,13 +1518,45 @@ local file system using FUSE.")
      `(("go-github-com-mattn-go-sqlite3" ,go-github-com-mattn-go-sqlite3)
        ("go-github-com-hanwen-fuse" ,go-github-com-hanwen-fuse)))
     (home-page "https://github.com/oniony/TMSU")
-    (synopsis "Tag files and access them through a virtual filesystem")
+    (synopsis "Tag files and access them through a virtual file system")
     (description
      "TMSU is a tool for tagging your files.  It provides a simple
-command-line utility for applying tags and a virtual filesystem to give you a
+command-line utility for applying tags and a virtual file system to give you a
 tag-based view of your files from any other program.  TMSU does not alter your
 files in any way: they remain unchanged on disk, or on the network, wherever
 your put them.  TMSU maintains its own database and you simply gain an
 additional view, which you can mount where you like, based upon the tags you
 set up.")
     (license license:gpl3+)))
+
+(define-public udftools
+  (package
+    (name "udftools")
+    (version "2.3")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/pali/udftools")
+                    (commit version)))
+              (sha256
+               (base32
+                "1nl2s61znyzaap23zhbdg3znj6l6akr313fchn5wwvjzj8k70is9"))
+              (file-name (git-file-name name version))))
+    (build-system gnu-build-system)
+    (arguments
+     `(#:configure-flags
+       (list (string-append "--docdir=" (assoc-ref %outputs "out")
+                            "/share/doc/" ,name "-" ,version))))
+    (native-inputs
+     `(("automake" ,automake)
+       ("autoconf" ,autoconf)
+       ("libtool" ,libtool)
+       ("pkg-config" ,pkg-config)))
+    (home-page "https://github.com/pali/udftools")
+    (synopsis "Tools to manage UDF file systems and DVD/CD-R(W) drives")
+    (description "@code{udftools} is a set of programs for reading
+and modifying @acronym{UDF, Universal Disk Format} file systems.
+@acronym{UDF, Universal Disk Format} is a file system mostly used for DVDs
+and other optical media.  It supports read-only media (DVD/CD-R)
+and rewritable media that wears out (DVD/CD-RW).")
+    (license license:gpl2+)))