;;; guix-web - Web interface for GNU Guix
;;; Copyright © 2014, 2015  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 html)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (web uri)
  #:use-module (guix licenses)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (gnu packages)
  #:use-module (guix-web package)
  #:export (all-packages
            view-package
            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/ui.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/model/generations.js" agpl3+)
        (javascript "/js/view/generations.js" agpl3+)
        (javascript "/js/controller/generations.js" agpl3+)
        (javascript "/js/routes.js" agpl3+)))

(define stylesheets
  (list "/css/bootstrap.css"
        "/css/guix.css"))

(define (render-javascript javascript)
  `(script (@ (type "text/javascript")
              (src ,(javascript-source-uri javascript)))))

(define (render-stylesheet stylesheet-uri)
  `(link (@ (rel "stylesheet")
            (href ,stylesheet-uri))))

(define (main-layout subtitle body)
  `((doctype "HTML")
    (html
     (head
      (meta (@ (content "text/html;charset=utf-8")
               (http-equiv "Content-Type")))
      (title ,(string-append "GNU Guix - " subtitle))
      ,@(map render-stylesheet stylesheets))
     (body ,body))))

(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 render-javascript 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))
            ,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))))))