path: root/tests/guile/cantius-test.scm

;;; SPDX-License-Identifier: CC0-1.0
;;;
;;; Copyright (C) 2023, 2024 Wojtek Kosior <koszko@koszko.org>

(use-modules ((scheme base) #:select (bytevector-copy string->utf8))
             ((srfi srfi-8) #:select (receive))
             ((srfi srfi-26) #:select (cut))
             ((srfi srfi-34) #:select (guard raise))
             ((ice-9 safe-r5rs) #:select (null-environment))
             ((ice-9 format) #:select (format))
             ((web client) #:select (open-socket-for-uri http-get))
             ((web response) #:prefix rsp:)
             ((web uri) #:prefix uri:)
             ((myra-test-utils) #:prefix tu:))

(define (make-env)
  (let ((env (null-environment 5)))
    (module-use! env (resolve-interface '(guile)))
    env))

(define (test-env name)
  (resolve-module `(cantius-test ,name)))

(define (open-socket-with-timeout uri timeout)
  (let ((start-time (current-time)))
    (let loop ()
      (guard (cnd ((> (current-time) (+ start-time timeout))
                   (raise cnd))
                  (#t
                   (sleep 1)
                   (loop)))
        (open-socket-for-uri uri)))))

(tu:test-group "nonfree-site"
  (tu:test-assert
   (or (eval '(begin
                (define-module (cantius-test nonfree-site)
                  #:use-module ((srfi srfi-18) #:select
                                (make-thread thread-terminate! thread-yield!
                                 thread-start!))
                  #:use-module ((ice-9 format) #:select (format))
                  #:use-module ((ice-9 textual-ports) #:select (get-string-all))
                  #:use-module (cantius))

                (define sock-port
                  #f))
             (make-env))))

  (tu:test-assert
   (or (eval '(begin
                (define %my-endset
                  (endset))

                (define-endpoint %my-endset about-ms
                  ("cool-companies" "ms" "about") '()
                  "Microsoft is my favorite company.  I started using
 Microsoft at the age of...")

                (define-endpoint %my-endset broken
                  ("cool-companies" "ms" "product-list") '()
                  (/ 1 0))

                (define-endpoint %my-endset drm-wiki
                  ("drm-wiki" ,(string-append "dev" "ices") . some-path) '()
                  (values (build-response*)
                          (format #f "~@{~@?~%~^~}"
                                  "full page path1: ~a" (%current-path-string)
                                  "full page path2: ~{/~a~}" (%current-path)
                                  "device page path: ~{/~a~}" some-path)))

                (define-endpoint %my-endset about-google
                  ,(list "cool-companies" "google" "about")
                  `((,%redirect/normalize-path? . #f)
                    (,%redirect/remove-query? . #f))
                  (values (build-response*)
                          "Google provides the best services in the world..."))

                (define-endpoint %my-endset static-files
                  ("static" . file-path)
                  `((,%resource-root-path
                     . ,(dirname (search-path %load-path "cantius" ".scm")))
                    (,%default-headers
                     . ((content-type
                         . (text/formatted (charset . "Windows-1252"))))))
                  (call-with-input-file
                      (find-resource-file (string-join file-path "/"))
                    get-string-all))

                (define server-sock
                  (socket PF_INET SOCK_STREAM 0))

                (bind server-sock AF_INET INADDR_LOOPBACK 0)

                (define sock-port
                  (sockaddr:port (getsockname server-sock)))

                (define server-thread
                  (make-thread
                   (lambda ()
                     (run-cantius %my-endset #:socket server-sock))))

                (thread-start! server-thread)

                (thread-yield!))
             (test-env 'nonfree-site))
       #t))

  (define (get path)
    (false-if-exception
     (let* ((sock-port (eval 'sock-port (test-env 'nonfree-site)))
            (client-sock (open-socket-with-timeout
                          (format #f "http://localhost:~a" sock-port)
                          5)))
       (dynamic-wind
         (const #f)
         (lambda ()
           (receive (response response-body)
               (http-get (string-append "http://dummy" path) #:port client-sock)
             (list response response-body)))
         (lambda ()
           (close client-sock))))))

  (tu:test-group "ms-about"
    (define ms-result
      (get "/cool-companies/ms/about"))

    (tu:test-eqv 200 (rsp:response-code (car ms-result)))

    (tu:test-equal '(text/plain (charset . "utf-8"))
                   (rsp:response-content-type (car ms-result)))

    (tu:test-assert (string-prefix? "Microsoft is my favorite company"
                                    (cadr ms-result))))

  (for-each
   (lambda (path)
     (tu:test-group "ms-about-auto-redirect"
       (define ms-redirect-result
         (get path))

       (tu:test-eqv 301 (rsp:response-code (car ms-redirect-result)))

       (tu:test-equal "/cool-companies/ms/about"
                      (uri:uri-path
                       (rsp:response-location (car ms-redirect-result))))))
   '("/cool-companies//ms/about" "/cool-companies/ms/about?a=b"))

  (tu:test-group "error-500"
    (define error-500-result
      (get "/cool-companies/ms/product-list"))

    (tu:test-eqv 500 (rsp:response-code (car error-500-result)))

    (tu:test-assert (string-contains (cadr error-500-result) "Backtrace")))

  (tu:test-group "error-404"
    (define error-404-result
      (get "/cool-companies/amazon//about?c=d"))

    (tu:test-eqv 404 (rsp:response-code (car error-404-result))))

  (tu:test-group "drm-wiki"
    (define ipad-result
      (get "/drm-wiki/devices/apple/ipad"))

    (tu:test-equal (format #f "~@{~a~%~}"
                           "full page path1: /drm-wiki/devices/apple/ipad"
                           "full page path2: /drm-wiki/devices/apple/ipad"
                           "device page path: /apple/ipad")
                   (cadr ipad-result)))

  (tu:test-group "about-google"
    (define google-result
      (get "/cool-companies///google/about?e=f"))

    (tu:test-eqv 200 (rsp:response-code (car google-result)))

    (tu:test-assert (string-prefix? "Google provides" (cadr google-result))))

  (tu:test-group "valid-static-resources"
    (define valid-resource-result
      (get "/static/cantius.scm"))

    (tu:test-eqv 200 (rsp:response-code (car valid-resource-result)))

    (tu:test-equal '(text/formatted (charset . "Windows-1252"))
                   (rsp:response-content-type (car valid-resource-result)))

    (tu:test-assert (string-prefix? ";;; " (cadr valid-resource-result))))

  (tu:test-group "illegal-static-resources"
    (for-each (lambda (resource-path)
                (define illegal-resource-result
                  (get resource-path))

                (tu:test-eqv 403
                             (rsp:response-code (car illegal-resource-result)))

                ;; Default handler for illegal resource accesses is expected to
                ;; ignore the value of the `%default-headers` parameter.
                (tu:test-equal '(text/plain (charset . "utf-8"))
                               (rsp:response-content-type
                                (car illegal-resource-result))))

              '("/static/../../../../../etc/passwd"
                "/static/stylesheets/."
                "/static/nonfree/../scripts/main.js")))

  (tu:test-group "missing-static-resources"
    (define missing-resource-result
      (get "/static/i'm-not-here!!!"))

    (tu:test-eqv 404 (rsp:response-code (car missing-resource-result)))

    ;; Default handler for missing resource accesses is expected to ignore the
    ;; value of the `%default-headers` parameter.
    (tu:test-equal '(text/plain (charset . "utf-8"))
                   (rsp:response-content-type (car missing-resource-result))))

  (tu:test-assert (eval '(begin (thread-terminate! server-thread)
                                (close server-sock))
                        (test-env 'nonfree-site))))

(tu:test-group "normalize-path"
  (tu:test-equal "a/b/c/d"
                 ((@ (cantius) normalize-path) "a//b/./c//c1/../d"))

  (tu:test-equal "."
                 ((@ (cantius) normalize-path) "aa/bb/cc/../../.."))

  (tu:test-equal "/"
                 ((@ (cantius) normalize-path) "/dd/ee/ff/../../.."))

  (tu:test-equal "/../../g/h/i"
                 ((@ (cantius) normalize-path)
                  "/ignored0/../ignored1/../.././ignored2/../../g/h/i"))

  (tu:test-equal "../j/k/l"
                 ((@ (cantius) normalize-path) "../j/k/l")))