150 lines
5.6 KiB
Common Lisp
150 lines
5.6 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)))))
|
||
(define-test mirror-img (:tags '(mirror-img))
|
||
(assert-eq
|
||
'T
|
||
(stringp
|
||
(setq *mirror-img-result*
|
||
(let* ((html-path (relative-pathname "t/testing-website/index.html"))
|
||
(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é" "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
|
||
'("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"
|
||
"http://localhost:4242/res/welcoming you.jpg")
|
||
(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")))
|
||
|