Replace our RELATIVE-PATHNAME with PATHNAME-UTIL’s

That is, on the first run of MIRROR-IMG, no
mirrored URLs got substituted — and on subsequent
runs, only previously-downloaded URLS did.

mirror-img.asd

@@ -4,7 +4,7 @@
   :version "0.1"
   :license "GPLv3"
   :author "Jaidyn Ann <jadedctrl@posteo.at>"
-  :depends-on (:dexador :lquery :split-sequence)
+  :depends-on (:dexador :lquery :pathname-utils :split-sequence)
   :components ((:file "src/mirror-img"))
   :in-order-to ((test-op (test-op "mirror-img/tests"))
                 (build-op (build-op "mirror-img/unix"))))

src/mirror-img.lisp

@@ -29,16 +29,22 @@
 ;;; Mirror-img
 ;;; ————————————————————————————————————————
 ;; pathname pathname list → string
-(defun mirror-img (html-file base-dir &key (tags *default-tags*))
+(defun mirror-img (html-file download-dir &key (url-dir download-dir) (tags *default-tags*))
   "Attempt to mirror all remote HREF/SRC URLs of an HTML file’s tags,
-downloading them to base-dir. The remote URLs will be replaced with the
+downloading them to DOWNLOAD-DIR. For each remote URL that could be
-local version, where downloading was successful.
+successfuly mirrored, the remote URLs will be replaced with the local
+version. The URL used will will be BASE-DIR plus the filename, where
+BASE-DIR defaults to DOWNLOAD-DIR.
 Returns a string of the modified page’s HTML."
-  (let* ((dom (lquery:$ (lquery:initialize html-file)))
+  (let* ((dom
+           (lquery:$ (lquery:initialize html-file)))
          (url→pathname-alist
-           (mirror-linked-urls dom :tags tags :base-dir base-dir))
+           (mirror-linked-urls dom :tags tags :download-dir download-dir))
          (url→relative-url-alist
-           (mapcar (lambda (pair) (cons (car pair) (namestring (cdr pair))))
+           (mapcar
+            (lambda (pair)
+              (cons (car pair)
+                    (mirror-pathname->mirror-url (cdr pair) download-dir url-dir)))
             url→pathname-alist)))
     (substitute-urls dom
                      url→relative-url-alist
@@ -46,9 +52,9 @@ Returns a string of the modified page’s HTML."
     (aref (lquery:$ dom (serialize)) 0)))
 
 ;; lquery-dom list pathname → alist
-(defun mirror-linked-urls (dom &key (tags *default-tags*) base-dir)
+(defun mirror-linked-urls (dom &key (tags *default-tags*) download-dir)
   "Mirror all URLs in the HREF/SRC attributes of the given tags in an LQuery
-DOM, downloading them to either the current-working directory or the base-dir.
+DOM, downloading them to either the current-working directory or the DOWNLOAD-DIR.
 Returns an associative list containing pairs of remote-URLs to local pathnames.
 Any unsuccessfuly-mirrored URL is excluded from the alist.
 For example:
@@ -58,7 +64,7 @@ For example:
    (mapcar (lambda (url)
              (let ((download-path
                      (ensure-directories-exist
-                      (mirrored-pathname url :base-dir base-dir))))
+                      (mirrored-pathname url :base-dir download-dir))))
                (if (http-fetch url download-path)
                    (cons url download-path))))
     (linked-urls dom :tags tags))))
@@ -96,6 +102,14 @@ to mirror it."
              (quri:uri-host url)
              (pathname-leaf path)))))
 
+;; pathname pathname string → string
+(defun mirror-pathname->mirror-url (pathname download-dir url-dir)
+  "Convert a mirrored file into a substitution-worthy URL, from its PATHNAME,
+DOWNLOAD-DIR, and URL-DIR."
+  (format nil "~A~A"
+          url-dir
+          (pathname-utils:relative-pathname download-dir pathname)))
+
 
 
 ;;; DOM-parsing
@@ -139,7 +153,8 @@ already set)."
 (defun http-fetch (url path)
   "Download a URL to a path; if successful, returns the pathname. Otherwise, NIL."
   (handler-case
-      (and (dexador:fetch (url-encode-uri url) path)
+      ; DEXADOR:FETCH returns nil on success, errors on fail. Hence the OR.
+      (or (dexador:fetch (url-encode-uri url) path)
           (pathname path))
     (cl-user::file-exists ()
       path)

t/mirror-img.lisp

@@ -24,29 +24,41 @@
 (defparameter *mirror-img-result* nil)
 
 (defun relative-pathname (path)
+  "Return an absolute path adding the relative PATH to the :mirror-img
+system’s path."
   (asdf:system-relative-pathname :mirror-img/tests path))
 
 (defun run ()
+  "Run all tests for the mirror-img package."
   (let* ((doc-root (relative-pathname "t/testing-website/"))
          (acceptor (make-instance 'hunchentoot:easy-acceptor
                                   :port 4242
                                   :document-root doc-root))
          (server (hunchentoot:start acceptor)))
-    (lisp-unit2:with-summary ()
-      (run-tests :package :mirror-img/tests)
-      (hunchentoot:stop server))))
 
+    (lisp-unit2:with-summary ()
+      (handler-case
+          (progn
+            (run-tests :package :mirror-img/tests)
+            (hunchentoot:stop server))
+        (error (c)
+          (hunchentoot:stop server)
+          c)))))
 (define-test mirror-img (:tags '(mirror-img))
   (assert-eq
    'T
    (stringp
     (setq *mirror-img-result*
-          (mirror-img:mirror-img (relative-pathname "t/testing-website/index.html")
+          (let* ((html-path    (relative-pathname "t/testing-website/index.html"))
-                                 "tmp")))))
+                 (download-dir (relative-pathname "t/tmp/"))
+                 (url-dir      (pathname-utils:relative-pathname
+                                (relative-pathname "t/")
+                                download-dir)))
+            (mirror-img:mirror-img html-path download-dir :url-dir url-dir))))))
 
 (define-test mirror-img.files-mirrored (:tags '(mirror-img))
   (assert-equal
-   '("café" "fireplace" "merry christmas!!! ^_^" "more_calming" "style" "welcoming you")
+   '("café" "classy_fireplace" "fireplace" "merry christmas!!! ^_^" "more_calming" "style" "welcoming you")
    (sort (mapcar #'pathname-name
                  (uiop:directory-files (relative-pathname "t/tmp/localhost/")))
          #'string-lessp)))
@@ -134,3 +146,4 @@
   (assert-equal
    " lak -!?ĉ_berries.png"
    (mirror-img::pathname-leaf #p"/mom/dad?!?Ljla asdasd'' aslkdjĉ/apple/laksdjal/ lak -!?ĉ_berries.png")))
+