factor out some repetition & get local cache MIME types

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

1 files changed, 59 insertions, 47 deletions

diff --git a/src/core.lisp b/src/core.lisp
index de6bd0c..2d1d3fa 100644
--- a/src/core.lisp
+++ b/src/core.lisp
@@ -727,53 +727,65 @@ sources are not expected to be available outside of the root Lisp."))
 ;; called by implementations of ESTABLISH-CONNECTION which start up remote
 ;; Lisp processes
 (defun upload-all-prerequisite-data (host)
-  (loop with *data-sources*
-	initially (register-data-source :asdf)
-
-	with sorted-local-cache  = (sort (get-local-cached-prerequisite-data)
-					 (compose #'version> #'third))
-	with sorted-remote-cache = (sort (get-remote-cached-prerequisite-data)
-					 (compose #'version> #'third))
-
-	for (iden1 . iden2) in (getf (slot-value host :hostattrs) :data)
-	for highest-local-cached-version
-	  = (third (car (remove-if-not (lambda (c)
-					 (and (string= (first c) iden1)
-					      (string= (second c) iden2)))
-				       sorted-local-cache)))
-	for highest-remote-cached-version
-	  = (third (car (remove-if-not (lambda (c)
-					 (and (string= (first c) iden1)
-					      (string= (second c) iden2)))
-				       sorted-remote-cache)))
-	for (highest-source-version . highest-source)
-	  = (query-data-sources iden1 iden2)
-
-	if (and highest-source-version
-		(or (not highest-remote-cached-version)
-		    (version< highest-remote-cached-version
-			      highest-source-version)))
-	  do (connection-clear-data-cache iden1 iden2)
-	     (connection-upload-data iden1
-				     iden2
-				     highest-source-version
-				     (funcall highest-source))
-	else if (and highest-local-cached-version
-		     (or (not highest-remote-cached-version)
-			 (version< highest-remote-cached-version
-				   highest-local-cached-version)))
-	       do (connection-clear-data-cache iden1 iden2)
-		  (connection-upload-data
-		   iden1
-		   iden2
-		   highest-local-cached-version
-		   (list :file
-			 (local-data-pathname iden1
-					      iden2
-					      highest-local-cached-version)))
-	else unless highest-remote-cached-version
-	       do (error "Could not provide prerequisite data ~S | ~S"
-			 iden1 iden2)))
+  (macrolet ((highest-version-in-cache (cache)
+	       `(third (car (remove-if-not (lambda (c)
+					     (and (string= (first c) iden1)
+						  (string= (second c) iden2)))
+					   ,cache)))))
+    (loop with *data-sources*
+	  initially (register-data-source :asdf)
+
+	  with sorted-local-cache  = (sort-prerequisite-data-cache
+				      (get-local-cached-prerequisite-data))
+	  with sorted-remote-cache = (sort-prerequisite-data-cache
+				      (get-remote-cached-prerequisite-data))
+	  for (iden1 . iden2) in (getf (slot-value host :hostattrs) :data)
+
+	  for highest-local-cached-version  = (highest-version-in-cache
+					       sorted-local-cache)
+	  for highest-remote-cached-version = (highest-version-in-cache
+					       sorted-remote-cache)
+	  for (highest-source-version . highest-source)
+	    = (query-data-sources iden1 iden2)
+
+	  if (and highest-source-version
+		  (or (not highest-remote-cached-version)
+		      (version< highest-remote-cached-version
+				highest-source-version)))
+	    do (connection-clear-data-cache iden1 iden2)
+	       (connection-upload-data iden1
+				       iden2
+				       highest-source-version
+				       (funcall highest-source))
+	  else if (and highest-local-cached-version
+		       (or (not highest-remote-cached-version)
+			   (version< highest-remote-cached-version
+				     highest-local-cached-version)))
+		 do (connection-clear-data-cache iden1 iden2)
+		    (connection-upload-data
+		     iden1
+		     iden2
+		     highest-local-cached-version
+		     (let ((file (local-data-pathname
+				  iden1
+				  iden2
+				  highest-local-cached-version)))
+		       (list :file file :type (try-get-file-mime-type file))))
+	  else unless highest-remote-cached-version
+		 do (error "Could not provide prerequisite data ~S | ~S"
+			   iden1 iden2))))
+
+(defun try-get-file-mime-type (file)
+  (handler-case (uiop:stripln
+		 (uiop:run-program (uiop:escape-sh-command
+				    (list "file" "-E"
+					  "--mime-type" "--brief"
+					  (uiop:unix-namestring file)))
+				   :output :string))
+    (uiop:subprocess-error () nil)))
+
+(defun sort-prerequisite-data-cache (cache)
+  (sort cache (lambda (x y) (version> (third x) (third y)))))
 
 (defun data-pathname (root &rest segments)
   (destructuring-bind (last . rest)