Only unlink internal checkouts by default

CHANGELOG.md

@@ -14,6 +14,13 @@ This project adheres to [Semantic Versioning](http://semver.org/).
   [#27](https://github.com/amperity/lein-monolith/issues/27)
   [#72](https://github.com/amperity/lein-monolith/pull/72)
 
+### Changed
+- The `unlink` task will now only remove internal checkouts by default. It also
+  accepts an `:all` option to remove external checkouts, as well as a list of
+  project names to specifically unlink.
+  [#66](https://github.com/amperity/lein-monolith/issues/66)
+  [#80](https://github.com/amperity/lein-monolith/pull/80)
+
 
 ## [1.5.0] - 2020-09-17
 

README.md

@@ -167,13 +167,14 @@ override them, you can pass the `:force` option.
 
 ```
 lein monolith link [:deep :force] [project...]
-lein monolith unlink
+lein monolith unlink [:all] [project...]
 ```
 
 In general, it's recommended to only link between the projects you're actually
 actively working on, otherwise Leiningen has to recursively trace the full tree
 of checkouts before running things.
 
+
 ## License
 
 Licensed under the Apache License, Version 2.0. See the [LICENSE](LICENSE) file

src/lein_monolith/task/checkouts.clj

@@ -9,7 +9,8 @@
     java.io.File
     (java.nio.file
       Files
-      LinkOption)))
+      LinkOption
+      Path)))
 
 
 (defn- create-symlink!
@@ -20,6 +21,18 @@
     (make-array java.nio.file.attribute.FileAttribute 0)))
 
 
+(defn- resolve-symlink
+  "Read a symlink at the given path and return the canonical path to its
+  target."
+  [^Path link]
+  (let [target (Files/readSymbolicLink link)]
+    (if (.isAbsolute target)
+      (.toRealPath target (into-array LinkOption []))
+      (-> (.getParent link)
+          (.resolve target)
+          (.toRealPath (into-array LinkOption []))))))
+
+
 (defn- link-checkout!
   "Creates a checkout dependency link to the given subproject."
   [^File checkouts-dir subproject force?]
@@ -31,23 +44,23 @@
         link-path (.toPath (io/file checkouts-dir link-name))
         target-path (.relativize (.toPath checkouts-dir) (.toPath dep-root))]
     (if (Files/exists link-path (into-array LinkOption [LinkOption/NOFOLLOW_LINKS]))
-      ; Link file exists.
+      ;; Link file exists.
       (let [actual-target (Files/readSymbolicLink link-path)]
         (if (and (Files/isSymbolicLink link-path)
                  (= target-path actual-target))
-          ; Link exists and points to target already.
-          (lein/info "Link for" dep-name "is correct")
-          ; Link exists but points somewhere else.
+          ;; Link exists and points to target already.
+          (lein/debug "Link for" dep-name "is correct")
+          ;; Link exists but points somewhere else.
           (if force?
-            ; Recreate link since force is set.
+            ;; Recreate link since force is set.
             (do (lein/warn "Relinking" dep-name "from"
                            (str actual-target) "to" (str target-path))
                 (Files/delete link-path)
                 (create-symlink! link-path target-path))
-            ; Otherwise print a warning.
+            ;; Otherwise print a warning.
             (lein/warn "WARN:" dep-name "links to" (str actual-target)
                        "instead of" (str target-path)))))
-      ; Link does not exist, so create it.
+      ;; Link does not exist, so create it.
       (do (lein/info "Linking" dep-name "to" (str target-path))
           (create-symlink! link-path target-path)))))
 
@@ -77,22 +90,42 @@
     (when (empty? projects-to-link)
       (lein/abort (str "Couldn't find any projects to link matching: "
                        (str/join " " project-names))))
-    ; Create checkouts directory if needed.
+    ;; Create checkouts directory if needed.
     (when-not (.exists checkouts-dir)
-      (lein/info "Creating checkout directory" (str checkouts-dir))
+      (lein/debug "Creating checkout directory" (str checkouts-dir))
       (.mkdir checkouts-dir))
-    ; Check each dependency for internal projects.
+    ;; Check each dependency for internal projects.
     (doseq [subproject projects-to-link]
       (link-checkout! checkouts-dir subproject (:force opts)))))
 
 
 (defn unlink
   "Remove the checkouts directory from a project."
-  [project]
+  [project opts project-names]
   (when-let [checkouts-dir (some-> (:root project) (io/file "checkouts"))]
     (when (.exists checkouts-dir)
-      (lein/info "Removing checkout directory" (str checkouts-dir))
-      (doseq [link (.listFiles checkouts-dir)]
-        (lein/debug "Removing checkout link" (str link))
-        (.delete ^File link))
-      (.delete checkouts-dir))))
+      (lein/debug "Unlinking checkouts in" (str checkouts-dir))
+      (let [[_ subprojects] (u/load-monolith! project)
+            root->subproject (into {}
+                                   (map (juxt (comp str :root val) key))
+                                   subprojects)
+            selected-names (into #{}
+                                 (map (partial dep/resolve-name! (keys subprojects)))
+                                 project-names)]
+        ;; For each file in the checkouts directory.
+        (doseq [link (.listFiles checkouts-dir)
+                :let [link-path (.toPath ^File link)]]
+          (when (or (:all opts)
+                    ;; Check that the file is a symlink and points to a known
+                    ;; subproject that we want to remove.
+                    (when (Files/isSymbolicLink link-path)
+                      (let [link-target (resolve-symlink link-path)
+                            target-name (root->subproject (str link-target))]
+                        (and target-name
+                             (or (empty? selected-names)
+                                 (contains? selected-names target-name))))))
+            (lein/debug "Removing checkout link" (str link))
+            (Files/delete link-path))))
+      ;; If the directory is empty, clean up.
+      (when (empty? (.listFiles checkouts-dir))
+        (.delete checkouts-dir)))))

src/leiningen/monolith.clj

@@ -192,18 +192,27 @@
     :deep        Link all subprojects this project transitively depends on"
   [project args]
   (when (:monolith project)
-    (lein/abort "The 'link' task does not need to be run for the monolith project!"))
+    (lein/abort "The 'link' task cannot be run for the monolith project!"))
   (let [[opts project-names] (opts+projects {:force 0, :deep 0} project args)
-        subproject-names (remove #(= (dep/project-name project) %)
-                                 project-names)]
-    (checkouts/link project opts
-                    subproject-names)))
+        target-names (remove #(= (dep/project-name project) %)
+                             project-names)]
+    (checkouts/link project opts target-names)))
 
 
 (defn unlink
-  "Remove the checkouts directory from a project."
-  [project]
-  (checkouts/unlink project))
+  "Remove internal checkout links from a project. Optionally, a set of project
+  names may be specified to remove links only for those projects.
+
+  Options:
+    :all         Remove all checkouts, not just internal ones."
+  [project args]
+  (when (:monolith project)
+    (lein/abort "The 'unlink' task cannot be run for the monolith project!"))
+  (let [[opts project-names] (opts+projects {:all 0} project args)
+        target-names (remove #(= (dep/project-name project) %)
+                             project-names)]
+    (checkouts/unlink project opts target-names)))
+
 
 
 ;; ## Fingerprinting
@@ -269,7 +278,7 @@
     "with-all"           (with-all project args)
     "each"               (each project args)
     "link"               (link project args)
-    "unlink"             (unlink project)
+    "unlink"             (unlink project args)
     "changed"            (changed project args)
     "mark-fresh"         (mark-fresh project args)
     "clear-fingerprints" (clear-fingerprints project args)