mirror-img/t/mirror-img.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")))