Add testing website and additional tests

… most importantly for MIRROR-IMG:MIRROR-IMG.
Thanks Hunchentoot, for being such a nice
web-server. =w=

mirror-img.asd

@@ -29,12 +29,11 @@
   :license "GPLv3"
   :author "Jaidyn Ann <jadedctrl@posteo.at>"
   :description "Tests for the the mirror-img package."
-  :depends-on (:mirror-img :lisp-unit2)
+  :depends-on (:mirror-img :hunchentoot :lisp-unit2)
   :components ((:file "t/mirror-img")))
 
-;; Following method borrowed from lisp-unit2’s documentation:
+;; Following method tweaked from lisp-unit2’s documentation:
 ;; https://github.com/AccelerationNet/lisp-unit2/blob/master/README.md#asdf
 (defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system :mirror-img/tests))))
   (eval (read-from-string
-         "(lisp-unit2:with-summary ()
-            (lisp-unit2:run-tests :package :mirror-img/tests))")))
+         "(mirror-img/tests:run)")))

src/mirror-img.lisp

@@ -21,31 +21,32 @@
 
 (in-package :mirror-img)
 
-(defvar *src-tags* '("audio" "embed" "img" "input" "script" "source" "track" "video"))
-(defvar *href-tags* '("link"))
+(defparameter +src-tags+ '("audio" "embed" "img" "input" "script" "source" "track" "video"))
+(defparameter +href-tags+ '("link"))
+(defparameter *default-tags* (append +src-tags+ +href-tags+))
 
 
 ;;; Mirror-img
 ;;; ————————————————————————————————————————
 ;; pathname pathname list → string
-(defun mirror-img (html-file base-dir &optional (tags '("img")))
+(defun mirror-img (html-file base-dir &key (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
 local version, where downloading was successful.
 Returns a string of the modified page’s HTML."
   (let* ((dom (lquery:$ (lquery:initialize html-file)))
          (url→pathname-alist
-           (mirror-linked-urls dom (append *src-tags* *href-tags*) base-dir))
+           (mirror-linked-urls dom :tags tags :base-dir base-dir))
          (url→relative-url-alist
            (mapcar (lambda (pair) (cons (car pair) (namestring (cdr pair))))
                    url→pathname-alist)))
     (substitute-urls dom
                      url→relative-url-alist
-                     (append *src-tags* *href-tags*))
+                     :tags tags)
     (aref (lquery:$ dom (serialize)) 0)))
 
 ;; lquery-dom list pathname → alist
-(defun mirror-linked-urls (dom &optional (tags '("link" "img" "script")) base-dir)
+(defun mirror-linked-urls (dom &key (tags *default-tags*) base-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.
 Returns an associative list containing pairs of remote-URLs to local pathnames.
@@ -57,13 +58,13 @@ For example:
    (mapcar (lambda (url)
              (let ((download-path
                      (ensure-directories-exist
-                      (mirrored-pathname url base-dir))))
+                      (mirrored-pathname url :base-dir base-dir))))
                (if (http-fetch url download-path)
                    (cons url download-path))))
-    (linked-urls dom tags))))
+    (linked-urls dom :tags tags))))
 
 ;; lquery-dom alist list → nil
-(defun substitute-urls (dom substitution-alist &optional (tags '("img")))
+(defun substitute-urls (dom substitution-alist &key (tags '("img")))
   "Replace SRC or HREF attributes of certain tags in an LQuery DOM, based on a
 substitution associative list. The substitution alist is made up of cons-cells
 mapping replacee URLs to substition URLs.
@@ -84,7 +85,7 @@ among the given tags."
   dom)
 
 ;; string pathname → pathname
-(defun mirrored-pathname (url &optional base-dir)
+(defun mirrored-pathname (url &key base-dir)
   "Given a URL, return the corresponding path we would download it to, were we
 to mirror it."
   (let* ((url (quri:uri url))
@@ -101,7 +102,7 @@ to mirror it."
 ;;; DOM-parsing
 ;;; ————————————————————————————————————————
 ;; lquery-dom list → list
-(defun linked-urls (dom &optional (tags '("link" "img" "script")))
+(defun linked-urls (dom &key (tags *default-tags*))
   "Return a list of all URLs in the LQuery DOM contained in the given tags’
 HREF and SRC attributes."
   (flet ((url-list-of-tag (tag)

t/mirror-img.lisp

@@ -16,15 +16,74 @@
 ;; along with this program. If not, see <https://www.gnu.org/licenses/>.
 
 (defpackage :mirror-img/tests
-  (:use :cl :lisp-unit2))
+  (:use :cl :lisp-unit2)
+  (:export :run))
 
 (in-package :mirror-img/tests)
 
+(defparameter *mirror-img-result* nil)
+
+(defun relative-pathname (path)
+  (asdf:system-relative-pathname :mirror-img/tests path))
+
+(defun run ()
+  (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))))
+
+(define-test mirror-img (:tags '(mirror-img))
+  (assert-eq
+   (stringp
+    (setq *mirror-img-result*
+          (mirror-img:mirror-img (relative-pathname "t/testing-website/index.html")
+                                 "tmp")))
+   'T))
+
+(define-test mirror-img.files-mirrored (:tags '(mirror-img))
+  (assert-equal
+   (sort (mapcar #'pathname-name
+                 (uiop:directory-files (relative-pathname "t/tmp/localhost/")))
+         #'string-lessp)
+   '("café" "fireplace" "merry christmas!!! ^_^" "more_calming" "style" "welcoming you")))
+
+(define-test mirror-img.correct-urls (:tags '(mirror-img))
+  (assert-equal
+   (sort (mirror-img::linked-urls
+          (lquery:$ (lquery:initialize *mirror-img-result*)))
+         #'string-lessp)
+   '("tmp/localhost/café.jpg"
+     "tmp/localhost/classy_fireplace.jpg"
+     "tmp/localhost/fireplace.jpg"
+     "tmp/localhost/merry christmas!!! ^_^.jpg"
+     "tmp/localhost/more_calming.jpg"
+     "tmp/localhost/style.css"
+     "tmp/localhost/welcoming you.jpg")))
+
 (define-test mirrored-pathname (:tags '(base))
   (assert-equal
-   (mirror-img::mirrored-pathname "https://invalid.tld/dir/bird apple.txt" #p"base/")
+   (mirror-img::mirrored-pathname "https://invalid.tld/dir/bird apple.txt"
+                                  :base-dir #p"base/")
    #p"base/invalid.tld/bird apple.txt"))
 
+(define-test linked-urls (:tags '(dom))
+  (assert-equal
+   (sort (mirror-img::linked-urls
+          (lquery:$ (lquery:initialize
+                     (relative-pathname "t/testing-website/index.html"))))
+         #'string-lessp)
+   '("http://localhost:4242/res/img/b/fireplace.jpg"
+     "http://localhost:4242/res/img/b/I’m trying hard to randomly name these directories/more_calming.jpg"
+     "http://localhost:4242/res/img/b/I’m trying hard to randomly name these directories/ĉu ĉi tio sufiĉe hazardas%3F!/classy_fireplace.jpg"
+     "http://localhost:4242/res/img/level-2/café.jpg"
+     "http://localhost:4242/res/img/merry christmas!!! ^_^.jpg"
+     "http://localhost:4242/res/style.css"
+     "http://localhost:4242/res/welcoming you.jpg")))
+
 (define-test url-encode-uri.space (:tags '(util))
   (assert-equal
    (mirror-img::url-encode-uri "https://invalid.tld/dad alive.jpg")

t/testing-website/index.html

@@ -0,0 +1,88 @@
+<!DOCTYPE HTML>
+<html lang="en">
+	<head>
+		<title>mirror-img’s testing site! ♥</title>
+		<meta charset="UTF-8"/>
+		<link rel="stylesheet" type="text/css" href="http://localhost:4242/res/style.css">
+	</head>
+
+	<body>
+		<main>
+			<h1>A sultry welcome to you</h1>
+
+			<figure>
+				<img src="http://localhost:4242/res/welcoming you.jpg">
+				<figcaption>Welcome~
+					<a href="https://twitter.com/Distrbeachboy/status/1758538124785852426">
+						🔗
+					</a>
+				</figcaption>
+			</figure>
+
+			<p>Take a seat over here by the fire, take a load off. Yea, just like that. Isn’t it warm, here? The fire always puts me at ease, and I feel myself drifting… somewhere… drifting… just like that. I’m going to count down from ten, and you’ll feel yourself drifting deeper, and deeper, and deeper.</p>
+
+			<!-- I’m already tired of this joke… but I’ve already started, so I guess I gotta keep going… =,w,= -->
+			<p>Ten…</p>
+			<p>Nine…</p>
+
+			<figure>
+				<img src="http://localhost:4242/res/img/b/fireplace.jpg">
+				<figcaption><em>You’re safe by the fire.</em>
+					<a href="https://www.pixiv.net/artworks/115188449">
+						🔗
+					</a>
+				</figcaption>
+			</figure>
+
+			<p>Eight…</p>
+			<p>Seven…</p>
+
+			<figure>
+				<img src="http://localhost:4242/res/img/b/I’m trying hard to randomly name these directories/more_calming.jpg">
+				<figcaption><em>Slide down, further and further~</em>
+					<a href="https://twitter.com/tao15102/status/1748663360105947389">
+						🔗
+					</a>
+				</figcaption>
+			</figure>
+
+			<p>Six…</p>
+			<p>Five…</p>
+
+			<figure>
+				<img src="http://localhost:4242/res/img/level-2/café.jpg">
+				<figcaption><em>Let yourself steep…</em>
+					<a href="https://twitter.com/yukichi_nya___/status/1608750624681918465">
+						🔗
+					</a>
+				</figcaption>
+			</figure>
+
+			<p>Four…</p>
+			<p>Three…</p>
+
+			<figure>
+				<img src="http://localhost:4242/res/img/b/I’m trying hard to randomly name these directories/ĉu ĉi tio sufiĉe hazardas%3F!/classy_fireplace.jpg">
+				<figcaption><em>You’re surrounded by your superiors.</em>
+					<a href="https://www.pixiv.net/artworks/115188449">
+						🔗
+					</a>
+				</figcaption>
+			</figure>
+
+			<p>Two…</p>
+			<p>One…</p>
+
+			<figure>
+				<img src="http://localhost:4242/res/img/merry christmas!!! ^_^.jpg">
+				<figcaption>AAAAAAAA!!!
+					<a href="https://www.pixiv.net/artworks/86493795">
+						🔗
+					</a>
+				</figcaption>
+			</figure>
+
+			<p>MERRY FUCKING CHRISTMAS, MOTHERFUCKER!!!!!! YOU’VE BEEN <a href="https://vid.puffyan.us/watch?v=KJ38jTQcO1k" >CHRISTMAS JOKED</a>!!!!!!!!!!!</p>
+		</main>
+	</body>
+</html>

t/testing-website/res/img/b/I’m trying hard to randomly name these directories/more_calming.txt

@@ -0,0 +1,2 @@
+https://twitter.com/tao15102/status/1748663360105947389
+By tao15102

t/testing-website/res/img/b/I’m trying hard to randomly name these directories/ĉu ĉi tio sufiĉe hazardas?!/classy_fireplace.txt

@@ -0,0 +1,2 @@
+https://www.pixiv.net/artworks/71223241
+By オギモトズキン

t/testing-website/res/img/b/fireplace.txt

@@ -0,0 +1,2 @@
+https://www.pixiv.net/artworks/115188449
+By フロリダちゃん

t/testing-website/res/img/level-2/café.txt

@@ -0,0 +1,2 @@
+https://twitter.com/yukichi_nya___/status/1608750624681918465
+By yukichi_nya___

t/testing-website/res/img/merry christmas!!! ^_^.txt

@@ -0,0 +1,2 @@
+https://www.pixiv.net/artworks/86493795
+By Ema3

t/testing-website/res/style.css

@@ -0,0 +1,22 @@
+body {
+	background-color: #d7d7af;
+}
+
+main {
+	max-width: 800px;
+	margin-left: auto;
+	margin-right: auto;
+	text-align: center;
+	background-color: #ffffd7;
+	padding: 10px;
+	border-radius: 10px;
+}
+
+img {
+	border-radius: 10px;
+}
+
+figure {
+	border: 2px dotted;
+	padding: 5px;
+}

t/testing-website/res/welcoming you.txt

@@ -0,0 +1,2 @@
+https://twitter.com/Distrbeachboy/status/1758538124785852426
+By Distrbeachboy