test/script-engine.lisp

   1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
   2 ;;; $Header: /usr/local/cvsrep/hunchentoot/test/test.lisp,v 1.24 2008/03/06 07:46:53 edi Exp $
   3
   4 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz.  All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :hunchentoot-test)
  31
  32 (defun file-contents (pathname &key (element-type '(unsigned-byte 8)))
  33   (with-open-file (s pathname :element-type element-type)
  34     (let ((result (make-array (file-length s) :element-type element-type)))
  35       (read-sequence result s)
  36       result)))
  37
  38 (defclass script-context ()
  39   ((base-url :initarg :base-url
  40              :reader script-context-base-url
  41              :documentation "Base URL to be used for all HTTP requests in this script context")))
  42
  43 (defmethod initialize-instance :before ((script-context script-context) &key context-class-name)
  44   ;; just ignore the context-class-name so that we can use &args in the WITH-SCRIPT-CONTEXT macro below.
  45   (declare (ignore context-class-name)))
  46
  47 (defvar *script-context* nil
  48   "Current script context")
  49
  50 (defmacro with-script-context ((&rest args &key (context-class-name 'script-context) &allow-other-keys)
  51                                &body body)
  52   `(let ((*script-context* (make-instance ',context-class-name ,@args))
  53          (*default-pathname-defaults* *this-file*)
  54          failed)
  55      (handler-bind
  56         ((assertion-failed (lambda (condition)
  57                              (push condition failed)
  58                              (format t "Assertion failed:~%~A~%" condition))))
  59        (prog1
  60            (progn ,@body
  61                   (values))
  62          (if failed
  63              (format t ";; ~A assertion~:P FAILED~%" (length failed))
  64              (format t ";; all tests PASSED~%"))))))
  65
  66 (defclass http-reply ()
  67   ((body :initarg :body)
  68    (status-code :initarg :status-code)
  69    (headers :initarg :headers)
  70    (uri :initarg :uri)
  71    (stream :initarg :stream)
  72    (close :initarg :close)
  73    (reason-phrase :initarg :reason-phrase)))
  74
  75 (defvar *last-reply* nil
  76   "Contains the last HTTP reply received")
  77
  78 (define-condition assertion-failed (simple-condition)
  79   ((assertion :initarg :assertion
  80               :accessor condition-assertion
  81               :initform nil)
  82    (reply-slot-name :initarg :reply-slot-name
  83                     :reader condition-reply-slot-name)
  84    (reply-value :initarg :reply-value
  85                 :reader condition-reply-value)
  86    (operator :initarg :operator
  87              :reader condition-operator)
  88    (args :initarg :args
  89          :reader condition-args)
  90    (reply :initarg :reply
  91           :reader condition-reply))
  92   (:report print-assertion))
  93
  94 (defun print-assertion (condition stream)
  95   (format stream " (~A "
  96           (condition-operator condition))
  97   (loop
  98      for rest on (cons (condition-reply-value condition)
  99                        (condition-args condition))
 100      for value = (car rest)
 101      for more-p = (cdr rest)
 102      do (if (and (arrayp value) (not (stringp value)))
 103             (format stream "<array>")
 104             (format stream "~S" value))
 105      when more-p
 106        do (princ #\Space stream))
 107   (format stream ")~%"))
 108
 109 (defun function-designator-p (thing)
 110   "Return true value if THING is a function or a symbol that has a function definition."
 111   (or (functionp thing)
 112       (and (symbolp thing)
 113            (fboundp thing))))
 114
 115 (defmacro with-operator-defaulting ((default-operator) &body body)
 116   "If OPERATOR is not a function designator, prepend it to ARGS and
 117 bind OPERATOR to DEFAULT-OPERATOR.  OPERATOR and ARGS are captured
 118 from the expansion environment."
 119   `(if (function-designator-p operator)
 120        (progn ,@body)
 121        (let ((operator ',default-operator)
 122              (args (cons operator args)))
 123          ,@body)))
 124
 125 (defun http-assert (reply-slot-name operator &rest args)
 126   (let ((reply-value (slot-value *last-reply* reply-slot-name)))
 127     (with-operator-defaulting (equal)
 128       (unless (apply operator reply-value args)
 129         (signal 'assertion-failed
 130                 :reply-slot-name reply-slot-name
 131                 :reply-value reply-value
 132                 :operator operator
 133                 :args args
 134                 :reply *last-reply*)))))
 135
 136 (define-condition header-assertion-failed (assertion-failed)
 137   ((header-name :initarg :header-name :reader condition-header-name)))
 138
 139 (defun http-assert-header (header-name operator &rest args)
 140   (let ((header-value (cdr (assoc header-name (slot-value *last-reply* 'headers) :test #'string-equal))))
 141     (with-operator-defaulting (matches)
 142       (unless (apply operator header-value args)
 143         (signal 'header-assertion-failed
 144                 :reply-slot-name 'headers
 145                 :header-name header-name
 146                 :reply-value header-value
 147                 :operator operator
 148                 :args args
 149                 :reply *last-reply*)))))
 150
 151 (defun http-assert-body (regex)
 152   (http-assert 'body 'matches regex))
 153
 154 (defun matches (string regex)
 155   (cl-ppcre:scan regex string))
 156
 157 (defun integer-equal (string integer)
 158   (eql (parse-integer string) integer))
 159
 160 (defun http-request (url
 161                      &rest args
 162                      &key (protocol :http/1.1)
 163                           (method :get)
 164                           content
 165                           content-type
 166                           content-length
 167                           range
 168                           cookie-jar
 169                           basic-authorization
 170                           parameters
 171                           external-format-out)
 172   (declare (ignore protocol method content content-type content-length cookie-jar basic-authorization
 173                    range parameters external-format-out))
 174   (setf *last-reply* (make-instance 'http-reply))
 175   (with-slots (body status-code headers uri stream close) *last-reply*
 176     (setf (values body status-code headers uri stream close)
 177           (apply 'drakma:http-request
 178                  (format nil "~A~A" (script-context-base-url *script-context*) url)
 179                  args)))
 180   (values))