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