From 666485c94ffcd2e8ae64392e12fcc80065210bcd Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 9 Aug 2014 13:15:11 -0400
Subject: Add JSON endpoint for a specific package name.

* guix-web/controller.scm (controller): Allow use of '.json' file extension.
* guix-web/view.scm (view-package-json, license->json, package->json):
  New procedures.
  (all-packages-json): Refactor.
  (view-package): Filter out non-package inputs.
---
 guix-web/controller.scm | 11 ++++++-
 guix-web/view.scm       | 80 +++++++++++++++++++++++++++++++------------------
 2 files changed, 61 insertions(+), 30 deletions(-)

diff --git a/guix-web/controller.scm b/guix-web/controller.scm
index 6640810..f3858d3 100644
--- a/guix-web/controller.scm
+++ b/guix-web/controller.scm
@@ -17,7 +17,9 @@
 
 (define-module (guix-web controller)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (web request)
+  #:use-module (gnu packages)
   #:use-module (guix-web render)
   #:use-module (guix-web view)
   #:export (controller))
@@ -31,7 +33,14 @@
     ((GET "packages.json")
      (render-json (all-packages-json)))
     ((GET "package" name)
-     (render-html (view-package name)))
+     (match (string-split name #\.)
+       ((name ext)
+        (render-json
+         (if (string=? ext "json")
+             (view-package-json name)
+             '())))
+       ((name)
+        (render-html (view-package name)))))
     ((GET "librejs")
      (render-html (librejs)))
     (_ #f)))
diff --git a/guix-web/view.scm b/guix-web/view.scm
index 6898c28..adf064b 100644
--- a/guix-web/view.scm
+++ b/guix-web/view.scm
@@ -17,6 +17,7 @@
 
 (define-module (guix-web view)
   #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
   #:use-module (json)
   #:use-module (web uri)
   #:use-module (guix licenses)
@@ -25,6 +26,7 @@
   #:export (all-packages
             all-packages-json
             view-package
+            view-package-json
             librejs))
 
 (define javascripts
@@ -54,32 +56,53 @@
                   (rel "jslicense"))
                "JavaScript license information")))))))
 
-(define (all-packages-json)
+(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)
-    (define (serialize license)
-      (json
-       (object
-        ("name" ,(license-name license))
-        ("uri" ,(license-uri license)))))
     (let ((license (package-license package)))
       (cond
        ((list? license)
-        (map serialize license))
+        (map license->json license))
        ((license? license)
-        (serialize license))
+        (license->json license))
        (else #f))))
 
-  (json
-   ,(map (lambda (p)
-           (json
-            (object
-             ("name" ,(package-name p))
-             ("version" ,(package-version p))
-             ("synopsis" ,(package-synopsis p))
-             ("description" ,(package-description p))
-             ("homepage" ,(package-home-page p))
-             ("license" ,(serialize-license p)))))
-         (fold-packages cons '()))))
+  (define (serialize-inputs packages)
+    (map package->json (filter package? (map second packages))))
+
+  (if serialize-inputs?
+      (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))
+        ("inputs" ,(serialize-inputs (package-inputs package)))
+        ("native-inputs" ,(serialize-inputs (package-native-inputs package)))
+        ("propagated-inputs" ,(serialize-inputs
+                               (package-propagated-inputs package)))))
+      (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))))))
+
+(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)
@@ -107,20 +130,19 @@
 (define (view-package name)
   (define (describe-inputs package package-inputs description)
     (define (describe-input input)
-      (match input
-        ((_ input)
-         `(li
-           (a (@ (href ,(string-append
-                         "/"
-                         (encode-and-join-uri-path
-                          `("package" ,(package-name input))))))
-              ,(string-append (package-name input) " "
-                              (package-version 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 inputs)))))))
+            (dd (ul ,@(map describe-input
+                           (filter package? (second inputs)))))))))
 
   (define (describe-package package)
     `(dl
-- 
cgit v1.2.3