Rework installer paths

yitzchak · yitzchak · commit abe87bc58572 · 2022-04-23T11:59:09.000-04:00
diff --git a/common-lisp-jupyter.asd b/common-lisp-jupyter.asd
@@ -13,7 +13,7 @@
      #:cl-indentify
      #:closer-mop
      #:dissect
-     ; This should be `(:feature (:not :clasp) :ironclad)` but some distributions still don't have
+     ; This should be `(:feature (:not :clasp) :ironclad)` but some implementations still don't have
      ; ASDF 3
      #-clasp :eclector
      #-clasp :ironclad
@@ -25,6 +25,7 @@
      #:trivial-garbage
      #:trivial-gray-streams
      #:trivial-mimes
+     #:trivial-features
      #:shasht)
   :components
     ((:module res
diff --git a/src/cl-jupyter/installer.lisp b/src/cl-jupyter/installer.lisp
@@ -75,7 +75,7 @@
     (append (list (or implementation
                       (first (uiop:raw-command-line-arguments))
                       (format nil "~(~A~)" (uiop:implementation-type)))
-                  +load-flag+ (namestring (jupyter:installer-path instance :root :program :bundle))
+                  +load-flag+ (namestring (jupyter:installer-path instance :bundle))
                   +eval-flag+ (if (find-package :quicklisp)
                                 "(ql:quickload :common-lisp-jupyter)"
                                 "(asdf:load-system :common-lisp-jupyter)"))
@@ -105,7 +105,7 @@
       '("{connection_file}"))))
 
 
-(defun install (&key bin-path implementation system bundle local prefix root
+(defun install (&key bin-path implementation system bundle local prefix jupyter program
                      (load-system t))
   "Install Common Lisp kernel based on the current implementation.
 - `bin-path` specifies path to LISP binary.
@@ -114,7 +114,7 @@
 - `bundle` creates a quicklisp bundle for system installations.
 - `local` toggles `/usr/local/share versus` `/usr/share` for system installations.
 - `prefix` key specifies directory prefix for packaging.
-- `root` key specifies the root under which the Jupyter folder is found. Is automatically determined if not provided."
+- `jupyter` key specifies the root under which the Jupyter folder is found. Is automatically determined if not provided."
   (jupyter:install
     (make-instance
       (cond
@@ -146,14 +146,15 @@
                                                    (lisp-implementation-type)))
           +language+)
       :prefix prefix
-      :root root)))
+      :jupyter-path jupyter
+      :program-path program)))
 
 
-(defun install-image (&key implementation prefix root)
+(defun install-image (&key implementation prefix jupyter program)
   "Install Common Lisp kernel based on image of current implementation.
 - `implementation` toggles including implementation details in kernel name.
 - `prefix` key specifies directory prefix for packaging.
-- `root` key specifies the root under which the Jupyter folder is found. Is automatically determined if not provided."
+- `jupyter` key specifies the root under which the Jupyter folder is found. Is automatically determined if not provided."
   (jupyter:install
     (make-instance 'user-image-installer
       :display-name
@@ -169,7 +170,8 @@
                                                    (lisp-implementation-type)))
           +language+)
       :prefix prefix
-      :root root)))
+      :jupyter-path jupyter
+      :program-path program)))
 
 
 (defun install-roswell (&key implementation)
diff --git a/src/installer.lisp b/src/installer.lisp
@@ -47,11 +47,16 @@
      :initform nil
      :accessor installer-resources
      :documentation "List of paths of resource files such as icons.")
-   (root
-     :initarg :root
+   (jupyter-path
+     :initarg :jupyter-path
      :initform nil
-     :accessor installer-root
-     :documentation "The root directory under which the Jupyter folder is found. If nil then it will be determined automatically.")
+     :accessor installer-jupyter-path
+     :documentation "The Jupyter directory. If nil then it will be determined automatically.")
+   (program-path
+     :initarg :program-path
+     :initform nil
+     :accessor installer-program-path
+     :documentation "The program directory. If nil then it will be determined automatically.")
    (systems
      :initarg :systems
      :initform nil
@@ -75,105 +80,84 @@
   ()
   (:documentation "User image installer class."))
 
