;;; 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/model/generations.js" agpl3+)
        (javascript "/js/controller/packages.js" agpl3+)
        (javascript "/js/controller/packageInfo.js" agpl3+)
        (javascript "/js/controller/generations.js" agpl3+)
        (javascript "/js/view/packages.js" agpl3+)
        (javascript "/js/view/packageInfo.js" agpl3+)
        (javascript "/js/view/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)))

(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))))))