Add basic, hacky package installation.

* guix-web/controller.scm (controller): Add package installation route.
* guix-web/package.scm: New file.
* guix-web/render.scm (unprocessable-entity, created): New procedures.
* js/guix-packages.js (guix.PHASE_NONE, guix.PHASE_PROMPT,
  guix.PHASE_DERIVATION, guix.PHASE_SUCCESS, guix.PHASE_ERROR): New variables.
  (guix.controller.phase, guix.controller.selectedPackage): New properties.
  (guix.controller.prototype.installSelectedPackage): New method.
  (guix.view): Add modal for package installation UI.

4 files changed, 192 insertions, 4 deletions

diff --git a/guix-web/controller.scm b/guix-web/controller.scm
index f3858d3..bfa2f5e 100644
--- a/guix-web/controller.scm
+++ b/guix-web/controller.scm
@@ -22,6 +22,7 @@
   #:use-module (gnu packages)
   #:use-module (guix-web render)
   #:use-module (guix-web view)
+  #:use-module (guix-web package)
   #:export (controller))
 
 (define (controller path)
@@ -32,7 +33,7 @@
      (render-html (all-packages)))
     ((GET "packages.json")
      (render-json (all-packages-json)))
-    ((GET "package" name)
+    ((GET "packages" name)
      (match (string-split name #\.)
        ((name ext)
         (render-json
@@ -41,6 +42,11 @@
              '())))
        ((name)
         (render-html (view-package name)))))
+    ((POST "packages" name "install")
+     (let ((package (car (find-packages-by-name name))))
+       (if (package-install package)
+           (created)
+           (unprocessable-entity))))
     ((GET "librejs")
      (render-html (librejs)))
     (_ #f)))
diff --git a/guix-web/package.scm b/guix-web/package.scm
new file mode 100644
index 0000000..1e5da8a
--- /dev/null
+++ b/guix-web/package.scm
@@ -0,0 +1,53 @@
+;;; 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 package)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (guix derivations)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix ui)
+  #:use-module (gnu packages)
+  #:export (package-install))
+
+(define %store (open-connection))
+(define %profile "/usr/var/guix/profiles/per-user/dave/guix-profile")
+(define manifest (profile-manifest %profile))
+
+(define (maybe-register-gc-root store profile)
+  "Register PROFILE as a GC root, unless it doesn't need it."
+  (unless (string=? profile %profile)
+    (add-indirect-root store (canonicalize-path profile))))
+
+(define (package-install package)
+  (let* ((new (manifest-add manifest
+                            (list (package->manifest-entry package))))
+         (prof-drv (run-with-store %store
+                     (profile-derivation new)))
+         (prof     (derivation->output-path prof-drv)))
+    (let* ((number (generation-number %profile))
+           (name   (generation-file-name %profile
+                                         (+ 1 number))))
+      (and (build-derivations %store (list prof-drv))
+           (let* ((entries (manifest-entries new))
+                  (count   (length entries)))
+             (switch-symlinks name prof)
+             (switch-symlinks %profile name))))))
diff --git a/guix-web/render.scm b/guix-web/render.scm
index de5da7c..e4f8771 100644
--- a/guix-web/render.scm
+++ b/guix-web/render.scm
@@ -23,6 +23,8 @@
   #:export (render-html
             render-json
             not-found
+            unprocessable-entity
+            created
             redirect))
 
 (define (render-html sxml)
@@ -40,6 +42,14 @@
   (list (build-response #:code 404)
         (string-append "Resource not found: " (uri->string uri))))
 
+(define (unprocessable-entity)
+  (list (build-response #:code 422)
+        ""))
+
+(define (created)
+  (list (build-response #:code 201)
+        ""))
+
 (define (redirect path)
   (let ((uri (build-uri 'http
                         #:path (string-append
diff --git a/js/guix-packages.js b/js/guix-packages.js
index afbf4fb..10e59d8 100644
--- a/js/guix-packages.js
+++ b/js/guix-packages.js
@@ -54,6 +54,12 @@ guix.Sorter = (function() {
   return Sorter;
 })();
 
+guix.PHASE_NONE = 0;
+guix.PHASE_PROMPT = 1;
+guix.PHASE_DERIVATION = 2;
+guix.PHASE_SUCCESS = 3;
+guix.PHASE_ERROR = 4;
+
 guix.controller = (function() {
   function controller() {
     var self = this;
@@ -82,6 +88,8 @@ guix.controller = (function() {
       }
     ];
     this.sorter = m.prop(new guix.Sorter("name"));
+    this.phase = m.prop(guix.PHASE_NONE);
+    this.selectedPackage = m.prop(null);
 
     // All packages are visible initially
     this.packages.then(function(packages) {
@@ -136,6 +144,23 @@ guix.controller = (function() {
     this.doSearch();
   };
 
+  controller.prototype.installSelectedPackage = function() {
+    var self = this;
+
+    this.phase(guix.PHASE_DERIVATION);
+
+    m.request({
+      method: "POST",
+      url: "/packages/"
+        .concat(this.selectedPackage().name)
+        .concat("/install")
+    }).then(function() {
+      self.phase(guix.PHASE_SUCCESS);
+    }, function() {
+      self.phase(guix.PHASE_ERROR);
+    });
+  };
+
   return controller;
 })();
 
@@ -144,7 +169,7 @@ guix.view = function(ctrl) {
   function renderName(package) {
     var name = package.name;
 
-    return m("a", { href: "/package/".concat(name) }, name);
+    return m("a", { href: "/packages/".concat(name) }, name);
   }
 
   function renderHomepage(package) {
@@ -171,6 +196,17 @@ guix.view = function(ctrl) {
     }
   }
 
+  function renderInstallLink(package) {
+    return m("a", {
+      href: "#",
+      onclick: function() {
+        ctrl.selectedPackage(package);
+        ctrl.phase(guix.PHASE_PROMPT);
+        return false;
+      }
+    }, "install");
+  }
+
   function renderPagination() {
     function renderPage(text, opts) {
       return m("li", {
@@ -222,11 +258,93 @@ guix.view = function(ctrl) {
     return "sorter";
   }
 
+  function renderModal() {
+    function renderBody() {
+      switch(ctrl.phase()) {
+      case guix.PHASE_PROMPT:
+        return [
+          m("p", "Do you want to install the following packages?"),
+          m("ul", [
+            m("li", [
+              ctrl.selectedPackage().name,
+              " ",
+              ctrl.selectedPackage().version
+            ])
+          ])
+        ];
+      case guix.PHASE_DERIVATION:
+        return [
+          m("p", "Installing..."),
+          m(".progress", [
+            m(".progress-bar.progress-bar-striped.active", {
+              role: "progressbar",
+              style: { width: "100%" }
+            })
+          ])
+        ];
+      case guix.PHASE_SUCCESS:
+        return m(".alert.alert-success", "Installation complete!");
+      case guix.PHASE_ERROR:
+        return m(".alert.alert-danger", "Installation failed!");
+      }
+
+      return null;
+    }
+
+    function renderButtons() {
+      switch(ctrl.phase()) {
+      case guix.PHASE_PROMPT:
+        return [
+          m(".btn.btn-default", "Cancel"),
+          m(".btn.btn-primary", {
+            onclick: function() {
+              ctrl.installSelectedPackage();
+              m.redraw();
+            }
+          }, "Install"),
+        ];
+      case guix.PHASE_DERIVATION:
+        return m(".btn.btn-default.disabled", "Please wait...");
+      case guix.PHASE_SUCCESS:
+      case guix.PHASE_SUCCESS:
+        return m(".btn.btn-primary", {
+          onclick: function() {
+            ctrl.phase(guix.PHASE_NONE);
+          }
+        }, "Close");
+      }
+
+      return null;
+    }
+
+    if(ctrl.phase() != guix.PHASE_NONE) {
+      return [
+        m(".modal-backdrop.in"),
+        m("div.modal.modal-open", {
+          style: {
+            display: "block"
+          }
+        }, m(".modal-dialog", [
+          m(".modal-content", [
+            m(".modal-header", [
+              m("h4.modal-title", "Install Packages")
+            ]),
+            m(".modal-body", renderBody()),
+            m(".modal-footer", renderButtons())
+          ])
+        ]))
+      ];
+    }
+
+    return null;
+  }
+
   return [
     m("h2", [
       "Packages",
       m("span.badge", ctrl.packageCount())
     ]),
+    renderModal(),
     m("input.form-control", {
       type: "text",
       placeholder: "Search",
@@ -246,7 +364,7 @@ guix.view = function(ctrl) {
                 ctrl.sortBy(column.sortField);
               }
             }, column.header);
-           })
+          }).concat([m("th", "")])
         ])
       ]),
       m("tbody", [
@@ -256,7 +374,8 @@ guix.view = function(ctrl) {
             m("td", package.version),
             m("td", package.synopsis),
             m("td", renderHomepage(package)),
-            m("td", renderLicense(package))
+            m("td", renderLicense(package)),
+            m("td", renderInstallLink(package))
           ]);
         })
       ])