Permalink
Switch branches/tags
save2011_02_16 release10.1_t6 release10.1_t5 release10.1_t4 release10.1_t3 release10.1_t2 release10.1_t1 release10.1_release_point release10.1_rc5 release10.1_rc4 release10.1_rc3 release10.1_rc2 release10.1_rc1 release10.1_beta3_release_point release10.1.beta2_release_point release10.1.beta_t6 release10.1.beta_t5 release10.1.beta_t4 release10.1.beta_t3 release10.1.beta_t2 release10.1.beta_t1 release10.1.beta_release_point release10.1.beta_rc4 release10.1.beta_rc3 release10.1.beta_rc2 release10.1.beta_rc1 release10.0_t3 release10.0_t2 release10.0_t1 release10.0_rc9 release10.0_rc8 release10.0_rc7 release10.0_rc6 release10.0_rc5 release10.0_rc4 release10.0_rc3 release10.0_rc2 release10.0_rc1 release10.0.pre-final.30_release_point release10.0.pre-final.17_release_point release10.0.beta_t13 release10.0.beta_t12 release10.0.beta_t11 release10.0.beta_t10 release10.0.beta_t9 release10.0.beta_t8 release10.0.beta_t7 release10.0.beta_t6 release10.0.beta_t5 release10.0.beta_t4 release10.0.beta_t3 release10.0.beta_t2 release10.0.beta_t1 release10.0.beta_release_point release10.0.beta_rc2 release10.0.beta_rc1 release_aclt2 release_acl100b14t8 release_acl100b11t7 release_acl100b10t6 release_acl100b8t5 release_acl100b7t4 release_acl100b6t3 release_acl100b4t2 release_acl100b2t1 release_acl90b21rc5 release_acl90b20_release_point release_acl90b20rc4 release_acl90b19rc3 release_acl90b18rc2 release_acl90b15_release_point release_acl90b15rc1 release_acl90b13t1 release_acl90b11t1 release_acl90b9t1 release_acl90b8t1 release_acl90b6_release_point release_acl90b6rc2 release_acl90b_release_point release_acl90a52rc1 release_acl90a44rc2 release_acl90a43rc1 release_acl90a39 release_acl90a39rc2 release_acl90a32 release_acl90a27 release_acl90a25 release_acl90a24 release_acl90a23 release_acl90a20 release_acl90a18 install-spider_2013-04-26T12-55-31 install-spider_2013-04-25T12-56-58 install-spider_2013-04-24T16-52-55 install-spider_2013-04-24T16-42-42 install-spider_2013-04-24T16-29-36 install-spider_2013-04-24T15-47-16 install-spider_2013-04-24T15-37-01 install-spider_2013-04-24T15-02-09 install-spider_2013-04-23T11-10-35
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
151 lines (104 sloc) 3.54 KB
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; playback.cl
;;
;; See the file LICENSE for the full license governing this code.
;;
;;
;; Description:
;; playback a script generated by logging a site
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
;; 2010-12-08 mm: This file is not included in the build script for the
;; production release.
;; The code in playback-form assumes only one thread will be calling it
;; at any instant. Use by several threads will require adding some locks.
(in-package :net.aserve)
(eval-when (compile) (declaim (optimize (speed 3))))
(defvar *last-responses* nil)
(defparameter *debug-playback* nil)
(defun playback (server filename)
(with-open-file (p filename :direction :input)
(do ((form (read p nil nil) (read p nil nil))
(jar (make-instance 'net.aserve.client::cookie-jar)))
((null form))
(playback-form server form jar))))
(defun playback-form (server form jar)
(macrolet ((qval (tag) `(cdr (assoc ,tag form :test #'equal))))
(let ((method (qval :method))
(uri (qval :uri))
(code (qval :code))
(auth (qval :auth))
(body (qval :body)))
;; special hack to handle a few cases
(if* (and body (match-re "user-id=" body))
then ; must do the hack
(multiple-value-bind (user-id call-id)
(find-user-id-etc)
(if* user-id
then
(setq body
(concatenate 'string
(format nil "user-id=~a&call-id=~a&~a"
user-id
call-id
(remove-regexp
"user-id=[^&]+&"
(remove-regexp
"call-id=[^&]*&"
body)))))
(and *debug-playback* (format t "~%~%new body ~s~%~%" body))
)))
;;
(if* (eql 401 code)
then ; authorization needed
(format t "auth failed, skipping ~s~%" uri)
(return-from playback-form nil))
(and *debug-playback* (format t "do ~s ~s~%" method uri))
(multiple-value-bind (body retcode headers)
(net.aserve.client:do-http-request
(format nil "~a~a" server uri)
:method method
:content (and (eq method :post)
body)
:content-type (and (eq method :post)
(qval :ctype))
:basic-authorization auth
:cookies jar)
(declare (ignore headers))
(push body *last-responses*)
(and *debug-playback*
(format t "ret ~s length(body) ~s~%" retcode (length body)))))))
(defun find-user-id-etc ()
(dolist (resp *last-responses*)
(multiple-value-bind (ok whole call-id)
(match-re "name=\"call-id\" value=\"(.*?)\""
resp
:multiple-lines t
:case-fold t)
(declare (ignore whole))
(if* ok
then (and *debug-playback* (format t "new call id is ~s~%" call-id))
else (and *debug-playback* (format t "No call id~%"))
(go out))
(multiple-value-bind (ok whole user-id)
(match-re "name=\"user-id\" value=\"(.*?)\""
resp
:case-fold t
:multiple-lines t)
(declare (ignore whole))
(if* ok
then (and *debug-playback* (format t "new user id is ~s~%" user-id))
else (and *debug-playback* (format t "No call id in ~s~%" resp))
(go out))
(return (values user-id call-id))))
out
))
(defun remove-regexp (regexp string)
(multiple-value-bind (ok whole before after)
(match-re (format nil "^(.*)~a(.*)$" regexp) string)
(declare (ignore whole))
(if* ok
then (concatenate 'string before after)
else string)))