;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Marius Bakke <marius@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 (gnu packages browser-extensions)
  #:use-module (gcrypt base16)
  #:use-module ((gcrypt hash) #:prefix hash:)
  #:use-module (ice-9 iconv)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages check)
  #:use-module (gnu packages chromium)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages tls)
  #:use-module (gnu packages xorg)
  #:use-module (guix build-system trivial)

  ;; Imports for extension packages.
  #:use-module (guix git-download)
  #:use-module (guix build-system gnu)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages python)

  #:export (make-chromium-extension))

;; Chromium requires that each package is signed with a unique key, from which
;; the "extension ID" derives.  Currently the package name is used as seed.
(define (make-signing-key seed)
  "Return a derivation for a deterministic PKCS #8 private key using SEED."

  (define sha256sum
    (bytevector->base16-string (hash:sha256 (string->bytevector seed "UTF-8"))))

  ;; certtool.c wants a 56 byte seed for a 2048 bit key.
  (define size 2048)
  (define normalized-seed (string-take sha256sum 56))

  (computed-file (string-append seed "-signing-key.pem")
                 #~(system* #$(file-append gnutls "/bin/certtool")
                            "--generate-privkey"
                            "--key-type=rsa"
                            "--pkcs8"
                            ;; Use the provable FIPS-PUB186-4 algorithm for
                            ;; deterministic results.
                            "--provable"
                            "--password="
                            "--no-text"
                            (string-append "--bits=" #$(number->string size))
                            (string-append "--seed=" #$normalized-seed)
                            "--outfile" #$output)))

(define* (make-crx package #:optional (chromium-output "out"))
  ;; XXX: This is terrible.  We pull Xorg and Chromium just to pack and
  ;; sign an extension.  This should be implemented with something lighter
  ;; using the protobuf-based protocol (TODO: where is it documented..?).
  (define name (package-name package))
  (define version (package-version package))
  (define signing-key (make-signing-key name))

  (with-imported-modules '((guix build utils))
    (computed-file
     (string-append name "-" version ".crx")
     #~(begin
         (use-modules (guix build utils)
                      (ice-9 ftw)
                      (srfi srfi-26))
         (let ((chromium #$(file-append ungoogled-chromium "/bin/chromium"))
               (xvfb #$(file-append xorg-server "/bin/Xvfb"))
               (packdir (string-append "/tmp/extension/" #$name)))
           (mkdir-p (dirname packdir))
           (copy-recursively (ungexp package chromium-output) packdir)
           (system (string-append xvfb " :1 &"))
           (setenv "DISPLAY" ":1")
           (sleep 2)  ;give Xorg some time to initialize...
           ;; Chromium stores the current time in the .crx Zip archive.
           ;; Sidestep that by using "faketime" for determinism.
           ;; FIXME (core-updates): faketime is missing an absolute reference
           ;; to 'date', hence the need to set PATH.
           (setenv "PATH" #$(file-append coreutils "/bin"))
           (invoke #$(file-append libfaketime "/bin/faketime")
                   "2000-01-01 00:00:00"
                   chromium
                   "--user-data-dir=/tmp/signing-profile"
                   (string-append "--pack-extension=" packdir)
                   (string-append "--pack-extension-key=" #$signing-key))
           (copy-file (string-append packdir ".crx") #$output))))))

(define* (package->chromium-json package #:optional (chromium-output "out"))
  "Return a derivation that creates a JSON file for PACKAGE, meant to be
consumed by Chromium to make the installed extension visible."

  (define name (package-name package))
  (define version (package-version package))
  (define crx (make-crx package chromium-output))

  (computed-file (string-append name "-" version ".json")
                 #~(call-with-output-file #$output
                     (lambda (port)
                       ;; Documentation for the JSON format can be found in
                       ;; extensions/common/extension.h and
                       ;; chrome/browser/extensions/external_provider_impl.cc.
                       (format port "
{
  \"external_crx\": \"~a\",
  \"external_version\": \"~a\"
}
"
                               #$crx #$version)))))


(define (key->der key)
  "Return a derivation for a file representation of KEY in DER format."
  (computed-file "der"
                 #~(system* #$(file-append gnutls "/bin/certtool")
                            "--load-privkey" #$key
                            "--pubkey-info"
                            "--outfile" #$output
                            "--outder")))

(define (gexp-sha256sum file)
  "Return a derivation for a base16 representation of the SHA256 checksum
of FILE."
  (with-extensions (list guile-gcrypt)
    #~(begin
        (use-modules (gcrypt base16) (gcrypt hash))
        (format #f (bytevector->base16-string (file-sha256 #$file))))))

(define (chromium-json->profile-object json signing-key)
  "Return a derivation that installs JSON to the destination searched by
Chromium, using a file name (aka extension ID) derived from SIGNING-KEY."
  (define der (key->der signing-key))
  (define checksum (gexp-sha256sum der))

  (with-imported-modules '((guix build utils))
    (computed-file
     "chromium-extension"
     #~(begin
         (use-modules (guix build utils))
         (define (base16-string->chromium-base16 str)
           ;; Translate STR, a hexadecimal string, to a Chromium-style
           ;; representation using the letters a-p (where a=0, p=15).
           (define s1 "0123456789abcdef")
           (define s2 "abcdefghijklmnop")
           (let loop ((chars (string->list str))
                      (converted '()))
             (if (null? chars)
                 (list->string (reverse converted))
                 (loop (cdr chars) (cons (string-ref
                                          s2 (string-index s1 (car chars)))
                                         converted)))))

         (let ((file-name (base16-string->chromium-base16
                           (string-take #$checksum 32)))
               (extension-directory (string-append #$output
                                                   "/share/chromium/extensions")))
           (mkdir-p extension-directory)
           (symlink #$json (string-append extension-directory "/"
                                          file-name ".json")))))))

(define* (make-chromium-extension p #:optional (output "out"))
  "Create a signed \".crx\" file from package P, an unpacked Chromium
extension, and return a derivation for a package that makes the packed
extension visible to Chromium when installed to a Guix profile.

OUTPUT can be used to specify which output of P contains the Chromium
extension directory."
  (package
    (inherit p)
    (name (string-append (package-name p) "-chromium"))
    (build-system trivial-build-system)
    (native-inputs '())
    (inputs
     `(("extension" ,(chromium-json->profile-object
                      (package->chromium-json p output)
                      (make-signing-key (package-name p))))))
    (propagated-inputs '())
    (outputs '("out"))
    (arguments
     '(#:modules ((guix build utils))
       #:builder
       (begin
         (use-modules (guix build utils))
         (copy-recursively (assoc-ref %build-inputs "extension")
                           (assoc-ref %outputs "out")))))))

\f

(define uassets
  (let ((commit "95d609786680bf4cf267b1dff3f429af88040da1"))
    (origin
      (method git-fetch)
      (uri (git-reference
            (url "https://github.com/uBlockOrigin/uAssets.git")
            (commit commit)))
      (file-name (git-file-name "uAssets" (string-take commit 9)))
      (sha256
       (base32
        "070v2g0hyxvqv77b6z404hdlggl0sq2bfhsfl4a84k93p9pwwlrq")))))

(define ublock-origin
  (package
    (name "ublock-origin")
    (version "1.30.8")
    (home-page "https://github.com/gorhill/uBlock")
    (source (origin
              (method git-fetch)
              (uri (git-reference (url home-page) (commit version)))
              (file-name (git-file-name name version))
              (sha256
               (base32
                "1y4dq4p4j4qrw6gfdcbpyigqjinqq3jm8r5x9h5ariiv9s8856w7"))))
    (build-system gnu-build-system)
    ;; XXX: The xpi and firefox outputs are currently unused, but included
    ;; for easy testing.
    (outputs '("xpi" "firefox" "chromium"))
    (arguments
     '(#:tests? #f                      ;no tests
       #:allowed-references ()
       #:phases
       (modify-phases (map (lambda (phase)
                             (assq phase %standard-phases))
                           '(set-paths unpack patch-source-shebangs))
         (add-after 'unpack 'link-uassets
           (lambda* (#:key native-inputs inputs #:allow-other-keys)
             (symlink (string-append (assoc-ref (or native-inputs inputs)
                                                "uassets"))
                      "../uAssets")
             #t))
         (add-after 'unpack 'make-files-writable
           (lambda _
             ;; The build system copies some files and later tries
             ;; modifying them.
             (for-each make-file-writable (find-files "."))
             #true))
         (add-after 'patch-source-shebangs 'build-xpi
           (lambda _
             (invoke "./tools/make-firefox.sh" "all")))
         (add-after 'build-xpi 'build-chromium
           (lambda _
             (invoke "./tools/make-chromium.sh")))
         (add-after 'build-chromium 'install
           (lambda* (#:key outputs #:allow-other-keys)
             (let ((firefox (assoc-ref outputs "firefox"))
                   (xpi (assoc-ref outputs "xpi"))
                   (chromium (assoc-ref outputs "chromium")))
               (install-file "dist/build/uBlock0.firefox.xpi"
                             (string-append xpi "/lib/mozilla/extensions"))
               (copy-recursively "dist/build/uBlock0.firefox" firefox)
               (copy-recursively "dist/build/uBlock0.chromium" chromium)
               #true))))))
    (native-inputs
     `(("python" ,python-wrapper)
       ("uassets" ,uassets)
       ("zip" ,zip)))
    (synopsis "Block unwanted content from web sites")
    (description
     "uBlock Origin is a @dfn{wide spectrum blocker} for IceCat and
ungoogled-chromium.")
    (license license:gpl3+)))

(define-public ublock-origin/chromium
  (make-chromium-extension ublock-origin "chromium"))