path: root/guix.scm

(define-module (guix)
  #:use-module (gnu packages autotools)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages build-tools)
  #:use-module (gnu packages check)
  #:use-module (gnu packages code)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages cppi)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages gtk)
  #:use-module (gnu packages imagemagick)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages tex)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages valgrind)
  #:use-module (gnu packages version-control)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix build utils)
  #:use-module (guix build-system gnu)
  #:use-module (guix gexp)
  #:use-module (guix git-download)
  #:use-module (guix git)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix derivations)
  #:use-module (guix download)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (srfi srfi-19))

(define git-exec
  (run-with-store
   (open-connection)
   (mlet %store-monad ((git (package->derivation git)))
         (mlet %store-monad ((built
                              (built-derivations
                               (list git))))
               (return (string-append (derivation->output-path git)
                                      "/bin/git"))))))

(define git-version-gen
  (run-with-store
   (open-connection)
   (mlet %store-monad ((gnulib (package->derivation gnulib)))
         (mlet %store-monad ((built
                              (built-derivations
                               (list gnulib))))
               (return (string-append (derivation->output-path gnulib)
                                      "/src/gnulib/build-aux/git-version-gen"))))))

(define disfluid:package-version
  (with-directory-excursion
      (dirname (current-filename))
    (let ((port (open-pipe* OPEN_READ "sh" git-version-gen ".tarball-version")))
      (let ((version (read-line port)))
        (when (eof-object? version)
          (set! version "0.0.0"))
        (close-port port)
	version))))

(define disfluid:commit-date
  (with-directory-excursion
      (dirname (current-filename))
    (let ((port (open-pipe* OPEN_READ git-exec "log" "-1" "--format=%ci")))
      (let ((date (read-line port)))
        (close-port port)
        (string->date date "~Y-~m-~d ~H:~M:~S ~z")))))

(define disfluid:source-file-db
  (let ((all-source-files
         (let ((port (open-pipe* OPEN_READ git-exec "ls-tree" "-r" "--name-only" "HEAD")))
           (let take-all ((taken '()))
             (let ((next (read-line port)))
               (cond
                ((eof-object? next)
                 (begin
                   (close-port port)
                   (reverse taken)))
                ((string=? next "gnulib")
                 ;; Ignore submodules
                 (take-all taken))
                (else
                 (take-all `(,next ,@taken)))))))))
    (map
     (lambda (source-file)
       `(,source-file
         ,(let ((port (open-pipe* OPEN_READ git-exec "log" "--pretty=format:%ai" "--author-date-order" source-file)))
            (let ((date (read-line port)))
              (when (eof-object? date)
                (format (current-error-port) "Your git repository is not deep enough to find a modification date for ~s.\n"
                        source-file)
                (error "git repository too shallow"))
              (close-port port)
              (string->date date "~Y-~m-~d ~H:~M:~S ~z")))))
     all-source-files)))

(define disfluid:authors
  (with-directory-excursion
      (dirname (current-filename))
    (let ((port (open-pipe* OPEN_READ git-exec "log" "--pretty=format:%an")))
      (let take-all ((taken '()))
        (let ((next (read-line port)))
          (if (eof-object? next)
              (begin
                (close-port port)
                (reverse taken))
              (take-all `(,next ,@taken))))))))

(define vc-list
  (program-file
   "vc-list"
   (with-imported-modules
       (source-module-closure '((guix build utils)))
     #~(begin
         (use-modules (guix build utils))
         (for-each
          (lambda (source-file)
            (format #t "~a\n" source-file))
          '(#$@(map (match-lambda
                      ((source-file _) source-file))
                    disfluid:source-file-db)))))))

(define find-mdate
  (program-file
   "find-mdate"
   (with-imported-modules
       (source-module-closure '((guix build utils)))
     #~(begin
         (use-modules (guix build utils))
         (format #t "~a\n"
                 #$(let find-manual ((db disfluid:source-file-db))
                     (match db
                       ((("doc/disfluid.texi" date) _ ...)
                        (date->string date "~4"))
                       ((_ db ...)
                        (find-manual db))
                       (()
                        (error "doc/disfluid.texi is not in the source file db")))))))))

(define list-authors
  (program-file
   "list-authors"
   (with-imported-modules
       (source-module-closure '((guix build utils)))
     #~(begin
         (use-modules (guix build utils))
         (for-each
          (lambda (author)
            (format #t "~a\n" author))
          '(#$@(begin disfluid:authors)))))))

(define disfluid:local-dir
  (dirname (current-filename)))

(define disfluid:package-source
  (git-checkout
   (url (string-append "file://" disfluid:local-dir))))

(define disfluid:translations
  (git-checkout
   (url (string-append "file://" (dirname (current-filename))))
   (branch "translations")))

(define po-download
  (program-file
   "po-download"
   (with-imported-modules
       (source-module-closure '((guix build utils)))
     #~(begin
         (use-modules (guix build utils) (ice-9 match))
         (match (command-line)
           ((_ directory _)
            (mkdir-p directory)
            (with-directory-excursion directory
              (copy-recursively #$(file-append disfluid:translations "/.") "."
                                #:follow-symlinks? #t
                                #:keep-permissions? #f
                                #:copy-file
                                (lambda (file dest)
                                  (copy-file file dest)
                                  (chmod dest #o644))))))))))

(define disfluid:raw-source
  (computed-file "disfluid-raw-source"
    (with-imported-modules
        (source-module-closure '((guix build utils)))
      #~(begin
          (use-modules (guix build utils))
          (mkdir-p #$output)
          (with-directory-excursion #$output
            (copy-recursively #$(file-append disfluid:package-source "/.") "."
                              #:follow-symlinks? #t)
            (call-with-output-file ".tarball-version"
              (lambda (port)
                (format port "~a\n" #$(begin disfluid:package-version))))
            (substitute* "bootstrap.conf"
              (("po_download_command_format=.*")
               (format #f "po_download_command_format=~s"
                       (string-append
                        #$po-download
                        " %s %s")))))))))

(define-public disfluid-boot
  (package
    (name "disfluid-boot")
    (version disfluid:package-version)
    (source disfluid:raw-source)
    (build-system gnu-build-system)
    (arguments
     (list
      #:configure-flags
      #~'("G_IR_SCANNER_FLAGS=--warn-all --warn-error")
      #:phases
      #~(modify-phases
            %standard-phases
          (add-before 'bootstrap 'bootstrap-bootstrap
            (lambda _
              (invoke "sh" "bootstrap-bootstrap")
              (for-each patch-shebang
                        '("autopull.sh" "autogen.sh"))
              (substitute* "bootstrap-funclib.sh"
                (("\\$gnulib_tool \\$gnulib_tool_options")
                 "sh $gnulib_tool $gnulib_tool_options"))))
          (add-after 'bootstrap 'fix-/bin/sh-in-po
            (lambda _
	      (substitute*
	          "po/Makefile.in.in"
	        (("SHELL = /bin/sh")
	         (format #f "SHELL = ~a" (which "sh"))))))
          (add-after 'check 'syntax-check
            (lambda _
              (invoke "make" "syntax-check"
                      (format #f "VC_LIST = ~a" #$vc-list)
                      (format #f "list_authors = ~a" #$list-authors)
                      (format #f "find_mdate = ~a" #$find-mdate))))
          (replace 'install
            (lambda _
              (patch-shebang "configure")
              (invoke "make" "-j8" "distcheck"
                      (format #f "DISTCHECK_CONFIGURE_FLAGS=SHELL=~a" (which "bash")))
              (invoke "tar" "xf" #$(format #f "disfluid-~a.tar.gz" disfluid:package-version))
              (with-directory-excursion
                  #$(format #f "disfluid-~a" disfluid:package-version)
                  (substitute* "po/Makefile.in.in"
                    (("SHELL = /gnu/store/.*/bin/sh")
                     "SHELL = /bin/sh"))
                  (substitute* "configure"
                    (("#!/gnu/store/.*/bin/sh")
                     "#!/bin/sh"))
                  (substitute* "configure"
                    (("/gnu/store/.*/bin/file")
                     "/bin/file"))
                  (with-directory-excursion "build-aux"
                    (substitute* '(
                                   "announce-gen"
                                   "ar-lib"
                                   "config.guess"
                                   "config.sub"
                                   "depcomp"
                                   "do-release-commit-and-tag"
                                   "git-version-gen"
                                   "gitlog-to-changelog"
                                   "install-sh"
                                   "ltmain.sh"
                                   "mdate-sh"
                                   "missing"
                                   "test-driver"
                                   "useless-if-before-free"
                                   "vc-list-files"
                                   "config.rpath"
                                   )
                      (("#!/gnu/store/.*/bin/sh")
                       "#!/bin/sh")))
                  (with-directory-excursion "tests/libgnu"
                    (substitute* '(
                                   "test-fflush2.sh"
                                   "test-fseek.sh"
                                   "test-fseek2.sh"
                                   "test-fseeko.sh"
                                   "test-fseeko2.sh"
                                   "test-fseeko3.sh"
                                   "test-fseeko4.sh"
                                   "test-ftell.sh"
                                   "test-ftell2.sh"
                                   "test-ftello.sh"
                                   "test-ftello2.sh"
                                   "test-ftello4.sh"
                                   "test-ftruncate.sh"
                                   "test-init.sh"
                                   "test-lseek.sh"
                                   "test-perror.sh"
                                   "test-select-in.sh"
                                   "test-select-out.sh"
                                   "test-setlocale1.sh"
                                   "test-setlocale2.sh"
                                   "test-string-desc.sh"
                                   "test-vc-list-files-cvs.sh"
                                   "test-vc-list-files-git.sh"
                                   "test-verify.sh"
                                   "test-binary-io.sh"
                                   )
                      (("#!/gnu/store/.*/bin/sh")
                       "#!/bin/sh")))
                  (with-directory-excursion "tests"
                    (substitute* '(
                                   "test-append.sh"
                                   )
                      (("#!/gnu/store/.*/bin/sh")
                       "#!/bin/sh"))))
              (invoke "sh" "-c" "grep '/gnu/store/' -R disfluid-* && exit 1 ; true")
              (mkdir-p #$output)
              (invoke "tar"
                      #$(format #f "--mtime=~a" (date->string disfluid:commit-date "~4"))
                      "--sort=name"
                      "--owner=0" "--group=0" "--numeric-owner"
                      "--pax-option=exthdr.name=%d/PaxHeaders/%f,delete=atime,delete=ctime"
                      "-cvzf" (string-append #$output "/complete-source.tar.gz")
                      #$(format #f "disfluid-~a" disfluid:package-version)))))))
    (native-inputs
     (list autoconf autoconf-archive automake libtool gnu-gettext
	   git valgrind/interactive
	   tar gzip global pkg-config
	   texinfo (texlive-updmap.cfg (list texlive))
           perl
           (let ((gnulib-base
                  (gnulib-checkout #:version "2023-04-02"
                                   #:commit "768593d575328a4b7c0fae0958f3d3af0a2ac3f9"
                                   #:hash (base32 "03ms53ynajmx3sfhvac4rm5barq395v83d7fykgx639kx8yb0iba"))))
           (package
             (inherit gnulib-base)
             (arguments
              (substitute-keyword-arguments (package-arguments gnulib-base)
                ((#:phases phases)
                 #~(modify-phases #$phases
                     (delete 'check)))))))
           gtk check (list glib "bin")
           gobject-introspection imagemagick
           indent cppi vala))
    (inputs
     (list gtk libadwaita check gnu-gettext gnutls))
    (home-page "https://labo.planete-kraus.eu/disfluid.git")
    (synopsis "Demanding Interoperability to Strengthen the Free/Libre Web: Introducing Disfluid")
    (description "This provides tools for web interoperability.")
    (license license:agpl3+)))

(package
  (inherit disfluid-boot)
  (name "disfluid")
  (source #f)
  (outputs (list "out" "complete-corresponding-source.tar.gz"))
  (arguments
   (list
    #:phases
    #~(modify-phases %standard-phases
        (replace 'unpack
          (lambda _
            (invoke "tar" "xf" #+(file-append disfluid-boot "/complete-source.tar.gz"))
            (chdir #$(format #f "disfluid-~a" disfluid:package-version))))
        (replace 'install-license-files
          (lambda _
            ;; Do not try to install COPYING in the
            ;; complete-corresponding-source.tar.gz output
            (let ((dir (format #f "~a/~a"
                               #$output
                               #$(format #f "share/doc/disfluid-~a"
                                         disfluid:package-version))))
              (mkdir-p dir)
              (copy-file "COPYING" (string-append dir "/COPYING")))))
        (add-after 'install 'install-complete-corresponding-source
          (lambda _
            (mkdir-p (string-append #$output "/share/disfluid"))
            (copy-file #+(file-append disfluid-boot "/complete-source.tar.gz")
                       #$output:complete-corresponding-source.tar.gz))))))
  (native-inputs
   (list valgrind (list glibc "debug") pkg-config
         texinfo (texlive-updmap.cfg (list texlive)) tar gzip))
  (inputs
   (list gnu-gettext gtk libadwaita check gnutls)))