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))
             ((rnrs bytevectors) #:prefix bv:)
             ((srfi srfi-8) #:select (receive))
             ((srfi srfi-26) #:select (cut))
             ((srfi srfi-34) #:select (guard raise))
             ((srfi srfi-35) #:select (condition-has-type?))
             ((ice-9 safe-r5rs) #:select (null-environment))
             ((ice-9 format) #:select (format))
             ((ice-9 regex) #:select (regexp-substitute/global))
             ((web client) #:select (open-socket-for-uri http-get))
             ((web response) #:prefix rsp:)
             ((web uri) #:prefix uri:)
             ((myra-test-utils) #:prefix tu:)
             ((cantius) #:prefix cant:))

(define (use-crlf text)
  (regexp-substitute/global #f "\n" text 'pre "\r\n" 'post))

(define %form-data-good
  (use-crlf "\
----boundary
Content-Disposition: form-data; name=\"binary-field\"; filename=\"somefile\"
Content-Type: application/octet-stream

śómę-ńóń-ĄŚĆII-dątą\\
----boundary
Content-Disposition: form-data; name=\"text-field1\"
Content-Transfer-Encoding: binary

óthęr-ńóń-ĄŚĆII-dątą\\
----boundary
Content-Disposition: form-data; name=\"text-field2\";
Content-Type: text/plain

//yęt-óthęr-ńóń-ĄŚĆII-dątą
----boundary--
"))

(define %form-data-bad-epilogue
  (use-crlf "\
----boundary
Content-Disposition: form-data; name=\"field\"

value
----boundary--SOMETHING-INCORRECT-HERE
"))

(define %form-data-unsupported-encoding
  (use-crlf "\
----boundary
Content-Disposition: form-data; name=\"field\"
Content-Transfer-Encoding: 7bit

value
----boundary--
"))

(define %form-boundary-1
  "--boundary")

(define %form-boundary-2
  "--boundary-with-\\-(a-backslash)")

(tu:test-group "parse-multipart/form-data"
  (for-each
   (lambda (boundary form-data)
     (define (parsed-multipart)
       (cant:parse-multipart/form-data boundary (bv:string->utf8 form-data)))

     (tu:test-eqv 3 (length (parsed-multipart)))

     (tu:test-equal '("binary-field" "text-field1" "text-field2")
                    (map cant:form-data-part-name (parsed-multipart)))

     (tu:test-equal '(((content-disposition . (form-data
                                               (name . "binary-field")
                                               (filename . "somefile")))
                       (content-type . (application/octet-stream)))
                      ((content-disposition . (form-data
                                               (name . "text-field1")))
                       (content-transfer-encoding . "binary"))
                      ((content-disposition . (form-data
                                               (name . "text-field2")))
                       (content-type . (text/plain))))
                    (map cant:form-data-part-headers (parsed-multipart)))

     (tu:test-equal '(#t #f #f)
                    (map cant:form-data-part-binary? (parsed-multipart)))

     (tu:test-equal `(,(bv:string->utf8 "śómę-ńóń-ĄŚĆII-dątą\\")
                      "óthęr-ńóń-ĄŚĆII-dątą\\"
                      "//yęt-óthęr-ńóń-ĄŚĆII-dątą")
                    (map cant:form-data-part-data (parsed-multipart))))
   (list %form-boundary-1 %form-boundary-2)
   (list %form-data-good
         (regexp-substitute/global #f %form-boundary-1 %form-data-good
                                   'pre %form-boundary-2 'post)))

  (tu:test-error (cut condition-has-type? <> cant:&bad-request)
                 (cant:parse-multipart/form-data
                  %form-boundary-1
                  (bv:string->utf8 %form-data-bad-epilogue)))

  (tu:test-error (compose (cut = 415 <>)
                          cant:condition-http-code)
                 (cant:parse-multipart/form-data
                  %form-boundary-1
                  (bv:string->utf8 %form-data-unsupported-encoding))))

(tu:test-group "parse-cookies"
  (tu:test-equal '(("name" . "val"))
                 (cant:parse-cookies "name=val;"))

  (tu:test-equal '(("ses sion" . "fargtrg34")
                   ("s" . "f")
                   ("forms-session2" . "")
                   ("forms-sessio n3" . "f4 3433=g = 4"))
                 (cant:parse-cookies
                  (string-append "\t\tses sion =fargtrg34;"
                                 " s = f;"
                                 "forms-session2=\n;"
                                 " forms-sessio n3=f4 3433=g = 4")))

  (tu:test-equal '() (cant:parse-cookies ""))

  (for-each (lambda (bad-cookies)
              (tu:test-error (cut condition-has-type? <> cant:&bad-request)
                             (cant:parse-cookies bad-cookies)))
            '(";"
              "c1=v1;c2=v2;c3;c4=v4"
              "something"
              "k=v;;")))

(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"
    (define illegal-resource-result
      (get "/static/stylesheets/../../../../../../etc/passwd"))

    (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))))

  (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")))