;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021  Vivien Kraus

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.

;; This program 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 Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (vkraus packages disfluid)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix build-system gnu)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages guile-xyz)
  #:use-module (gnu packages nettle)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages tex)
  #:use-module (gnu packages autotools)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages man)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages gtk)
  #:use-module (gnu packages gnome)
  #:use-module (ice-9 match)
  #:use-module (ice-9 optargs)
  #:use-module (sxml simple))

(define disfluid-snapshot
  (package
   (name "disfluid-snapshot")
   (version "SNAPSHOT")
   (source "./disfluid-SNAPSHOT.tar.gz")
   (build-system gnu-build-system)
   (arguments
    '(#:modules ((guix build utils)
                 (guix build gnu-build-system)
                 (ice-9 rdelim)
                 (ice-9 popen))
      #:phases
      (modify-phases
       %standard-phases
       (add-after
        'install 'wrap-program
        (lambda* (#:key native-inputs inputs outputs #:allow-other-keys)
          (define (remove-duplicates list)
            (define (aux selected seen-table rest)
              (if (null? rest)
                  (reverse selected)
                  (let ((next (car rest))
                        (rest (cdr rest)))
                    (if (hash-ref seen-table next #f)
                        (aux selected seen-table rest)
                        (begin
                          (hash-set! seen-table next #t)
                          (aux (cons next selected) seen-table rest))))))
            (aux '() (make-hash-table (length list)) list))
          (let* ((out (assoc-ref outputs "out"))
                 (the-guile (assoc-ref (or native-inputs inputs) "guile"))
                 (the-guile-exec (format #f "~a/bin/guile" the-guile))
                 (effective-version
                  (read-line
                   (open-pipe* OPEN_READ
                               the-guile-exec
                               "-c"
                               "(display (effective-version))")))
                 (all-inputs
                  (remove-duplicates
                   (cons out
                         (map cdr inputs))))
                 (mod-paths
                  (filter
                   file-exists?
                   (map (lambda (prop-input)
                          (format #f "~a/share/guile/site/~a"
                                  prop-input effective-version))
                        all-inputs)))
                 (go-paths
                  (filter
                   file-exists?
                   (map (lambda (prop-input)
                          (format #f "~a/lib/guile/~a/site-ccache"
                                  prop-input effective-version))
                        all-inputs)))
                 (typelib-paths
                  (filter
                   file-exists?
                   (map (lambda (input)
                          (format #f "~a/lib/girepository-1.0"
                                  input))
                        all-inputs))))
            (wrap-program
             (format #f "~a/bin/disfluid" out)
             `("GUILE_LOAD_PATH" ":" = ,mod-paths)
             `("GUILE_LOAD_COMPILED_PATH" ":" = ,go-paths)
             `("GI_TYPELIB_PATH" ":" = ,typelib-paths))
            (symlink (format #f "~a/bin/disfluid" out)
                     (format #f "~a/bin/webid-oidc" out))
            (for-each
             (lambda (program)
               (wrap-program
                   (format #f "~a/bin/disfluid-~a" out program)
                 `("GUILE_LOAD_PATH" ":" = ,mod-paths)
                 `("GUILE_LOAD_COMPILED_PATH" ":" = ,go-paths)
                 `("GI_TYPELIB_PATH" ":" = ,typelib-paths)))
             '(example-app hello))))))))
   (native-inputs
    `(("pkg-config" ,pkg-config)
      ("guile" ,guile-3.0)
      ("guile-json" ,guile-json-4)
      ("guile-rdf" ,guile-rdf)
      ("guile-jsonld" ,guile-jsonld)
      ("guile-readline" ,guile-readline)
      ("texinfo" ,texinfo)
      ("autoconf" ,autoconf)
      ("autoconf-archive" ,autoconf-archive)
      ("automake" ,automake)
      ("libtool" ,libtool)
      ("gettext" ,gnu-gettext)
      ("coreutils" ,coreutils) ;; for link (wrap-program)
      ("help2man" ,help2man)
      ("which" ,which)
      ("glib" ,glib)
      ("glib" ,glib "bin")
      ("gtk+" ,gtk+)
      ("gtk" ,gtk)
      ("libhandy" ,libhandy)
      ("gobject-introspection" ,gobject-introspection)
      ("vala" ,vala)))
   (inputs `(("guile" ,guile-3.0)
             ("guile-json" ,guile-json-4)
             ("guile-rdf" ,guile-rdf)
             ("guile-jsonld" ,guile-rdf)
             ("guile-gi" ,guile-gi)
             ("gnutls" ,gnutls)
             ("nettle" ,nettle)
             ("gtk+" ,gtk+)
             ("gtk" ,gtk)
             ("libhandy" ,libhandy)))
   (synopsis "Demanding Interoperability to Strengthen the Free (Libre) Web: Introducing Disfluid")
   (description "Demanding Interoperability to Strengthen the Free (Libre) Web: Introducing Disfluid")
   (home-page "https://labo.planete-kraus.eu/webid-oidc.git")
   (license license:agpl3+)
   (native-search-paths
    (list (search-path-specification
           (variable "LTDL_LIBRARY_PATH")
           (files '("lib")))))))

(define*-public (disfluid-release
                 #:key version release-date manual-mdate commit-id hash)
  (package
   (inherit disfluid-snapshot)
   (name "disfluid")
   (version version)
   (source
    (origin
     (method git-fetch)
     (uri (git-reference
           (url "https://labo.planete-kraus.eu/webid-oidc.git")
           (commit commit-id)))
     (sha256 (base32 hash))
     (snippet
      `(begin
         (with-output-to-file ".tarball-version"
           (lambda _ (format #t "~a~%" ,version)))
         (with-output-to-file ".tarball-release-date"
           (lambda _ (format #t "~a~%" ,release-date)))
         (with-output-to-file ".manual-mdate"
           (lambda _ (format #t "~a~%" ,manual-mdate)))
         #t))))))

(define*-public (disfluid-branch-snapshot
                 #:key branch-name version manual-mdate release-date commit-id hash)
  (package
    (inherit (disfluid-release
              #:version version
              #:manual-mdate manual-mdate
              #:release-date release-date
              #:commit-id commit-id
              #:hash hash))
    (name (string-append "disfluid-snapshot-" branch-name))))

(define-public (disfluid-htmlize disfluid)
  (package
   (inherit disfluid)
   (name "disfluid-html")
   (arguments
    '(#:modules ((guix build utils)
                 (guix build gnu-build-system)
                 (ice-9 textual-ports))
      #:phases
      (modify-phases
       %standard-phases
       (add-after
        'build 'build-html
        (lambda* (#:key make-flags parallel-build? #:allow-other-keys)
          (apply invoke "make" "html"
                 `(,@(if parallel-build?
                         `("-j" ,(number->string (parallel-job-count)))
                         '())
                   ,@make-flags))))
       (add-after
        'build-html 'build-pdf
        (lambda* (#:key make-flags parallel-build? #:allow-other-keys)
          (apply invoke "make" "pdf"
                 `(,@(if parallel-build?
                         `("-j" ,(number->string (parallel-job-count)))
                         '())
                   ,@make-flags))))
       (add-after
        'build-pdf 'complete-corresponding-source
        (lambda* (#:key make-flags parallel-build? #:allow-other-keys)
          (apply invoke "make" "dist"
                 `(,@(if parallel-build?
                         `("-j" ,(number->string (parallel-job-count)))
                         '())
                   ,@make-flags))))
       (replace
        'install
        (lambda* (#:key make-flags parallel-build? outputs #:allow-other-keys)
          (apply invoke "make" "install-pdf" "install-html"
                 `(,@(if parallel-build?
                         `("-j" ,(number->string (parallel-job-count)))
                         '())
                   ,@make-flags))
          (let ((version
                 (car
                  (string-split
                   (call-with-input-file ".tarball-version"
                     get-string-all)
                   #\newline))))
            (symlink (string-append
                      (assoc-ref outputs "out")
                      "/share/doc/disfluid/disfluid.pdf")
                     (string-append
                      (assoc-ref outputs "out")
                      "/share/doc/disfluid/disfluid.html/disfluid.pdf"))
            (copy-file (string-append
                        "disfluid-" version ".tar.gz")
                       (string-append
                        (assoc-ref outputs "out")
                        "/share/doc/disfluid/disfluid.html/complete-corresponding-source.tar.gz"))))))))
   (native-inputs
    `(("texlive"
       ,(texlive-union (list texlive-tex-texinfo)))
      ,@(package-native-inputs disfluid)))
   (synopsis "HTML documentation for Disfluid")
   (description "The manual for disfluid is provided as a texinfo
file, which is exported to HTML and PDF. Also include the complete
corresponding source, as an AGPL requirement.")))

(define-public (make-website master-disfluid branch-disfluids)
  (directory-union
   "website"
   `(,(file-append (disfluid-htmlize disfluid) "/share/doc/disfluid/disfluid.html")
     ,(file-union
       "branch-subdirectory"
       `(("refs"
          ,(file-union
            "branch-websites"
            `(("index.html"
               ,(plain-file
                 "branch-index"
                 (call-with-output-string
                   (lambda (port)
                     (sxml->xml
                      `(*TOP*
                        (html (@ (href "http://www.w3.org/1999/xhtml")
                                 (xml:lang "en"))
                              (head (title "Other versions"))
                              (body
                               (h1 "Other versions of the manual")
                               ,@(let ((lis
                                        (map
                                         (match-lambda
                                           ((branch . _)
                                            `(li (a (@ (href ,branch)) ,branch))))
                                         branch-disfluids)))
                                   (if (null? lis)
                                       `((p "The manual is not available for any branch."))
                                       `((p "The manual is available for these development branches:")
                                         (ul ,@lis)))))))
                      port)))))
              ,@(map
                 (match-lambda
                   ((branch . package)
                    `(,branch ,(file-append (disfluid-htmlize package) "/share/doc/disfluid/disfluid.html"))))
                 branch-disfluids)))))))))
(define-public disfluid-snapshot-better-web-api (disfluid-branch-snapshot #:branch-name "better-web-api" #:version "0.6.1-9-gd0fce36" #:manual-mdate "2021-10-21T09:45:14+02:00" #:release-date "2021-11-09T13:55:22+01:00" #:commit-id "d0fce362dbdc3f8c8952cd1c4bbda77e5c72ed50" #:hash "1fvya03342wf159ilhai13m300xyyqmj8q74wilqjdmncjyvksvg"))
(define-public disfluid-snapshot-debug (disfluid-branch-snapshot #:branch-name "debug" #:version "0.6.1-31-gcd841f9" #:manual-mdate "2021-10-21T09:45:14+02:00" #:release-date "2021-11-14T16:49:56+00:00" #:commit-id "cd841f9cc9457bf008a7890723d831b5cbf4e2f0" #:hash "1xp60njv41dppgm1bvj64qcjr9hqlgrjqjqy1gj643521pbljg03"))
(define-public disfluid (disfluid-release #:version "0.6.1-31-gcf5d6f3" #:manual-mdate "2021-10-21T09:45:14+02:00" #:release-date "2021-12-15T17:19:53+01:00" #:commit-id "cf5d6f3f745986e8b6e8ae293124ede20b786678" #:hash "0vjfzpbp83ahhpkl8a15p9q712i46ibcgw1k47lmfqid35wy13mv"))
(define-public disfluid-snapshot-master (disfluid-branch-snapshot #:branch-name "master" #:version "0.6.1-31-gcf5d6f3" #:manual-mdate "2021-10-21T09:45:14+02:00" #:release-date "2021-12-15T17:19:53+01:00" #:commit-id "cf5d6f3f745986e8b6e8ae293124ede20b786678" #:hash "0vjfzpbp83ahhpkl8a15p9q712i46ibcgw1k47lmfqid35wy13mv"))
(define-public disfluid:website (make-website disfluid (list (cons "better-web-api" disfluid-snapshot-better-web-api) (cons "debug" disfluid-snapshot-debug) (cons "master" disfluid-snapshot-master))))