Compare commits
No commits in common. "36c8b2a87b03e44e1d69cc8b64b74135bd7f656d" and "0b4ceff91f6a7498a455396f37a3329874eaa30c" have entirely different histories.
36c8b2a87b
...
0b4ceff91f
|
|
@ -29,11 +29,12 @@
|
||||||
:license "GPLv3"
|
:license "GPLv3"
|
||||||
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
:author "Jaidyn Ann <jadedctrl@posteo.at>"
|
||||||
:description "Tests for the the mirror-img package."
|
:description "Tests for the the mirror-img package."
|
||||||
:depends-on (:mirror-img :hunchentoot :lisp-unit2)
|
:depends-on (:mirror-img :lisp-unit2)
|
||||||
:components ((:file "t/mirror-img")))
|
:components ((:file "t/mirror-img")))
|
||||||
|
|
||||||
;; Following method tweaked from lisp-unit2’s documentation:
|
;; Following method borrowed from lisp-unit2’s documentation:
|
||||||
;; https://github.com/AccelerationNet/lisp-unit2/blob/master/README.md#asdf
|
;; 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))))
|
(defmethod asdf:perform ((o asdf:test-op) (c (eql (asdf:find-system :mirror-img/tests))))
|
||||||
(eval (read-from-string
|
(eval (read-from-string
|
||||||
"(mirror-img/tests:run)")))
|
"(lisp-unit2:with-summary ()
|
||||||
|
(lisp-unit2:run-tests :package :mirror-img/tests))")))
|
||||||
|
|
|
||||||
|
|
@ -21,32 +21,31 @@
|
||||||
|
|
||||||
(in-package :mirror-img)
|
(in-package :mirror-img)
|
||||||
|
|
||||||
(defparameter +src-tags+ '("audio" "embed" "img" "input" "script" "source" "track" "video"))
|
(defvar *src-tags* '("audio" "embed" "img" "input" "script" "source" "track" "video"))
|
||||||
(defparameter +href-tags+ '("link"))
|
(defvar *href-tags* '("link"))
|
||||||
(defparameter *default-tags* (append +src-tags+ +href-tags+))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Mirror-img
|
;;; Mirror-img
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
;; pathname pathname list → string
|
;; pathname pathname list → string
|
||||||
(defun mirror-img (html-file base-dir &key (tags *default-tags*))
|
(defun mirror-img (html-file base-dir &optional (tags '("img")))
|
||||||
"Attempt to mirror all remote HREF/SRC URLs of an HTML file’s 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 base-dir. The remote URLs will be replaced with the
|
||||||
local version, where downloading was successful.
|
local version, where downloading was successful.
|
||||||
Returns a string of the modified page’s HTML."
|
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
|
(url→pathname-alist
|
||||||
(mirror-linked-urls dom :tags tags :base-dir base-dir))
|
(mirror-linked-urls dom (append *src-tags* *href-tags*) base-dir))
|
||||||
(url→relative-url-alist
|
(url→relative-url-alist
|
||||||
(mapcar (lambda (pair) (cons (car pair) (namestring (cdr pair))))
|
(mapcar (lambda (pair) (cons (car pair) (namestring (cdr pair))))
|
||||||
url→pathname-alist)))
|
url→pathname-alist)))
|
||||||
(substitute-urls dom
|
(substitute-urls dom
|
||||||
url→relative-url-alist
|
url→relative-url-alist
|
||||||
:tags tags)
|
(append *src-tags* *href-tags*))
|
||||||
(aref (lquery:$ dom (serialize)) 0)))
|
(aref (lquery:$ dom (serialize)) 0)))
|
||||||
|
|
||||||
;; lquery-dom list pathname → alist
|
;; lquery-dom list pathname → alist
|
||||||
(defun mirror-linked-urls (dom &key (tags *default-tags*) base-dir)
|
(defun mirror-linked-urls (dom &optional (tags '("link" "img" "script")) base-dir)
|
||||||
"Mirror all URLs in the HREF/SRC attributes of the given tags in an LQuery
|
"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 base-dir.
|
||||||
Returns an associative list containing pairs of remote-URLs to local pathnames.
|
Returns an associative list containing pairs of remote-URLs to local pathnames.
|
||||||
|
|
@ -58,13 +57,13 @@ For example:
|
||||||
(mapcar (lambda (url)
|
(mapcar (lambda (url)
|
||||||
(let ((download-path
|
(let ((download-path
|
||||||
(ensure-directories-exist
|
(ensure-directories-exist
|
||||||
(mirrored-pathname url :base-dir base-dir))))
|
(mirrored-pathname url base-dir))))
|
||||||
(if (http-fetch url download-path)
|
(if (http-fetch url download-path)
|
||||||
(cons url download-path))))
|
(cons url download-path))))
|
||||||
(linked-urls dom :tags tags))))
|
(linked-urls dom tags))))
|
||||||
|
|
||||||
;; lquery-dom alist list → nil
|
;; lquery-dom alist list → nil
|
||||||
(defun substitute-urls (dom substitution-alist &key (tags '("img")))
|
(defun substitute-urls (dom substitution-alist &optional (tags '("img")))
|
||||||
"Replace SRC or HREF attributes of certain tags in an LQuery DOM, based on a
|
"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
|
substitution associative list. The substitution alist is made up of cons-cells
|
||||||
mapping replacee URLs to substition URLs.
|
mapping replacee URLs to substition URLs.
|
||||||
|
|
@ -85,7 +84,7 @@ among the given tags."
|
||||||
dom)
|
dom)
|
||||||
|
|
||||||
;; string pathname → pathname
|
;; string pathname → pathname
|
||||||
(defun mirrored-pathname (url &key base-dir)
|
(defun mirrored-pathname (url &optional base-dir)
|
||||||
"Given a URL, return the corresponding path we would download it to, were we
|
"Given a URL, return the corresponding path we would download it to, were we
|
||||||
to mirror it."
|
to mirror it."
|
||||||
(let* ((url (quri:uri url))
|
(let* ((url (quri:uri url))
|
||||||
|
|
@ -102,7 +101,7 @@ to mirror it."
|
||||||
;;; DOM-parsing
|
;;; DOM-parsing
|
||||||
;;; ————————————————————————————————————————
|
;;; ————————————————————————————————————————
|
||||||
;; lquery-dom list → list
|
;; lquery-dom list → list
|
||||||
(defun linked-urls (dom &key (tags *default-tags*))
|
(defun linked-urls (dom &optional (tags '("link" "img" "script")))
|
||||||
"Return a list of all URLs in the LQuery DOM contained in the given tags’
|
"Return a list of all URLs in the LQuery DOM contained in the given tags’
|
||||||
HREF and SRC attributes."
|
HREF and SRC attributes."
|
||||||
(flet ((url-list-of-tag (tag)
|
(flet ((url-list-of-tag (tag)
|
||||||
|
|
|
||||||
|
|
@ -16,74 +16,15 @@
|
||||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(defpackage :mirror-img/tests
|
(defpackage :mirror-img/tests
|
||||||
(:use :cl :lisp-unit2)
|
(:use :cl :lisp-unit2))
|
||||||
(:export :run))
|
|
||||||
|
|
||||||
(in-package :mirror-img/tests)
|
(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))
|
(define-test mirrored-pathname (:tags '(base))
|
||||||
(assert-equal
|
(assert-equal
|
||||||
(mirror-img::mirrored-pathname "https://invalid.tld/dir/bird apple.txt"
|
(mirror-img::mirrored-pathname "https://invalid.tld/dir/bird apple.txt" #p"base/")
|
||||||
:base-dir #p"base/")
|
|
||||||
#p"base/invalid.tld/bird apple.txt"))
|
#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))
|
(define-test url-encode-uri.space (:tags '(util))
|
||||||
(assert-equal
|
(assert-equal
|
||||||
(mirror-img::url-encode-uri "https://invalid.tld/dad alive.jpg")
|
(mirror-img::url-encode-uri "https://invalid.tld/dad alive.jpg")
|
||||||
|
|
|
||||||
|
|
@ -1,88 +0,0 @@
|
||||||
<!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>
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 60 KiB |
|
|
@ -1,2 +0,0 @@
|
||||||
https://twitter.com/tao15102/status/1748663360105947389
|
|
||||||
By tao15102
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 38 KiB |
|
|
@ -1,2 +0,0 @@
|
||||||
https://www.pixiv.net/artworks/71223241
|
|
||||||
By オギモトズキン
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 24 KiB |
|
|
@ -1,2 +0,0 @@
|
||||||
https://www.pixiv.net/artworks/115188449
|
|
||||||
By フロリダちゃん
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 27 KiB |
|
|
@ -1,2 +0,0 @@
|
||||||
https://twitter.com/yukichi_nya___/status/1608750624681918465
|
|
||||||
By yukichi_nya___
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 47 KiB |
|
|
@ -1,2 +0,0 @@
|
||||||
https://www.pixiv.net/artworks/86493795
|
|
||||||
By Ema3
|
|
||||||
|
|
@ -1,22 +0,0 @@
|
||||||
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;
|
|
||||||
}
|
|
||||||
Binary file not shown.
|
Before Width: | Height: | Size: 17 KiB |
|
|
@ -1,2 +0,0 @@
|
||||||
https://twitter.com/Distrbeachboy/status/1758538124785852426
|
|
||||||
By Distrbeachboy
|
|
||||||
Ŝarĝante…
Reference in New Issue