-(defgeneric installer-path-part (instance part)
-  (:documentation "Get a specific part of an installer path. part is a keyword symbol specifying which part."))
-
-(defmethod installer-path-part (instance (part (eql :prefix)))
-  "Get the directory prefix if it exists."
-  (with-slots (prefix) instance
-    (if prefix
-      (merge-pathnames
-        (uiop:relativize-pathname-directory (installer-path-part instance :root))
-        (truename prefix))
-      (installer-path-part instance :root))))
-
-(defmethod installer-path-part ((instance system-installer) (type (eql :root)))
-  "Get the root directory for a system installation."
-  (cond
-    ((installer-root instance)
-      (installer-root instance))
-    ((uiop:os-windows-p) ; Use %PROGRAMDATA% on Windows
-      (uiop:getenv-absolute-directory "PROGRAMDATA"))
-    ((installer-local instance) ; /usr/local/share/
-      (make-pathname :directory '(:absolute "usr" "local" "share")))
-    (t ; /usr/share/
-      (make-pathname :directory '(:absolute "usr" "share")))))
-
-(defmethod installer-path-part ((instance user-installer) (type (eql :root)))
-  "Get the root directory for a user installation"
-  (cond
-    ((installer-root instance)
-      (installer-root instance))
-    ((uiop:os-macosx-p) ; use $HOME/Library/ on Mac
-      (merge-pathnames (make-pathname :directory '(:relative "Library"))
-                       (uiop:getenv-pathname "HOME" :ensure-directory t)))
-    ((uiop:os-windows-p) ; Use %APPDATA% on Windows
-      (uiop:get-folder-path :appdata))
-    (t ; Use XDG_DATA_HOME on all other platforms
-      (uiop:xdg-data-home))))
-
-(defmethod installer-path-part (instance (part (eql :kernel)))
-  "Get the kernel directory."
-  (make-pathname
-    :directory
-      (list
-        :relative
-        ; Just in case HFS+ is case-sensitive
-        (if (uiop:os-macosx-p) "Jupyter" "jupyter")
-        "kernels"
-        (installer-kernel-name instance))))
-
-(defmethod installer-path-part (instance (part (eql :program)))
-  "Get the program directory."
-  (make-pathname
-    :directory
-      (list
-        :relative
-        (format nil "~A-jupyter" (installer-kernel-name instance)))))
-
-(defmethod installer-path-part (instance (part (eql :spec)))
-  "Get the kernel spec file name."
-  (make-pathname :name "kernel" :type "json"))
-
-(defmethod installer-path-part (instance (part (eql :image)))
-  "Get the image file name."
-  (make-pathname :name "image" :type (when (uiop:os-windows-p) "exe")))
-
-(defmethod installer-path-part (instance (part (eql :bundle)))
-  "Get the Quicklisp bundle file name."
-  (make-pathname :name "bundle" :type "lisp"))
-
-(defmethod installer-path-part (instance (part (eql :local-projects)))
-  "Get the local-projects directory."
-  (make-pathname
-    :directory (list :relative "local-projects")))
-
-(defmethod installer-path-part (instance (part string))
-  "If the part is a string then just return it."
-  part)
-
-(defmethod installer-path-part (instance (part pathname))
-  "If the part is already a pathname then just return it."
-  part)
-
-(defun installer-path (instance &rest parts)
-  "Resolve each of the path parts then combine all into a single path using merge-pathnames."
-  (reduce
-    (lambda (previous part)
-      (merge-pathnames
-        (installer-path-part instance part)
-        previous))
-    parts
-    :initial-value (make-pathname)))
+(defgeneric installer-path (instance name))
+
+(defmethod installer-path (instance (name (eql :spec)))
+  (merge-pathnames (make-pathname :name "kernel" :type "json")
+                   (installer-path instance :kernel)))
+
+(defmethod installer-path (instance (name (eql :kernel)))
+  (merge-pathnames (make-pathname :directory (list :relative
+                                                   "kernels"
+                                                   (installer-kernel-name instance)))
+                   (installer-path instance :jupyter)))
+
+(defun add-prefix (instance path)
+  (if (installer-prefix instance)
+      (merge-pathnames (uiop:relativize-pathname-directory path)
+                       (truename (installer-prefix instance)))
+      path))
+
+(defmethod installer-path ((instance system-installer) (name (eql :root)))
+  #+windows
+    (uiop:getenv-absolute-directory "PROGRAMDATA")
+  #-windows
+    (make-pathname :directory (if (installer-local instance)
+                                  '(:absolute "usr" "local" "share")
+                                  '(:absolute "usr" "share"))))
+
+(defmethod installer-path ((instance user-installer) (name (eql :root)))
+  #+darwin
+    (merge-pathnames (make-pathname :directory '(:relative "Library"))
+                     (uiop:getenv-pathname "HOME" :ensure-directory t))
+  #+windows
+    (uiop:get-folder-path :appdata)
+  #-(or darwin windows)
+    (uiop:xdg-data-home))
+
+(defmethod installer-path ((instance system-installer) (name (eql :jupyter)))
+  (add-prefix instance
+              (or (installer-jupyter-path instance)
+                  (merge-pathnames (make-pathname :directory '(:relative "jupyter"))
+                                   (installer-path instance :root)))))
+
+(defmethod installer-path ((instance user-installer) (name (eql :jupyter)))
+  (add-prefix instance
+              (or (installer-jupyter-path instance)
+                  (merge-pathnames (make-pathname :directory '(:relative #+darwin "Jupyter"
+                                                                         #-darwin "jupyter"))
+                                   (installer-path instance :root)))))
+
+(defmethod installer-path (instance (name (eql :program)))
+  (add-prefix instance
+              (or (installer-program-path instance)
+                  (merge-pathnames (make-pathname :directory (list :relative
+                                                             (format nil "~A-jupyter"
+                                                                     (installer-kernel-name instance))))
+                                   (installer-path instance :root)))))
+
+(defmethod installer-path (instance (name (eql :image)))
+  (merge-pathnames (make-pathname :name "image" :type #+windows "exe" #-windows :unspecific)
+                   (installer-path instance :program)))
+
+(defmethod installer-path (instance (name (eql :bundle)))
+  (merge-pathnames (make-pathname :name "bundle" :type "lisp")
+                   (installer-path instance :program)))
+
+(defmethod installer-path (instance (name (eql :local-projects)))
+  (merge-pathnames (make-pathname :directory (list :relative "local-projects"))
+                   (installer-path instance :program)))
+
+(defmethod installer-path (instance (name pathname))
+  name)
 
 (defgeneric command-line (instance)
   (:documentation "Get the command line for an installer instance."))
 
 (defmethod command-line ((instance user-image-installer))
   "Get the command for a user image installer."
-  (list
-    (namestring (installer-path instance :root :program :image))
-    "{connection_file}"))
+  (list (namestring (installer-path instance :image))
+        "{connection_file}"))
 
 (defgeneric copy-component (component dest)
   (:documentation "Copy a specific ASDF component to the destination."))
@@ -206,31 +190,33 @@
 
 (defun install-local-systems (instance)
   "Install the local systems into local-projects."
-  (let ((dest (installer-path instance :prefix :program :local-projects)))
-    (format t "Installing local systems to ~A~%" dest)
-    (dolist (system-sym (installer-local-systems instance))
-      (alexandria:when-let ((system (asdf:find-system system-sym)))
-        (copy-component system dest)))))
+  (when (installer-local-systems instance)
+    (let ((dest (installer-path instance :local-projects)))
+      (format t "Installing local systems to ~A~%" dest)
+      (ensure-directories-exist dest)
+      (dolist (system-sym (installer-local-systems instance))
+        (alexandria:when-let ((system (asdf:find-system system-sym)))
+          (copy-component system dest))))))
 
 (defun install-bundle (instance)
   "Install the Quicklisp bundle."
-  (let ((dest (installer-path instance :prefix :program)))
+  (let ((dest (installer-path instance :program)))
     (format t "Installing Quicklisp bundle to ~A~%" dest)
+    (ensure-directories-exist dest)
     (funcall (fdefinition (find-symbol "BUNDLE-SYSTEMS" 'ql))
       (installer-systems instance) :to dest)))
 
 (defun install-directories (instance)
   "Create all needed directories."
   (format t "Creating directories.~%")
-  (alexandria:when-let ((prefix (installer-prefix instance)))
-    (ensure-directories-exist prefix))
-  (ensure-directories-exist (installer-path instance :prefix :kernel))
-  (ensure-directories-exist (installer-path instance :prefix :program)))
+  (alexandria:when-let ((installer-prefix (installer-prefix instance)))
+    (ensure-directories-exist installer-prefix))
+  (ensure-directories-exist (installer-path instance :kernel)))
 
 (defun install-spec (instance)
   "Install the kernel spec file."
   (with-slots (display-name language) instance
-    (let ((spec-path (installer-path instance :prefix :kernel :spec)))
+    (let ((spec-path (installer-path instance :spec)))
       (format t "Installing kernel spec file ~A~%" spec-path)
       (with-open-file (stream spec-path :direction :output :if-exists :supersede)
         (shasht:write-json
@@ -244,11 +230,12 @@
                          :empty-object))
           stream)))))
 
-(defun install-resources (instance)
+(defun install-resources (instance &aux (kernel-path (installer-path instance :kernel)))
   "Install all kernel resources."
-  (format t "Installing kernel resources to ~A.~%" (installer-path instance :prefix :kernel))
+  (format t "Installing kernel resources to ~A.~%" kernel-path)
   (dolist (src (installer-resources instance))
-    (alexandria:copy-file src (installer-path instance :prefix :kernel (file-namestring src)))))
+    (alexandria:copy-file src (merge-pathnames (file-namestring src)
+                                               kernel-path))))
 
 (defgeneric install (instance)
   (:documentation "Install a kernel based on an installer instance."))
@@ -261,7 +248,7 @@
 
 (defmethod install ((instance user-image-installer))
   "Create an image for the user image based kernels."
-  (let ((prefixed-image-path (installer-path instance :prefix :program :image))
+  (let ((prefixed-image-path (installer-path instance :image))
         (class (installer-class instance)))
     (setq uiop:*image-entry-point*
       `(lambda ()
