;;; guix-web - Web interface for GNU Guix
;;; Copyright © 2014  David Thompson <davet@gnu.org>
;;;
;;; 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
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-web view)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (json)
  #:use-module (web uri)
  #:use-module (guix licenses)
  #:use-module (guix packages)
  #:use-module (gnu packages)
  #:export (all-packages
            all-packages-json
            view-package
            view-package-json
            librejs))

(define-record-type <javascript>
  (javascript source-uri license)
  javascript?
  (source-uri javascript-source-uri)
  (license javascript-license))

(define (javascript-license-uri javascript)
  (let ((license (javascript-license javascript)))
    (cond
     ((eq? license expat)
      "http://www.jclark.com/xml/copying.txt")
     ((eq? license agpl3+)
      "https://www.gnu.org/licenses/agpl-3.0.html"))))

(define javascripts
  (list (javascript "/js/lib/underscore.js" expat)
        (javascript "/js/lib/mithril.js" expat)
        (javascript "/js/utils.js" agpl3+)
        (javascript "/js/view/layout.js" agpl3+)
        (javascript "/js/model/packages.js" agpl3+)
        (javascript "/js/view/packages.js" agpl3+)
        (javascript "/js/controller/packages.js" agpl3+)
        (javascript "/js/routes.js" agpl3+)))

(define (script-tag javascript)
  `(script (@ (type "text/javascript")
              (src ,(javascript-source-uri javascript)))
           ;; hack to ensure closing </script> tag
           ""))

(define (main-layout subtitle body)
  `(html
    (head
     (meta (@ (content "text/html;charset=utf-8")
              (http-equiv "Content-Type")))
     (title ,(string-append "GNU Guix - " subtitle))
     (link (@ (rel "stylesheet")
              (href "/css/bootstrap.css")))
     (link (@ (rel "stylesheet")
              (href "/css/guix.css"))))
    (body ,body)))

(define (license->json license)
  (json
   (object
    ("name" ,(license-name license))
    ("uri" ,(license-uri license)))))

(define* (package->json package #:optional serialize-inputs?)
  (define (serialize-license package)
    (let ((license (package-license package)))
      (cond
       ((list? license)
        (map license->json license))
       ((license? license)
        (license->json license))
       (else #f))))

  (define (serialize-inputs packages)
    (map package->json (filter package? (map second packages))))

  (json
   (object
    ("name" ,(package-name package))
    ("version" ,(package-version package))
    ("synopsis" ,(package-synopsis package))
    ("description" ,(package-description package))
    ("homepage" ,(package-home-page package))
    ("license" ,(serialize-license package))
    ,@(if serialize-inputs?
          `(("inputs" ,(serialize-inputs (package-inputs package)))
            ("native-inputs" ,(serialize-inputs
                               (package-native-inputs package)))
            ("propagated-inputs" ,(serialize-inputs
                                   (package-propagated-inputs package))))
          '()))))

(define (all-packages-json)
  (map package->json (fold-packages cons '())))

(define (view-package-json name)
  (map (lambda (p) (package->json p #t))
       (find-packages-by-name name)))

(define (render-package-license package)
  (define (license-link license)
    `(a (@ (href ,(license-uri license)))
        ,(license-name license)))

  (let ((license (package-license package)))
    (cond ((list? license)
           `(ul (@ (class "list-inline"))
                ,@(map (lambda (l)
                         `(li ,(license-link l)))
                       license)))
          ((license? license)
           (license-link license))
          (else ""))))

(define (all-packages)
  (main-layout "Packages" (map script-tag javascripts)))

;; This should be moved client-side and the server should just serve
;; the relevant JSON.
(define (view-package name)
  (define (describe-inputs package package-inputs description)
    (define (describe-input input)
      `(li
        (a (@ (href ,(string-append
                      "/"
                      (encode-and-join-uri-path
                       `("package" ,(package-name input))))))
           ,(string-append (package-name input) " "
                           (package-version input)))))
    (let ((inputs (package-inputs package)))
      (if (null? inputs)
          '()
          `((dt ,description)
            (dd (ul ,@(map describe-input
                           (filter package?
                                   (map second inputs)))))))))

  (define (describe-package package)
    `(dl
      (dt "Version")
      (dd ,(package-version package))
      (dt "Synopsis")
      (dd ,(package-synopsis package))
      (dt "Description")
      (dd ,(package-description package))
      (dt "License")
      (dd ,(render-package-license package))
      ,@(describe-inputs package package-inputs "Inputs")
      ,@(describe-inputs package package-native-inputs "Native Inputs")
      ,@(describe-inputs package package-propagated-inputs
                         "Propagated Inputs")))

  (let ((packages (find-packages-by-name name)))
    (define (format-package-count)
      (let ((count (length packages)))
        (format #f "~d ~a"
                count
                (if (> count 1)
                    "versions"
                    "version"))))

    (main-layout
     name
     `((h1 ,name (span (@ (class "badge"))
                       ,(format-package-count)))
       (ul (@ (class "list-unstyled"))
           ,@(map (lambda (p)
                    `(li ,(describe-package p)))
                  packages))))))

(define (librejs)
  (define (weblabel js)
    (let ((source (javascript-source-uri js)))
      `(tr
        (td
         (a (@ (href ,source))
            ,(basename source)))
        (td
         (a (@ (href ,(javascript-license-uri js)))
            ,(license-name (javascript-license js))))
        (td
         (a (@ (href ,source))
            ,(basename source))))))

  (main-layout
   "LibreJS"
   `(div (@ (class "container"))
         (div
          (a (@ (href "/"))
             (img (@ (src "/images/logo.png")))))
         (h1 "JavaScript License Information")
         (table (@ (id "jslicense-labels1")
                   (class "table"))
                (thead
                 (tr
                  (th "URI")
                  (th "License")
                  (th "Source Code")))
                (tbody ,@(map weblabel javascripts))))))