1 files changed, 68 insertions, 0 deletions
diff --git a/guix/web/package.scm b/guix/web/package.scm
new file mode 100644
index 0000000..f5a032c
--- /dev/null
+++ b/guix/web/package.scm
@@ -0,0 +1,68 @@
+;;; 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 (%all-packages
+            package-install
+            profile-generations*))
+
+(define %all-packages
+  (fold-packages cons '()))
+
+(define %profile
+  (string-append "/usr/var/guix/profiles/per-user/"
+                 (getenv "USER") "/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)
+  (with-store %store
+    (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)))))))
+
+(define (profile-generations*)
+  (map (lambda (n)
+         (cons n (reverse
+                  (manifest-entries
+                   (profile-manifest
+                    (generation-file-name %profile n))))))
+       (generation-numbers %profile)))