Jaidyn Ann
36c8b2a87b
… most importantly for MIRROR-IMG:MIRROR-IMG. Thanks Hunchentoot, for being such a nice web-server. =w=
96 lines
3.7 KiB
Common Lisp
96 lines
3.7 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)
|
||
(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"
|
||
: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")
|
||
"https://invalid.tld/dad%20alive.jpg"))
|
||
|
||
(define-test url-encode-path.space+exclamation (:tags '(util))
|
||
(assert-equal
|
||
(mirror-img::url-encode-path "/images!/dad alive.jpg")
|
||
"/images%21/dad%20alive.jpg"))
|