1 files changed, 53 insertions, 0 deletions
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))))))