Jaidyn Ann
cd1c603c8a
This one makes sure output is the same, regardless as to whether or not files have already been mirrored.
162 lines
6.0 KiB
Common Lisp
162 lines
6.0 KiB
Common Lisp
;;;; mirror-img/tests: Tests for the mirror-img package.
|
||
|
||
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
|
||
;;
|
||
;; This program is free software: you can redistribute it and/or
|
||
;; modify it under the terms of the GNU General Public License as
|
||
;; published by the Free Software Foundation, either version 3 of
|
||
;; the License, or (at your option) any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
(defpackage :mirror-img/tests
|
||
(:use :cl :lisp-unit2)
|
||
(:export :run))
|
||
|
||
(in-package :mirror-img/tests)
|
||
|
||
(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 ()
|
||
(handler-case
|
||
(progn
|
||
(run-tests :package :mirror-img/tests)
|
||
(hunchentoot:stop server))
|
||
(error (c)
|
||
(hunchentoot:stop server)
|
||
c)))))
|
||
|
||
(defun call-mirror-img ()
|
||
"Invoke MIRROR-IMG:MIRROR-IMG, using our own parameters.
|
||
Used in the tests MIRROR-IMG and MIRROR-IMG.ALREADY-DOWNLOADED."
|
||
(let* ((html-path (relative-pathname "t/testing-website/index.html"))
|
||
(download-dir (relative-pathname "t/tmp/"))
|
||
(html-url "http://localhost:4242")
|
||
(url-dir (pathname-utils:relative-pathname
|
||
(relative-pathname "t/")
|
||
download-dir)))
|
||
(mirror-img:mirror-img html-path download-dir
|
||
:url-dir url-dir
|
||
:html-url html-url)))
|
||
|
||
(define-test mirror-img (:tags '(mirror-img))
|
||
(assert-eq
|
||
'T
|
||
(stringp (setq *mirror-img-result* (call-mirror-img)))))
|
||
|
||
(define-test mirror-img.already-downloaded (:tags '(mirror-img))
|
||
(assert-equal
|
||
*mirror-img-result*
|
||
(call-mirror-img)))
|
||
|
||
(define-test mirror-img.files-mirrored (:tags '(mirror-img))
|
||
(assert-equal
|
||
'("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)))
|
||
|
||
(define-test mirror-img.correct-urls (:tags '(mirror-img))
|
||
(assert-equal
|
||
'("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")
|
||
(sort (mirror-img::linked-urls
|
||
(lquery:$ (lquery:initialize *mirror-img-result*)))
|
||
#'string-lessp)))
|
||
|
||
(define-test mirrored-pathname (:tags '(base))
|
||
(assert-equal
|
||
#p"base/invalid.tld/bird apple.txt"
|
||
(mirror-img::mirrored-pathname "https://invalid.tld/dir/bird apple.txt"
|
||
:base-dir #p"base/")))
|
||
|
||
(define-test mirrored-pathname.esperanto-question (:tags '(base))
|
||
(assert-equal
|
||
#p"base/invalid.tld/?!?! ĉu ne?!?!.png"
|
||
(mirror-img::mirrored-pathname "https://invalid.tld/dir/s/d/ askldjas/ asldkja/?!?! ĉu ne?!?!.png"
|
||
:base-dir #p"base/")))
|
||
|
||
(define-test linked-urls (:tags '(dom))
|
||
(assert-equal
|
||
'("/res/welcoming you.jpg"
|
||
"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?!/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")
|
||
(sort (mirror-img::linked-urls
|
||
(lquery:$ (lquery:initialize
|
||
(relative-pathname "t/testing-website/index.html"))))
|
||
#'string-lessp)))
|
||
|
||
(define-test url-encode-uri.space (:tags '(util))
|
||
(assert-equal
|
||
"https://invalid.tld/dad%20alive.jpg"
|
||
(mirror-img::url-encode-uri "https://invalid.tld/dad alive.jpg")))
|
||
|
||
(define-test url-encode-path.space+exclamation (:tags '(util))
|
||
(assert-equal
|
||
"/images%21/dad%20alive.jpg"
|
||
(mirror-img::url-encode-path "/images!/dad alive.jpg")))
|
||
|
||
(define-test url-encode-path.question (:tags '(util))
|
||
(assert-equal
|
||
"/images%21/%3F%C4%89u_ne%20tio%20sufi%C4%89e%3F%21.jpg"
|
||
(mirror-img::url-encode-path "/images!/?ĉu_ne tio sufiĉe?!.jpg")))
|
||
|
||
(define-test uri-explicit-port.http80 (:tags '(util))
|
||
(assert-eq
|
||
nil
|
||
(mirror-img::uri-explicit-port (quri:uri "http://xwx.moe/bird.png"))))
|
||
|
||
(define-test uri-explicit-port.http443 (:tags '(util))
|
||
(assert-eq
|
||
443
|
||
(mirror-img::uri-explicit-port (quri:uri "http://xwx.moe:443/bird.png"))))
|
||
|
||
(define-test uri-explicit-port.https27 (:tags '(util))
|
||
(assert-eq
|
||
27
|
||
(mirror-img::uri-explicit-port (quri:uri "http://xwx.moe:27/bird.png"))))
|
||
|
||
(define-test uri-explicit-port.https443 (:tags '(util))
|
||
(assert-eq
|
||
nil
|
||
(mirror-img::uri-explicit-port (quri:uri "https://xwx.moe:443/bird.png"))))
|
||
|
||
(define-test pathname-leaf.simple (:tags '(util))
|
||
(assert-equal
|
||
"apple_berries.png"
|
||
(mirror-img::pathname-leaf #p"/mom/dad/apple/laksdjal/apple_berries.png")))
|
||
|
||
(define-test pathname-leaf.very-weird (:tags '(util))
|
||
(assert-equal
|
||
" lak -!?ĉ_berries.png"
|
||
(mirror-img::pathname-leaf #p"/mom/dad?!?Ljla asdasd'' aslkdjĉ/apple/laksdjal/ lak -!?ĉ_berries.png")))
|
||
|