;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; proxy.cl
;;
;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2000-2007 Franz Inc, Oakland, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. See the GNU
;; Lesser General Public License for more details.
;;
;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;
;;
;; $Id: proxy.cl,v 1.50 2009/01/23 06:52:20 jkf Exp $
;; Description:
;; aserve's proxy and proxy cache
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(in-package :net.aserve)
(check-smp-consistency)
(defmacro with-mp-locked-connection-cache ((s) &rest body)
(smp-case
((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
,@body))
(nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
(defmacro with-mp-locked-pcache-ent ((s) &rest body)
(smp-case
((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
,@body))
(nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
(defmacro with-fast-mp-locked-pcache-ent ((s) &rest body)
(smp-case
((t :macros) `(with-locked-structure (,s :-smp :atomically)
,@body))
(nil `(excl::atomically ,s ,@body)))) ;; in a #-smp block
(defmacro with-mp-locked-pcache ((s) &rest body)
(smp-case
((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
,@body))
(nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
(defmacro with-mp-locked-pcache-queue ((s) &rest body)
(smp-case
((t :macros) `(with-locked-structure (,s :-smp :without-scheduling)
,@body))
(nil `(si::without-scheduling ,s ,@body)))) ;; in a #-smp block
; denotes a request from the browser
(defconstant *browser-level* 100) ;
(defparameter *extra-lifetime-factor* 1.1)
; number of seconds to add to expiration time of any entry in cache
(defparameter *extra-lifetime* 0)
; true if we are to save cached connections
(defparameter *connection-caching* t)
; statistics about connection caching
(defparameter *connections-cached* 0) ; number of connections put in to cache
(defparameter *connections-made* 0) ; number of make-socket calls made
(defparameter *connections-used-cached* 0) ; number of cached connections used
; the cache
(defparameter *connection-cache-queue* (cons nil nil)) ; (first . last) queue of conn-cache objects
(defparameter *connection-cache-expire* 10) ; number of seconds to live
(defparameter *connection-cache-lock*
(smp-case
((t :macros) (excl::make-basic-lock :name "connection-cache"))
(nil nil)))
; number of seconds we wait for a connect before we consider it timed
; out. Given the chance Linux seems to wait forever for a connection
; so we need to shut it down ourselves.
(defparameter *connection-timed-out-wait* 30)
(defstruct (pcache
#+smp-macros (:include synchronizing-structure)
)
;; proxy cache
table ; hash table mapping to pcache-ent objects
disk-caches ; list of pcache-disk items
cleaner ; process doing housecleaning
(cleaner-lock (mp:make-process-lock :name "cache cleaner"))
size ; specified size of the cache (in blocks)
high-water ; when blocks in cache gets above this start flushing to disk
low-water ; when blocks in cache get below this stop flushing
(dead-items 0) ; total number of objects on the dead-ent list
(level0-time 0) ; last time level0 access was done
queueobj ; queue object holding in-memory cache objects
dead-ent ; linked list of dead pcache-ents, linked by next field only
; hash table of handlers for uris, keyed by host
uri-info-table
; pointer to linkscan object if we are doing automatic link scanning
; in the proxy cache
linkscan
entry-cached-hook ; funcalled with pcache, pcache-ent and level
; requests that completely bypass the cache
(r-direct 0)
; ims or non-ims where there is no entry that mathes this url
; and the request headers
(r-miss 0)
; like r-miss except the level is greater than 0 thus this is a
; cache fill rather than a direct user request
(r-cache-fill 0)
; non-ims request. value within the min-freshness contstraints
; ims request where we know that the value in the cache is fresh
; and has been modified since the ims time
(r-fast-hit 0)
; non-ims request. value is stale but after checking with the
; origin server we find that our value is up to date
(r-slow-hit 0)
; ims request made and cached value is fresh and based on that
; we know that the client's version is fresh so send
; not-modified response back
(r-fast-validation 0)
; ims request where we return not-modified after checking with
; the origin server
(r-slow-validation 0)
; stale copy in the cache, we check with the origin server
; and find that our copy was inconsistent and get a new copy to cache
(r-consistency-miss 0)
)
(defstruct pcache-disk
;; for each disk file on which we are caching
filename
stream
blocks ; total blocks in cache
free-blocks ; number of blocks remaining
free-list ; list of (start . end) blocks that are free
high-water ; when free blocks is less than this start flushing
low-water ; when free blocks is more than this stop flushing
(lock (mp:make-process-lock :name "disk pcache"))
; doubly linked list of pcache-ents in this cache
queueobj
)
; each pcache entry holds the information on a 200 response
; use state
; --- ------
; >=0 nil in memory cache entry. linked to mru-ent
; >0 :dead in memory entry in use but which will no longer be used
; after the uses are over. linked to dead-ent
; nil :dead in memory entry which is ready to be reclaimed along
; with all the blocks it points to. linked to dead-ent
;
(defstruct (pcache-ent
#+smp-macros (:include synchronizing-structure)
)
key ; the string form of the uri
uri ; the actual uri
last-modified-string ; last modified time from the header
last-modified ; universal time entry was last modified
expires ; universal time when this entry expires
data ; data blocks (first is the response header block)
data-length ; number of octets of data
blocks ; number of cache blocks (length of the value in data slot)
code ; response code. 200 or 302
comment ; response comment
cookie ; the cookie if any with this request
; count of the internal use of this
use ; nil - dead entry. >= 0 - current users of this entry
(state :new) ; nil - normal ,
; :dead - trying to kill off,
; :new - filling the entry
;; scanned ; true when link scanning has been done
; number of times this entry was returned due to a request
(returned 0)
; if cached to the disk this tells where
disk-location
pcache-disk
loading-flag ; true when we are loading in from the disk
; linked list of pcache-ents
queueobj ; queue object we're stored in
prev
next
; scanning for links
; notes:
; links is initially nil and once the page has been scanned for links
; it is t or a list of uri objects
; or it is :scanning when then pcache-ent is in the to be link scanned
; level is non-zero when this entry is on the link-scan queue or
; uri-scan queue.
; scan-next is valid (nil or non-nil) when this entry is on the
; link-scan queue or uri-scan queue.
;
links ; nil or list of uris to img's then list of uris from a links
links-left ; list of uris still to scan
level ; level at which to scan these links
scan-next ; next pcache-ent to scan
(autoscan-time 0) ; univeral time when last scanned by the link scanner
)
(defstruct queueobj
(items 0) ; number of items in the queue (aside from dummy ones)
(bytes 0) ; number of data bytes cached
(blocks 0) ; number of buffer blocks
mru ; points to dummy pcache-ent at the head of the queue
lru ; points to dummy pcache-ent at the tail of the quee
)
(defstruct uri-info
;; information on how to handle a uri or set of uris
host ; string naming the host of the uri
(port 80)
path ; string in regexp form denoting the path. nil means all
path-regexp ; compiled regular expression for the path (or nil)
; nil or number of extra seconds of lifetime to add to uri
; nil means use systemwide default
extra-lifetime
; nil or default depth for link scanning
; nil means use systemwide default
scan-depth
exclude ; list of regexps for links to not scan
exclude-regexp ; compiled regexp versions of dont-follow
; called on links to determine at which level they should be followed
scan-function
; true if we should follow links to a site different than this page
offsite
)
(defclass locator-proxy (locator)
;; denotes sending the request to another machine
;;
())
(defun enable-proxy (&key (server *wserver*)
proxy-proxy)
;;
(let ((locator-proxy-obj
(make-instance 'locator-proxy
:name :proxy
:extra (make-instance 'computed-entity
:function #'(lambda (req ent)
(do-proxy-request req ent))
:extra (if* proxy-proxy
then (multiple-value-bind (host port)
(get-host-port proxy-proxy)
(if* (null host)
then (error "bad host port specification: ~s" proxy-proxy))
(cons host port)))))))
; must be first as other locators may not ignore absolute proxy urls
(pushnew locator-proxy-obj (wserver-locators server))
))
(defmethod standard-locator ((req http-request) (locator locator-proxy))
;; see if this is a proxy request and if so return the entity that
;; denotes we're proxying
(if* (uri-scheme (request-raw-uri req))
then ; compute entity object
(locator-extra locator)))
(defun do-proxy-request (req ent)
;; a request has come in which has a uri with a scheme part,
;; thus denoting a request to be proxied (unless it's on our machine).
(let* ((uri (request-raw-uri req))
(scheme (uri-scheme uri))
(host (uri-host uri))
(port (or (uri-port uri) 80))
)
(if* (or (not (eq scheme :http))
(null host))
then (with-http-response (req ent :response *response-bad-request*)
(with-http-body (req ent)
(html (:html (:head (:title "Bad Request"))
(:body "This url isn't a valid proxy request "
(:princ-safe (net.uri:render-uri uri nil)))))))
else ; see if it's a local request
(let ((ipaddr (ignore-errors (socket:lookup-hostname host))))
(if* (null ipaddr)
then (with-http-response (req ent :response
*response-not-found*)
(with-http-body (req ent)
(html
(:html
(:head (:title "404 - Not Found"))
(:body
(:h1 "Host not found")
"The proxy failed to find the address for host "
(:b (:princ-safe host)))))))
(return-from do-proxy-request))
(if* (and ipaddr
(member ipaddr
(wserver-ipaddrs *wserver*))
(eq port
(socket:local-port (wserver-socket *wserver*)))
)
then ; it's us, make it into into a local request
; and look it up again
(setf (request-raw-uri req)
(net.uri:copy-uri uri :scheme nil :host nil))
(handle-request req)
else ; must really proxy
(check-cache-then-proxy-request
req ent t *browser-level*))))))
(defmethod unpublish-locator ((locator locator-proxy))
nil)
(defun proxy-request (req ent &key pcache-ent (respond t)
(level *browser-level*))
;; a request has come in with an http scheme given in uri
;; and a machine name which isn't ours.
;;
;; the headers have been parsed.
;;
;; send out the request
;; get the response and if respond is true send back the response
;;
(let* ((request-body (get-request-body req))
(outbuf (get-header-block))
(outend)
(clibuf)
(cliend)
(sock)
(uri (request-raw-uri req))
(host (uri-host uri))
(port (uri-port uri))
(method (request-method req))
(protocol :http/1.0)
(state :pre-send)
(keep-alive)
(cached-connection)
(phostport (and ent (entity-extra ent)))
(otherheaders))
(if* phostport
then ; we're proxying to a proxy. yikes
(setq host (car phostport)
port (cdr phostport)))
(unwind-protect
(tagbody
retry-proxy
(handler-bind ((error
#'(lambda (cond)
(logmess
(format nil "error during proxy: ~a ~% with ~
cached connection = ~s~%" cond cached-connection))
(if* cached-connection
then ; retry
(logmess "retry proxy")
(if* sock
then (ignore-errors
(close sock :abort t)))
(go retry-proxy))
(if* pcache-ent
then (kill-pcache-ent pcache-ent))
(if* (not (member :notrap *debug-current*
:test #'eq))
then ; we want to auto-handle the error
(if* (eq state :pre-send)
then ; haven't sent anything
; so send failed response
(ignore-errors
(proxy-failure-response req ent)))
(return-from proxy-request nil)))))
(setq keep-alive nil ; assume not keep alive
cached-connection nil)
; create outgoing headers by copying
(copy-headers (request-header-block req) outbuf
*header-client-array*)
;; now insert new headers
; content-length is inserted iff this is put or post method
(if* (member method '(:put :post) :test #'eq)
then (insert-header outbuf :content-length
(format nil "~d"
(if* request-body
then (length request-body)
else 0))))
; connection we'll set to 'close' for now but at some point
; we'll connection caching so we'll want to do some keep-alive'ing
;
(insert-header outbuf :connection
(if* *connection-caching*
then "Keep-Alive"
else "close"))
;(logmess "outbuf now")
;(dump-header-block outbuf *initial-terminal-io*)
; send host header
(let ((host (or (request-header-host req)
(header-buffer-header-value
(request-header-block req) :host)
(if* port
then (format nil "~a:~d"
host port)
else host))))
(insert-header outbuf :host host))
; if the proxier decides to check authorization before
; doing a proxy then the authorization header will appear
; in the request-headers list and we want to prevent the
; authorization header from being sent twice in this case:
; [spr33532]
(dolist (header (request-headers req))
(if* (not (eq (car header) :authorization))
then (insert-non-standard-header outbuf (car header) (cdr header))))
(setq outend (add-trailing-crlf outbuf 1))
(if-debug-action :xmit
(format *debug-stream* "proxy converted headers toward server~%")
(dotimes (i outend)
(write-char (code-char (aref outbuf i)) *debug-stream*))
(format *debug-stream* "---- end---~%")
(force-output *debug-stream*))
; time to make a call to the server
(handler-case
(multiple-value-setq (sock cached-connection)
(get-possibly-cached-connection
host (or port 80)))
(error (cond)
(declare (ignore cond))
(if* respond
then (with-http-response (req ent :response
*response-not-found*)
(with-http-body (req ent)
(html
(:html
(:head (:title "404 - Not Found"))
(:body
(:h1 "404 - Not Found")
"The proxy failed to connect to machine "
(:b (:princ-safe host))
" on port "
(:b (:princ-safe (or port 80)))))))))
(return-from proxy-request)))
(if* *watch-for-open-sockets*
then (schedule-finalization
sock
#'check-for-open-socket-before-gc))
;; there are bogus ip redirectors out there that want to
;; see the whole request in the packet. (e.g www.cbs.com)
;; so we build as much as we can and then blast that out
; this is written in this non-pretty way for speed
(let ((firstbuf (get-header-block))
(ind 0)
(cmdstrings
'((:get . #.(make-array 3
:element-type '(unsigned-byte 8)
:initial-contents
(list
(char-int #\G)
(char-int #\E)
(char-int #\T))))
(:post . #.(make-array 4
:element-type '(unsigned-byte 8)
:initial-contents
(list
(char-int #\P)
(char-int #\O)
(char-int #\S)
(char-int #\T))))
))
(prot-strings
'((:http/1.0 . #.(make-array 8
:element-type '(unsigned-byte 8)
:initial-contents
(list
(char-int #\H)
(char-int #\T)
(char-int #\T)
(char-int #\P)
(char-int #\/)
(char-int #\1)
(char-int #\.)
(char-int #\0)
)))
(:http/1.1 . #.(make-array 8
:element-type '(unsigned-byte 8)
:initial-contents
(list
(char-int #\H)
(char-int #\T)
(char-int #\T)
(char-int #\P)
(char-int #\/)
(char-int #\1)
(char-int #\.)
(char-int #\1)
)))))
)
(let ((cmd (cdr (assoc method cmdstrings :test #'eq))))
; write method
(if* cmd
then (dotimes (i (length cmd))
(setf (ausb8 firstbuf i) (ausb8 cmd i)))
(incf ind (length cmd))
else ; unusual method, turn method into a string
(let ((str (string-upcase (string method))))
(dotimes (i (length str))
(setf (ausb8 firstbuf i)
(char-int (schar str i))))
(incf ind (length str))))
(setf (ausb8 firstbuf ind) #.(char-int #\space))
(incf ind)
; now the uri
(let ((str (if* phostport
then ; proxying so send http://...
(net.uri:render-uri (request-raw-uri req)
nil)
else (net.aserve.client::uri-path-etc uri))))
(dotimes (i (length str))
; should do string-to-octets...
(setf (ausb8 firstbuf ind)
(char-int (schar str i)))
(incf ind)))
(setf (ausb8 firstbuf ind) #.(char-int #\space))
(incf ind)
; now the protocol
(let ((cmd (cdr (assoc protocol prot-strings :test #'eq))))
(if* (null cmd)
then (error "can't proxy protocol ~s" protocol))
(dotimes (i (length cmd))
(setf (ausb8 firstbuf ind) (ausb8 cmd i))
(incf ind)))
(setf (ausb8 firstbuf ind) #.(char-int #\return))
(incf ind)
(setf (ausb8 firstbuf ind) #.(char-int #\linefeed))
(incf ind)
; now add as much of the headers as we can
(do ((i 0 (1+ i))
(tocopy (min (- (length firstbuf) ind) outend)))
((>= i tocopy)
;
(if-debug-action
:xmit
(format *debug-stream* "about to send~%")
(dotimes (i ind)
(write-char (code-char (ausb8 firstbuf i))
*debug-stream*))
(format *debug-stream* "<endof xmission>~%"))
(write-sequence firstbuf sock :end ind)
(if* (< i outend)
then ; still more from original buffer left
(write-sequence outbuf sock
:start i
:end outend))
)
(setf (ausb8 firstbuf ind) (ausb8 outbuf i))
(incf ind))
(free-header-block firstbuf)))
; now the body if any
(if* request-body
then (write-sequence request-body sock))
(force-output sock)
; a shutdown would make sense here but it seems to confuse
; the aol servers
;(socket:shutdown sock :direction :output)
(let (protocol response comment header-start given-content-length
body-buffers body-length)
(loop
; loop until we don't get a 100 continue
;
; now read the response and the following headers
(setq outend (read-headers-into-buffer sock outbuf))
(if* (null outend)
then ; response coming back was truncated
(error "truncated proxy response"))
(multiple-value-setq (protocol response comment header-start)
(parse-response-buffer outbuf))
(if* (null protocol)
then ; bogus response
(return-from proxy-request
(proxy-failure-response req ent)))
(if* (not (eql response 100)) then (return)))
(setf (request-reply-code req)
(code-to-response response)) ; for the logging
(setq otherheaders
(parse-header-block outbuf header-start outend))
; Get the body of the message if any.
; there is never a response to a :head request although the header
; fields may imply there is.
; These response codes don't have a message body:
; 1xx, 204, 304
; All other responses include a message body which may be of zero size
;
(if* (setq given-content-length
(header-buffer-header-value outbuf :content-length))
then (setq given-content-length
(net.aserve.client::quick-convert-to-integer
given-content-length)))
(if* (not (or (eq (request-method req) :head)
(<= 100 response 199)
(eq response 204)
(eq response 304)))
then ; got to read the body
(multiple-value-setq (body-buffers body-length)
(read-into-block-buffers sock
given-content-length))
(if* (and given-content-length
(not (eql body-length given-content-length)))
then (warn "content-length ~s but body length ~d"
given-content-length body-length)
(setq given-content-length body-length)))
(setf (request-reply-content-length req)
(or body-length given-content-length 0))
(setq keep-alive
(equalp (header-buffer-header-value outbuf :connection)
"keep-alive"))
(if* keep-alive
then (add-to-connection-cache sock
host
(or port 80))
else (close sock))
(setq sock nil)
; convert the header we received from the server into one
; to send to the client
(setq clibuf (get-sresource *header-block-sresource*))
(copy-headers outbuf clibuf *header-server-array*)
; add content-length if known
(if* given-content-length
then (insert-header clibuf :content-length
(format nil "~s" given-content-length)))
; should add a 'via' line
; transfer-encoding -
; we won't chunk back since we know the content length
(dolist (header otherheaders)
(insert-non-standard-header clibuf (car header) (cdr header)))
(setq cliend (add-trailing-crlf clibuf 2))
(if-debug-action
:xmit
(format *debug-stream* "~%~%proxy converted headers toward client~%")
(dotimes (i cliend)
(write-char (code-char (aref clibuf i))
*debug-stream*))
(format *debug-stream* "---- end---~%")
(force-output *debug-stream*))
; do the response
(setq state :post-send)
(if* respond
then (ignore-errors
(let ((rsock (request-socket req)))
(format rsock "HTTP/1.1 ~d ~a~a" response (and comment (octets-to-string comment)) *crlf*)
(write-sequence clibuf rsock :end cliend)
(if* body-length
then (write-body-buffers rsock body-buffers
body-length))
(force-output rsock))))
(if* (and pcache-ent
(eq (request-method req) :get))
then ; we are caching
(let ((tmp-clibuf clibuf)
(tmp-body-buffers body-buffers))
(setf clibuf nil
body-buffers nil)
(cache-response req pcache-ent
response comment tmp-clibuf
tmp-body-buffers body-length level)
; these buffers have been saved in the cache
; so nil them out so they aren't freed
))
(dolist (block body-buffers) (free-header-block block))
)))
;; cleanup forms
(if* sock
then (ignore-errors (force-output sock))
(ignore-errors (close sock :abort t)))
(free-header-block outbuf)
(free-header-block clibuf))))
(defun parse-response-buffer (buff)
;; the buffer should contain the first line of an http respose
;; and a response code, a crlf and then headers (but not including
;; the crlf after the headers)
;;
(let (protocol response-code comment beginc)
(flet ((match (array list)
; test if the list of bytes matches the prefix of the array
(do ((i 0 (1+ i))
(ll list (cdr ll)))
((null ll) t)
(if* (not (eq (aref array i) (car ll)))
then (return nil)))))
;;
(if* (match buff '(#.(char-int #\H)
#.(char-int #\T)
#.(char-int #\T)
#.(char-int #\P)
#.(char-int #\/)
#.(char-int #\1)
#.(char-int #\.)))
then (case (aref buff 7)
(#.(char-int #\0) (setq protocol :http/1.0))
(#.(char-int #\1) (setq protocol :http/1.1)))
(if* (null protocol)
then (return-from parse-response-buffer nil)))
; compute response code
(let ((val 0)
(i 8))
(loop
(let ((chv (aref buff i)))
(if* (<= #.(char-code #\0) chv #.(char-code #\9))
then (setq val (+ (* val 10) (- chv #.(char-code #\0))))
elseif (member chv '(#.(char-code #\space)
#.(char-code #\return)
#.(char-code #\linefeed))
:test #'eq)
then (if* (not (zerop val))
then (return) ; whitespace after value, get out
)
else ; bogus response code
(return-from parse-response-buffer nil))
(incf i)))
(setq response-code val)
; search for begining of comment
(loop
(let ((chv (aref buff i)))
(if* (member chv '(#.(char-code #\return)
#.(char-code #\linefeed))
:test #'eq)
then ; end of line before seeing a comment
(return)
elseif (not (eq chv #.(char-code #\space)))
then ; beginning of comment
(setq beginc i)
(return))
(incf i)))
(if* beginc
then ; found beginning, search for end
(loop (let ((chv (aref buff i)))
(if* (member chv '(#.(char-code #\return)
#.(char-code #\linefeed))
:test #'eq)
then ; hit the end
(return))
(incf i))))
; we have what we need
(if* beginc
then (let ((str (make-array (- i beginc)
:element-type '(unsigned-byte 8))))
(do ((jj beginc (1+ jj))
(ii 0 (1+ ii)))
((>= jj i))
(setf (aref str ii)
(aref buff jj)))
(setq comment str)))
(values protocol response-code comment i)))))
(defun read-into-block-buffers (sock size)
;; read up to size bytes from sock into a sequnce of block
;; buffers.
;; if size is nil then read until end of file.
;; return a list of block buffers with all full except perhaps
;; the last one
;; return a second value which is the number of bytes read
(if* (eql size 0)
then (return-from read-into-block-buffers (values nil 0)))
(let (res block len bytesleft (bytesread 0) (start 0))
(setq block (get-sresource *header-block-sresource*))
(push block res)
(setq len (length block))
(setq bytesleft (or size len))
(loop
(let ((retv (rational-read-sequence block sock
:start start
:end (min len (+ start bytesleft)))))
(if* (<= retv start)
then ; end of file
(return)
else ; read something
(if* size
then (decf bytesleft (- retv start))
else (incf bytesread (- retv start)))
(if* (<= bytesleft 0)
then (return)) ; all done
(setq start retv)
(if* (>= start len)
then ; need a new block
(push (setq block (get-sresource
*header-block-sresource*))
res)
(setq start 0)))))
(values (nreverse res)
(if* size
then (- size bytesleft)
else bytesread))))
(defun write-body-buffers (sock buffers length)
;; write all the data in the buffers to the socket
(if* (> length 0)
then (let ((len (if* buffers then (length (car buffers)))))
(dolist (buff buffers)
(write-sequence buff sock :end (min length len))
(decf length len)
(if* (<= length 0) then (return))))))
(defun proxy-failure-response (req ent)
(with-http-response (req ent :response *response-not-found*)
(with-http-body (req ent)
(html (:title "not found by proxy")
(:body
(:h1 "not found")
"The proxy could not find the requested uri: "
(:princ-safe (request-raw-uri req)))))))
;;;--------------------- connection cache -------------
(defstruct connection-cache-ent
expire ; time when this entry expires
host
port
socket
)
(defun add-to-connection-cache (socket host port)
(let* ((now (get-universal-time))
(ent (list (make-connection-cache-ent
:expire (+ now *connection-cache-expire*)
:host host
:port port
:socket socket)))
(queue *connection-cache-queue*))
(incf *connections-cached*)
(with-mp-locked-connection-cache (*connection-cache-lock*)
(incf *connections-cached*)
(let ((start (first-valid-entry now queue)))
(if* (null start)
then ; empty, this is the first entry
(setf (car queue)
(setf (cdr queue) ent))
; add at the end
else (setf (cdr (cdr queue)) ent)
(setf (cdr queue) ent))))))
(defun first-valid-entry (now queue)
;; remove expired entries and return the list of entries
;; beginning with the first non expired entry
(let ((start (car queue)))
; scan down cache removing expired entries
(loop
(if* (null start) then (return))
(if* (< (connection-cache-ent-expire
(car start))
now)
then ; kill this one
(ignore-errors
(close (connection-cache-ent-socket
(car start))
:abort t))
(setf (car queue)
(setq start (cdr start)))
else (return)))
start))
(defun get-possibly-cached-connection (host port)
;; check the cache and then return a cached connection
;; build a new one if there isn't one cached
(let ((now (get-universal-time))
(queue *connection-cache-queue*))
(with-mp-locked-connection-cache (*connection-cache-lock*)
(let ((start (first-valid-entry now queue))
(prev nil))
(loop
(if* (null start) then (return))
(if* (and (equalp host (connection-cache-ent-host (car start)))
(eql port (connection-cache-ent-port (car start))))
then ; a match
(if* prev
then ; slice it out
(if* (null (setf (cdr prev) (cdr start)))
then ; we removed last entry, fix last
(setf (cdr queue) prev))
else ; we're removing the first
(setf (car queue) (cdr start)))
(incf *connections-used-cached*)
(return-from get-possibly-cached-connection
(values (connection-cache-ent-socket (car start)) t)))
(setq prev start
start (cdr start)))))
; get here if there is no match
(incf *connections-made*)
(socket:with-pending-connect
(mp:with-timeout (*connection-timed-out-wait* ; ok w-t
(error "connection timed out"))
(socket:make-socket :remote-host host
:remote-port port
:format :bivalent
:type *socket-stream-type*
:nodelay t)))))
;;;--------------------- proxy cache ------------------
(defparameter *min-freshness* 10) ; assume values valid this long
(defparameter *likely-fresh* 60) ; values probably valid this long but check
; cache items are in one of these states
; fresh - item in case is considered to be valid
; stale - item in cache may be valid but it will requires validate to verify
;
; proxy cache actions
; direct - go to the proxy without considering the cache
; hit - found item in the cache and it is fresh
;
(defun create-proxy-cache (&key (server *wserver*) (size #.(* 10 1024 1024)))
;; create a cache for the proxy
(let (pcache)
(setf (wserver-pcache server)
(setq pcache (make-pcache
:table (make-hash-table :size 1000 :test #'equal)
:queueobj (make-and-init-queueobj)
:uri-info-table (make-hash-table :test #'equalp)
)))
(configure-memory-cache :server server :size size)
(start-proxy-cache-processes server pcache)))
(defun start-proxy-cache-processes (server pcache)
(let ((name (format nil "~d-cache-cleaner" (incf *thread-index*))))
(setf (pcache-cleaner pcache)
(mp:process-run-function
name
#'(lambda (server)
(let ((*wserver* server)
(pcache (wserver-pcache server)))
(loop
(if* (null (wserver-accept-thread server))
then ; we are shutting down, exit thread
(return))
(mp:with-process-lock ((pcache-cleaner-lock pcache))
(ignore-errors (cache-housekeeping)))
(sleep 30))))
server))
(setf (getf (mp:process-property-list (pcache-cleaner pcache))
'short-name)
(format nil "c~d" *thread-index*))
)
(publish :path "/cache-stats"
:function
#'(lambda (req ent)
(display-proxy-cache-statistics req ent pcache)))
(publish :path "/cache-entries"
:function
#'(lambda (req ent)
(display-proxy-cache-entries req ent pcache)))
(publish :path "/cache-entries-gc"
:function
#'(lambda (req ent)
(gc)
(display-proxy-cache-statistics req ent pcache)))
(publish :path "/cache-entries-global-gc"
:function
#'(lambda (req ent)
(gc t)
(display-proxy-cache-statistics req ent pcache)))
)
(defun kill-proxy-cache (&key (server *wserver*))
;; kill off the cache and return all resources to the pool
(let ((pcache (wserver-pcache server)))
(if* (null pcache) then (return-from kill-proxy-cache))
(mp:with-process-lock ((pcache-cleaner-lock pcache))
;; now we know that the other thread cleaning out
;; the cache won't call cache-housekeeping while we're
;; busy doing our business.
; this will signal the cache cleaner process to exit
(setf (pcache-cleaner pcache) nil)
; clean out and remove the disk caches first
(dolist (pcache-disk (pcache-disk-caches pcache))
(flush-disk-cache pcache pcache-disk 0)
(ignore-errors (close (pcache-disk-stream pcache-disk)))
(ignore-errors (delete-file (pcache-disk-filename pcache-disk))))
(setf (pcache-disk-caches pcache) nil)
; now clean the memory cache
(flush-memory-cache pcache 0)
; and now return all the blocks on dead list
(flush-dead-entries pcache))))
(defun configure-memory-cache (&key (server *wserver*)
size)
;; specify the desired size of the memory cache
(let ((pcache (wserver-pcache server)))
(if* (null pcache)
then (error "There is no memory cache to size"))
; store it in blocks
(setf (pcache-size pcache) (truncate size *header-block-size*))
(setf (pcache-high-water pcache) (truncate (* .90 (pcache-size pcache))))
(setf (pcache-low-water pcache) (truncate (* .80 (pcache-size pcache))))))
(defun add-disk-cache (&key (server *wserver*)
filename
(size #.(* 10 1024 1024)))
(if* (null filename)
then ; create a filename
(loop
(let ((name (format nil "acache-~x.acf" (random 34567))))
(if* (not (probe-file name))
then (setq filename name)
(return)))))
(let* ((blocks (truncate size *header-block-size*))
(pcache-disk (make-pcache-disk
:filename filename
:queueobj (make-and-init-queueobj)
:high-water (truncate (* .90 blocks))
:low-water (truncate (* .80 blocks))
:blocks blocks
:free-blocks blocks
:free-list (list (cons 0 (1- blocks)))
:stream (open filename
:if-exists :supersede
:if-does-not-exist :create
:direction :io
#-(and allegro (version>= 6))
:element-type
#-(and allegro (version>= 6))
'(unsigned-byte 8)))))
(push pcache-disk (pcache-disk-caches
(wserver-pcache server)))
filename))
(defun make-and-init-queueobj ()
; make a queue object with the dummy mru,lru entries
(let ((q (make-queueobj
:mru (make-pcache-ent)
:lru (make-pcache-ent))))
(setf (pcache-ent-next (queueobj-mru q)) (queueobj-lru q)
(pcache-ent-prev (queueobj-lru q)) (queueobj-mru q))
q))
(defun display-proxy-cache-statistics (req ent pcache)
; count number of memory entries
(let ((dead-bytes 0)
(dead-blocks 0))
(do ((ent (pcache-dead-ent pcache) (pcache-ent-next ent)))
((null ent))
(let ((this-data-length (pcache-ent-data-length ent))
(this-dead-blocks (pcache-ent-blocks ent)))
(if* this-data-length
then (incf dead-bytes this-data-length))
(if* this-dead-blocks
then (incf dead-blocks this-dead-blocks))))
(with-http-response (req ent)
(with-http-body (req ent)
(html
(:html
(:head (:title "AllegroServe Proxy Cache Statistics"))
(:body
(:h1 "AllegroServe Proxy Cache Statistics")
:p
"Show " ((:a :href "cache-entries") "Cache Entries,")
" Refresh " ((:a :href "cache-stats") "this page")
:br
"Perform a " ((:a :href "cache-entries-gc") "normal gc,")
" Perform a " ((:a :href "cache-entries-global-gc") "global gc")
:br
((:table :border 2)
(:tr
(:th "Cache Action")
(:th "Count"))
(dolist (ent
'(("direct" pcache-r-direct)
("miss (user request)" pcache-r-miss)
("miss (anticipated request)" pcache-r-cache-fill)
("consistency miss" pcache-r-consistency-miss)
("fast hit" pcache-r-fast-hit)
("fast validation" pcache-r-fast-validation)
("slow validation" pcache-r-slow-validation)))
(html
(:tr
(:td (:princ (car ent)))
(:td (:princ (funcall (cadr ent) pcache)))))))
:br
;; info on connection caching
"Connection caching is "
(:princ (if* *connection-caching*
then "enabled"
else "diabled"))
:br
((:table :border 2)
(:tr
(:td "make-socket calls") (:td (:princ *connections-made*)))
(:tr
(:td "connections cached") (:td (:princ *connections-cached*)))
(:tr
(:td "cached connections used")
(:td (:princ *connections-used-cached*))))
:br
((:table :border 2)
(:tr
(:th "Kind of Entry")
(:th "Count")
(:th "Bytes")
(:th "Blocks"))
(:tr
(:td "Live entries in memory")
(:td (:princ (queueobj-items (pcache-queueobj pcache)))
(:td (:princ (queueobj-bytes (pcache-queueobj pcache))))
(:td (:princ (queueobj-blocks (pcache-queueobj pcache)))
" ("
(:princ (* (queueobj-blocks (pcache-queueobj pcache))
*header-block-size*))
" bytes)")))
(:tr
(:td "Dead entries in memory")
(:td (:princ (pcache-dead-items pcache)))
(:td (:princ dead-bytes))
(:td (:princ dead-blocks)
" ("
(:princ (* dead-blocks *header-block-size*)) " bytes)"
))
)
:br
"Memory Cache"
((:table :border 2)
(:tr
(:th "items")
(:th "used-blocks/total-blocks")
(:th "bytes")
)
(let ((queueobj (pcache-queueobj pcache)))
(html (:tr
(:td (:princ-safe (queueobj-items queueobj)))
(:td (:princ-safe (queueobj-blocks queueobj))
"/"
(:princ-safe (pcache-size pcache)))
(:td (:princ-safe (queueobj-bytes queueobj)))))))
:br
:br
"Disk Caches"
:br
((:table :border 2)
(:tr
(:th "filename")
(:th "items")
(:th "blocks")
(:th "bytes")
(:th "free blocks")
(:th "free list")
)
(dolist (pcache-disk (pcache-disk-caches pcache))
(let ((queueobj (pcache-disk-queueobj pcache-disk)))
(html (:tr
(:td (:princ-safe (pcache-disk-filename pcache-disk)))
(:td (:princ-safe (queueobj-items queueobj)))
(:td (:princ-safe (queueobj-blocks queueobj)))
(:td (:princ-safe (queueobj-bytes queueobj)))
(:td (:princ-safe (pcache-disk-free-blocks
pcache-disk)))
(:td (:princ-safe (pcache-disk-free-list
pcache-disk))))))))
:br
"Current memory usage"
:br
(:pre (:princ-safe (with-output-to-string (*standard-output*)
(room t))))
)))))))
(defun display-proxy-cache-entries (req ent pcache)
;; show all the proxy cache entries
(let ((now (get-universal-time)))
(flet ((display-pcache-ent (ent)
(html (:b "uri: ")
(:princ-safe (pcache-ent-key ent))
:br
(if* (>= now (pcache-ent-expires ent))
then (html (:b ((:font :color "red")
"Stale -- ")))
else (html (:b ((:font :color "green")
"Fresh -- "))))
(:b "Expires: ")
(:princ-safe
(universal-time-to-date (pcache-ent-expires ent)))
:br
(:b "Last Modified: ")
(:princ-safe
(universal-time-to-date (pcache-ent-last-modified ent)))
:br
(:b "Size: ")
(:princ (pcache-ent-data-length ent))
(:b ", State: ")
(:princ-safe (pcache-ent-state ent))
(:b ", Use: ")
(:princ-safe (pcache-ent-use ent))
(:b ", Code: ")
(:princ-safe (pcache-ent-code ent))
(if* (pcache-ent-disk-location ent)
then (html :br
(:b "Disk Location: "
(:princ-safe
(pcache-ent-disk-location ent)))))
:p
:br
)
))
(with-http-response (req ent)
(with-http-body (req ent)
(html
(:html
(:head (:title "Proxy Cache Entries"))
(:body
(:h1 "Proxy cache entries")
:p
"Here is a summary of " ((:a :href "cache-stats") "Cache Statistics.")
:br
"The current time is " (:princ-safe (universal-time-to-date now))
:br
:br
(let ((ent (pcache-ent-next (queueobj-mru
(pcache-queueobj pcache))))
(last-ent (queueobj-lru (pcache-queueobj pcache))))
(loop
(if* (or (null ent) (eq last-ent ent)) then (return))
(display-pcache-ent ent)
(setq ent (pcache-ent-next ent))))
; now display the disk caches
(dolist (pcache-disk (pcache-disk-caches pcache))
(html :hr
:br
"Disk Cache: " (:princ-safe (pcache-disk-filename pcache-disk))
:br
"Free blocks: " (:princ-safe
(pcache-disk-free-blocks pcache-disk))
:br
"Free list: " (:princ-safe
(pcache-disk-free-list pcache-disk))
:br
:br)
; display the entries
(do ((ent (pcache-ent-next (queueobj-mru
(pcache-disk-queueobj pcache-disk)))
(pcache-ent-next ent)))
((or (null ent)
(null (pcache-ent-key ent))))
(display-pcache-ent ent)))
))))))))
#+ignore
(defun verify-memory-cache (tag)
;; verify that all memory cache items are not on the free list too
(let ((pcache (wserver-pcache *wserver*)))
(let ((ent (pcache-ent-next (queueobj-mru
(pcache-queueobj pcache))))
(last-ent (queueobj-lru (pcache-queueobj pcache))))
(loop
(if* (or (null ent) (eq last-ent ent)) then (return))
;; test to see if block are on the free list
(setq *bug* ent)
(dolist (db (pcache-ent-data ent))
(chk-header-block db tag))
(setq ent (pcache-ent-next ent))))
))
; was 'proxy-cache-request'
(defun check-cache-then-proxy-request (req ent respond level)
;; if we've got a proxy cache then retrieve it from there
;; else just proxy the request
;; respond is true if we really want to respond, it will be
;; nil if we just want to ensure that what we need is in the cache
;;
(let ((pcache (wserver-pcache *wserver*))
(rendered-uri))
(if* (or (null pcache)
; should handle :head requests too
(not (eq (request-method req) :get))
; don't look in cache if request has cookies
(and (header-slot-value req :authorization)
(progn
(logmess "authorization forces direct")
t))
)
then (if* pcache then (incf (pcache-r-direct pcache)))
(return-from check-cache-then-proxy-request
(proxy-request req ent :respond respond)))
; clear out the fragment part (after the #) so that we don't match
; on that.
(setf (net.uri:uri-fragment (request-raw-uri req)) nil)
(setq rendered-uri
(transform-uri (net.uri:render-uri (request-raw-uri req) nil)))
(dlogmess (format nil "cache: look in cache for ~a, level ~d, ents ~d~%"
rendered-uri
level
(length (gethash rendered-uri (pcache-table pcache)))
))
(dolist (pcache-ent (gethash rendered-uri (pcache-table pcache))
; not found, must proxy and then cache if the
; result looks good
(progn
(dlogmess (format nil "not in cache, proxy it level ~d" level))
(if* (eql *browser-level* level)
then (incf (pcache-r-miss pcache))
(log-proxy rendered-uri level :mi nil)
else (incf (pcache-r-cache-fill pcache))
(log-proxy rendered-uri level :pf nil))
(proxy-and-cache-request req ent (get-universal-time)
nil respond level)))
(if* (lock-pcache-ent pcache-ent)
then (unwind-protect
(if* (equal (pcache-ent-cookie pcache-ent)
(header-slot-value req :cookie))
then ; can use this one
(multiple-value-bind (response new-pcache-ent)
(use-value-from-cache req ent pcache-ent
level respond)
; run hook only if we're at the browser level
; (since this will allow us to flush the queue)
; of if this wasn't a fast hit and thus there
; is new data to cache
(if* (and (pcache-entry-cached-hook pcache)
(or (eql level *browser-level*)
(not (member response '(:fh :fv :sh)
:test #'eq))))
then ; we want to do link scanning of this
(if* (null new-pcache-ent)
then (setq new-pcache-ent
pcache-ent))
(if* (lock-pcache-ent new-pcache-ent)
then ; it will be unlocked by the hook fcn
(funcall (pcache-entry-cached-hook pcache)
pcache
new-pcache-ent level))))
(return)
else (dlogmess
(format nil "can't use cached ~s due to cookie difference~%"
rendered-uri))
(dlogmess (format nil
"cached cookie ~s~%, current cookie: ~s~%"
(pcache-ent-cookie pcache-ent)
(header-slot-value req :cookie))))
(unlock-pcache-ent pcache-ent))
else (logmess "entry could not be locked~%")))))
(defun proxy-and-cache-request (req ent now pcache-ent respond level)
;; must send the request to the net via the proxy.
;; if pcache-ent is non-nil then this is the existing
;; cache entry which may get updated or killed.
;;
;; return the reponse code from the proxy call
;; return the new pcache-ent that got the new value if the return
;; code is 200 or 302
;;
;;
(let ((new-ent (make-pcache-ent))
(rendered-uri
(transform-uri (net.uri:render-uri (request-raw-uri req) nil)))
(pcache (wserver-pcache *wserver*)))
(setf (pcache-ent-key new-ent) rendered-uri
(pcache-ent-uri new-ent) (request-raw-uri req))
(proxy-request req ent :pcache-ent new-ent :respond respond :level level)
(if* (member (pcache-ent-code new-ent) '(200
302 ; redirect
))
then ; turns out it was modified, must
; make this the new entry
(if* pcache-ent
then (dlogmess (format nil "replace cache entry for ~a"
rendered-uri)))
(push new-ent
(gethash rendered-uri
(pcache-table pcache)))
; put at the head of the memory queue
; could already be dead from some other threads o
; be careful
(if* (lock-pcache-ent new-ent)
then (if* (not (eq (pcache-ent-state new-ent) :dead))
then (move-pcache-ent new-ent nil
(pcache-queueobj pcache)))
(unlock-pcache-ent new-ent))
; and disable the old entry
(if* pcache-ent
then (kill-pcache-ent pcache-ent pcache))
elseif (and pcache-ent
(eq (pcache-ent-code new-ent) 304))
then ; still not modified, recompute the
; expiration time since we now know
; that the item is older
;* this may end up violation the expiration
; time in a header from a previous call
(dlogmess (format nil "change expiration date for ~a"
rendered-uri))
(setf (pcache-ent-expires pcache-ent)
(max (pcache-ent-expires pcache-ent)
(compute-approx-expiration
(pcache-ent-last-modified pcache-ent)
now))))
(values (pcache-ent-code new-ent) new-ent)))
(defun use-value-from-cache (req ent pcache-ent level respond)
;; we've determined that pcache-ent matches the request.
;; now deal with the issue of it possibily being out of date
;;
;; return a keyword specifying the kind of access that was
;; done
;;
(let* ((ims (header-slot-value req :if-modified-since))
(now (get-universal-time))
(pcache (wserver-pcache *wserver*))
(fresh))
(most-recently-used-ent pcache-ent)
(dlogmess (format nil "ims is ~s" ims))
; compute if the entry is fresh or stale
(setq fresh (<= now (pcache-ent-expires pcache-ent)))
(dlogmess (format nil "ims is ~s, fresh by ~s seconds" ims
(- (pcache-ent-expires pcache-ent) now)))
(if* (and ims (not (equal "" ims)))
then ; we're in a conditional get situation, where the
; condition is If-Modified-Since
(setq ims (date-to-universal-time ims))
(if* fresh
then (if* (< ims (pcache-ent-last-modified pcache-ent))
then ; it has been modified since the ims time
; must return the whole thing
(dlogmess "validation->fast hit")
(incf (pcache-r-fast-hit pcache))
(if* respond
then (send-cached-response req pcache-ent))
(log-proxy (pcache-ent-key pcache-ent)
level
:fh
(- (pcache-ent-last-modified pcache-ent)
ims))
:fh
else ; it hasn't been modified since the ims time
(dlogmess "fast validation")
(incf (pcache-r-fast-validation pcache))
(if* respond
then (send-not-modified-response req ent))
(log-proxy (pcache-ent-key pcache-ent)
level
:fv
(- (pcache-ent-last-modified pcache-ent)
ims))
:fv
)
else ; stale, must revalidate
(let ((code
(proxy-and-cache-request req ent
now pcache-ent respond
level)))
(if* (eql code 304)
then (dlogmess "slow validation")
(incf (pcache-r-slow-validation pcache))
(log-proxy (pcache-ent-key pcache-ent)
level
:sv
(- (pcache-ent-last-modified pcache-ent)
ims))
:sv
else (dlogmess "consistency miss")
(incf (pcache-r-consistency-miss
pcache))
(log-proxy (pcache-ent-key pcache-ent)
level
:cm
(- (pcache-ent-last-modified pcache-ent)
ims))
:cm
)))
else ; unconditional get
(if* fresh
then (dlogmess "fast hit")
(incf (pcache-r-fast-hit pcache))
(if* respond then (send-cached-response req pcache-ent))
(log-proxy (pcache-ent-key pcache-ent)
level
:fh
nil)
:fh
else ; issue a validating send
(insert-header
(request-header-block req)
:if-modified-since
(or (pcache-ent-last-modified-string pcache-ent)
(setf (pcache-ent-last-modified-string pcache-ent)
(universal-time-to-date
(pcache-ent-last-modified pcache-ent)))))
(multiple-value-bind (code new-pcache-ent)
(proxy-and-cache-request req ent now pcache-ent nil
-1)
; we didn't respond just sent out a probe
(multiple-value-prog1
(if* (eql code 304)
then ; hasn't been modified since our
; cached entry
(dlogmess "slow hit")
(incf (pcache-r-slow-hit pcache))
(log-proxy (pcache-ent-key pcache-ent)
level
:sh
nil)
:sh
else ; was modified, so new item is cached
(setq pcache-ent new-pcache-ent)
(dlogmess "consistency miss")
(incf (pcache-r-consistency-miss pcache))
(log-proxy (pcache-ent-key pcache-ent)
level
:cm
nil)
(values :cm pcache-ent)
)
(if* respond
then (send-cached-response req pcache-ent))))))))
(defun compute-approx-expiration (changed now)
;; compute the expires time based on the last time the file was
;; change and current time.
(let ((delta (max 1 (ceiling
(* (- now changed) *extra-lifetime-factor*)))))
(+ changed delta)))
(defun send-not-modified-response (req ent)
;; return a not-modified response
(with-http-response (req ent :response *response-not-modified*)
(with-http-body (req ent))))
(defun send-cached-response (req pcache-ent)
;; send back this response
(dlogmess (format nil "cache: sending back cached response: ~a, length ~d~%"
(net.uri:render-uri (request-raw-uri req) nil)
(pcache-ent-data-length pcache-ent)))
(incf (pcache-ent-returned pcache-ent))
(if* (pcache-ent-disk-location pcache-ent)
then (retrieve-pcache-from-disk pcache-ent))
(let ((rsock (request-socket req)))
(format rsock "HTTP/1.1 ~d ~a~a"
(pcache-ent-code pcache-ent)
(pcache-ent-comment pcache-ent) *crlf*)
(setf (request-reply-code req) (code-to-response
(pcache-ent-code pcache-ent)))
(let ((data (pcache-ent-data pcache-ent))
(data-length (pcache-ent-data-length pcache-ent)))
(setf (request-reply-content-length req) data-length)
(write-sequence (car data) rsock
:end (add-trailing-crlf (car data) 3))
(if* data-length
then (write-body-buffers rsock (cdr data) data-length))
(force-output rsock))))
(defun lock-pcache-ent (pcache-ent)
;; attempt to increase the use count of this entry by one.
;; If successful return true.
;; If the entry is dead return nil
(with-fast-mp-locked-pcache-ent (pcache-ent)
(excl::fast
(let ((val (pcache-ent-use pcache-ent)))
(if* val
then (setf (pcache-ent-use pcache-ent)
(the fixnum (1+ (the fixnum val)))))))))
(defun unlock-pcache-ent (pcache-ent)
;; reduce the use count of this entry
(with-mp-locked-pcache-ent (pcache-ent)
(let ((val (pcache-ent-use pcache-ent)))
(if* val
then (if* (and (zerop (excl::fast
(decf (the fixnum val))))
(eq (pcache-ent-state pcache-ent) :dead))
then (setf (pcache-ent-use pcache-ent) nil)
else (setf (pcache-ent-use pcache-ent) val))))))
(defun most-recently-used-ent (pcache-ent)
;; make this entry the most recently used in whatever queue it's on
(let ((queueobj (pcache-ent-queueobj pcache-ent)))
(move-pcache-ent pcache-ent queueobj queueobj)))
#+ignore ;; fixed below for thread safety
(defun move-pcache-ent (pcache-ent fromq toq)
;; move the pcache-ent between queues
;; fromq and toq can be nil or the same.
;;
(let ((prev (pcache-ent-prev pcache-ent))
(next (pcache-ent-next pcache-ent)))
(mp:without-scheduling
; unlink
(if* (and prev next)
then (setf (pcache-ent-next prev) next
(pcache-ent-prev next) prev))
(if* (and fromq (not (eq fromq toq)))
then ; must update counts in the from queue
(decf (queueobj-items fromq))
(decf (queueobj-bytes fromq) (pcache-ent-data-length pcache-ent))
(decf (queueobj-blocks fromq)
(pcache-ent-blocks pcache-ent)))
; link into the toq, at the mru position
(if* toq
then ;debugging
(if* (eq (pcache-ent-state pcache-ent) :dead)
then (break "shouldn't be dead during move"))
(let* ((mru-head (queueobj-mru toq))
(mru (pcache-ent-next mru-head)))
(setf (pcache-ent-next mru-head) pcache-ent
(pcache-ent-prev pcache-ent) mru-head
(pcache-ent-next pcache-ent) mru
(pcache-ent-prev mru) pcache-ent))
(if* (not (eq fromq toq))
then ; increment counts
(incf (queueobj-items toq))
(incf (queueobj-bytes toq)
(pcache-ent-data-length pcache-ent))
(incf (queueobj-blocks toq)
(pcache-ent-blocks pcache-ent))))
(setf (pcache-ent-queueobj pcache-ent) toq))))
;; This is the new version, fixed for thread safety
(defun move-pcache-ent (pcache-ent fromq toq)
;; move the pcache-ent between queues
;; fromq and toq can be nil or the same.
;;
;; to handle errors detected inside a locked block, we
;; set up a flag that we can check after leaving the locked code
(let ((error-flag nil))
(if* (eq fromq toq)
then ;; just shifting it to the head of the queue it's in
(if* (null fromq)
then (setq error-flag :noqueue)
elseif (eq (pcache-ent-state pcache-ent) :dead) ; debugging
then (setq error-flag :dead)
else (with-mp-locked-pcache-queue (fromq)
(let* ((prev (pcache-ent-prev pcache-ent))
(next (pcache-ent-next pcache-ent))
(mru-head (queueobj-mru toq))
(mru (pcache-ent-next mru-head)))
;; unlink and relink, or report error
(if* (or (null prev) (null next))
then (setq error-flag :unlinked)
else (setf (pcache-ent-next prev) next
(pcache-ent-prev next) prev
(pcache-ent-next mru-head) pcache-ent
(pcache-ent-prev pcache-ent) mru-head
(pcache-ent-next pcache-ent) mru
(pcache-ent-prev mru) pcache-ent)))))
else ;; toq != fromq; we're changing one or more queue counts
(when fromq
;; it's leaving the queue fromq
(with-mp-locked-pcache-queue (fromq)
(let ((prev (pcache-ent-prev pcache-ent))
(next (pcache-ent-next pcache-ent)))
;; unlink
(if* (or (null prev) (null next))
then (setq error-flag :unlinked)
else (setf (pcache-ent-next prev) next
(pcache-ent-prev next) prev)
(decf (queueobj-items fromq))
(decf (queueobj-bytes fromq)
(pcache-ent-data-length pcache-ent))
(decf (queueobj-blocks fromq)
(pcache-ent-blocks pcache-ent))))))
(when (and (null error-flag) toq)
;; link into the toq, at the mru position
(if* (eq (pcache-ent-state pcache-ent) :dead)
then (setq error-flag :dead)
else (with-mp-locked-pcache-queue (toq)
(let* ((mru-head (queueobj-mru toq))
(mru (pcache-ent-next mru-head)))
(setf (pcache-ent-next mru-head) pcache-ent
(pcache-ent-prev pcache-ent) mru-head
(pcache-ent-next pcache-ent) mru
(pcache-ent-prev mru) pcache-ent))
(incf (queueobj-items toq))
(incf (queueobj-bytes toq)
(pcache-ent-data-length pcache-ent))
(incf (queueobj-blocks toq)
(pcache-ent-blocks pcache-ent)))))
(if* (null error-flag)
then (setf (pcache-ent-queueobj pcache-ent) toq)))
;; we've either made changes or set error-flag non-nil
(case error-flag
(:noqueue
(error "attempt to move a pcache-ent without specifying a queue"))
(:dead (break "shouldn't be dead during move"))
(:unlinked
(error "attempt to shift an unlinked pcache-ent")))))
(defun kill-pcache-ent (pcache-ent &optional (pcache (wserver-pcache
*wserver*)))
; make this entry dead
(with-mp-locked-pcache (pcache)
; stop any scanning of this uri
(setf (pcache-ent-level pcache-ent) -1)
(let ((state (pcache-ent-state pcache-ent)))
(if* (not (eq :dead state))
then ; make it dead
(setf (pcache-ent-state pcache-ent) :dead)
(move-pcache-ent pcache-ent
(pcache-ent-queueobj pcache-ent)
nil ; move to nowhere,
)
; link onto the dead list
(setf (pcache-ent-next pcache-ent) (pcache-dead-ent pcache)
(pcache-dead-ent pcache) pcache-ent)
; if currently not in use, then make sure it's never used
(if* (eql 0 (pcache-ent-use pcache-ent))
then (setf (pcache-ent-use pcache-ent) nil))
;; stats
(incf (pcache-dead-items pcache))
; remove from hash table
(let ((ents (gethash (pcache-ent-key pcache-ent)
(pcache-table pcache))))
(setf (gethash (pcache-ent-key pcache-ent)
(pcache-table pcache))
(delete pcache-ent ents :test #'eq)))
))))
#+ignore
(defun match-request-blocks (request-block cache-block)
;; compare the header entries that have to match for this
;; cached request to be used.
;;
(if* (eq request-block cache-block)
then (error "block reused when it shouldn't have"))
(let ((hcma *header-cache-match-array*))
(dotimes (i (length hcma) t)
(let ((ent (svref hcma i)))
(if* ent
then (if* (not (header-match-values request-block
cache-block
i
(eq ent :mx)))
then ; give up
(return nil)))))))
(defun cache-response (req pcache-ent
response-code comment client-response-header
body-buffers body-length level)
;; we are caching, save the information about this response
;; in the pcache-ent we are passed, which should be blank
(dlogmess (format nil "cache: caching response to ~a, code ~d, length ~d~%"
(net.uri:render-uri (request-raw-uri req) nil)
response-code
body-length
))
(let (now uri-info
(pcache (wserver-pcache *wserver*)))
(if* (or (eql response-code 200)
(eql response-code 302) ; redirect
)
then ; full response
(setf (pcache-ent-code pcache-ent) response-code)
(setf (pcache-ent-comment pcache-ent) comment)
(setf (pcache-ent-data pcache-ent)
(cons client-response-header body-buffers))
(setf (pcache-ent-data-length pcache-ent) body-length
(pcache-ent-blocks pcache-ent)
(length (pcache-ent-data pcache-ent)))
(setf (pcache-ent-cookie pcache-ent)
(header-slot-value req :cookie))
(setf (pcache-ent-state pcache-ent) nil ; means valid data
(pcache-ent-use pcache-ent) 0)
(setq uri-info (find-uri-info (request-raw-uri req)))
(if* uri-info
then (dlogmess (format nil "have uri info for ~a"
(request-raw-uri req))))
(let* ((last-mod (header-buffer-header-value
client-response-header
:last-modified))
(last-mod-val (and last-mod
(date-to-universal-time last-mod)))
(expires (header-buffer-header-value
client-response-header
:expires))
(expires-val (and expires
(date-to-universal-time expires))))
(setq client-response-header nil
body-buffers nil)
(if* last-mod-val
then (setf (pcache-ent-last-modified-string pcache-ent) last-mod
(pcache-ent-last-modified pcache-ent) last-mod-val)
else ; no value given, store current time minus a
; second to account for the transit time
(setf (pcache-ent-last-modified pcache-ent)
(- (setq now (get-universal-time)) 2)))
(if* expires-val
then ; given expiration date, use it
;* it may be bogus since people doing ads use this
; to force cache reloads
(setf (pcache-ent-expires pcache-ent) expires-val)
else ; must compute expiration
(setf (pcache-ent-expires pcache-ent)
(compute-approx-expiration
(pcache-ent-last-modified pcache-ent)
(or now (get-universal-time)))))
;; add extra lifetime for certain entries
(incf (pcache-ent-expires pcache-ent)
(if* (and uri-info (uri-info-extra-lifetime uri-info))
then (uri-info-extra-lifetime uri-info)
else *extra-lifetime*))
(if* (pcache-entry-cached-hook pcache)
then (if* (lock-pcache-ent pcache-ent)
then ; it will be unlocked by the hook fcn
(funcall (pcache-entry-cached-hook pcache)
pcache pcache-ent level))))
elseif (eql response-code 304)
then ; just set that so the reader of the response will know
; the result
(setf (pcache-ent-code pcache-ent) response-code))
(if* client-response-header
then (free-header-block client-response-header))
(if* body-buffers
then (free-header-blocks body-buffers))))
; --- cleaning out old entries
(defun cache-housekeeping (&optional (pcache (wserver-pcache *wserver*)))
;; bring all the caches to within the appropriate tolerance
; first clean out disk caches so we can put more memory stuff in them
(dolist (pcache-disk (pcache-disk-caches pcache))
(if* (> (- (pcache-disk-blocks pcache-disk)
(pcache-disk-free-blocks pcache-disk))
(pcache-disk-high-water pcache-disk))
then ; must flush it
(flush-disk-cache pcache
pcache-disk
(pcache-disk-low-water pcache-disk))))
; clear out all entries made dead
(flush-dead-entries pcache)
; now clean out the memory cache if needed by moving to a disk cache
(if* (> (queueobj-blocks (pcache-queueobj pcache))
(pcache-high-water pcache))
then (flush-memory-cache pcache
(pcache-low-water pcache)))
; now rotate caches so they are evenly used
(let ((caches (pcache-disk-caches pcache)))
(if* (cdr caches)
then (let ((new (cdr caches)))
(setf (cdr caches) nil)
(nconc new caches)
(setf (pcache-disk-caches pcache) new)))))
(defun flush-disk-cache (pcache pcache-disk goal)
;; flush entries from the disk cache until the number of blocks
;; is less than or equal to the goal
(let* ((needed (- (- (pcache-disk-blocks pcache-disk)
(pcache-disk-free-blocks pcache-disk))
goal))
(queueobj (pcache-disk-queueobj pcache-disk))
(mru-head (queueobj-mru queueobj))
(lru-head (queueobj-lru queueobj)))
(loop
(if* (<= needed 0)
then (return))
; pick off the lru and kill it
(mp::with-process-lock ((pcache-disk-lock pcache-disk))
(let ((lru (pcache-ent-prev lru-head)))
(if* (not (eq lru mru-head))
then ; a legit block
(dlogmess (format nil "kill ~s from disk queue"
(pcache-ent-key lru)))
(decf needed (pcache-ent-blocks lru))
(kill-pcache-ent lru pcache)
(log-proxy (pcache-ent-key lru) 0 :kd nil)
else (return) ; no more left ? shouldn't happen
))))))
(defun flush-memory-cache (pcache goal)
;; move memory cache items to a disk cache if possible
(if* (null pcache)
then (setq pcache (wserver-pcache *wserver*)))
(let* ((needed (- (queueobj-blocks (pcache-queueobj pcache))
goal))
(queueobj (pcache-queueobj pcache))
(mru-head (queueobj-mru queueobj))
(lru-head (queueobj-lru queueobj))
(disk-caches (pcache-disk-caches pcache))
(ent-todo)
)
(loop
(if* (<= needed 0) then (return))
#+ignore ;; recoded below
(block main
(setq ent-todo nil)
(mp:without-scheduling
;; find the next ent to process without other processes running
(let ((lru lru-head))
(loop
(setq lru (pcache-ent-prev lru))
(if* (eq lru mru-head)
then (setq needed 0)
(return-from main))
(if* (lock-pcache-ent lru)
then (setq ent-todo lru)
(return-from main))))))
;; this is the new version
(with-mp-locked-pcache (pcache)
(setq ent-todo nil)
(do ((lru (pcache-ent-prev lru-head) (pcache-ent-prev lru)))
((eq lru mru-head)
(setq needed 0))
(if* (lock-pcache-ent lru)
then (setq ent-todo lru)
(return))))
(if* ent-todo
then ; move this one to disk or kill it off
(if* (dolist (dc disk-caches t)
(if* (move-ent-to-disk ent-todo dc)
then ; successful move to disk
(decf needed (pcache-ent-blocks ent-todo))
(unlock-pcache-ent ent-todo)
(return nil)))
then ; can't put on disk. kill it in memory
(decf needed (pcache-ent-blocks ent-todo))
(kill-pcache-ent ent-todo pcache)
(unlock-pcache-ent ent-todo))))))
(defun flush-dead-entries (pcache)
;; flush all the deal items from the cache, returning
;; their resource
(let (ent)
(smp-case
(nil
(atomically-fast
(setf ent (pcache-dead-ent pcache)
(pcache-dead-ent pcache) nil)))
((t :macros)
(loop
(setq ent (pcache-dead-ent pcache))
(excl::fast
(when (atomic-conditional-setf (pcache-dead-ent pcache) nil ent)
(return))))))
; now we have an exclusive link to the dead entries
; which we can free at our leisure
(let ((count 0))
(loop
(if* (null ent) then (return))
(incf count)
(free-header-blocks (pcache-ent-data ent))
(let ((diskloc (pcache-ent-disk-location ent)))
; if stored on the disk, free those blocks
(if* diskloc
then (return-free-blocks (pcache-ent-pcache-disk ent)
diskloc)))
(setq ent (pcache-ent-next ent)))
(smp-case
(nil
(atomically-fast
(decf (the fixnum (pcache-dead-items pcache))
(the fixnum count))))
((t :macros)
(excl::fast
(decf-atomic (the fixnum (pcache-dead-items pcache))
(the fixnum count)))))
)))
(defun empty-all-caches (&key (server *wserver*))
;; remove everything from all caches
(let ((pcache (wserver-pcache server)))
(mp:with-process-lock ((pcache-cleaner-lock pcache))
(flush-dead-entries pcache)
(flush-memory-cache pcache 0) ; empty memory
(dolist (dcache (pcache-disk-caches pcache))
(flush-disk-cache pcache dcache 0)))))
;------------ disk cache
(defun move-ent-to-disk (pcache-ent pcache-disk)
;; copy the given pcache-ent to the disk
;; assume that we've locked it at this point
;;
;; return t if we suceede and nil if we didn't
;;
(if* (pcache-ent-disk-location pcache-ent)
then (dlogmess (format nil "cached ~s is already on the disk"
(pcache-ent-key pcache-ent)))
(return-from move-ent-to-disk t))
(let ((to-store-list (get-disk-cache-blocks
pcache-disk (pcache-ent-blocks pcache-ent)))
(buffs))
(if* to-store-list
then (dlogmess (format nil "store ~s on disk at ~s~%"
(pcache-ent-key pcache-ent)
to-store-list))
(store-data-on-disk pcache-ent pcache-disk to-store-list)
(log-proxy (pcache-ent-key pcache-ent) 0 :wd nil)
(let ((ans
(with-mp-locked-pcache-ent (pcache-ent)
(if* (and (null (pcache-ent-state pcache-ent))
(eql 1 (pcache-ent-use pcache-ent)))
then ; we are tre sole user of this entry so we cna
; replace the buffers with the disk location
(setf (pcache-ent-disk-location pcache-ent)
to-store-list
(pcache-ent-pcache-disk pcache-ent)
pcache-disk
buffs (pcache-ent-data pcache-ent)
(pcache-ent-data pcache-ent) nil)
; move to disk's list
(move-pcache-ent pcache-ent
(pcache-ent-queueobj pcache-ent)
(pcache-disk-queueobj
pcache-disk))
t
else ; someone started using the entry.. so forget we
; wrote it
(logmess
(format nil "can't complete store: use ~d, state ~s~%"
(pcache-ent-use pcache-ent)
(pcache-ent-state pcache-ent)))
(return-free-blocks pcache-disk to-store-list)
nil))))
(free-header-blocks buffs)
ans))))
(defun ensure-pcache-in-memory (pcache-ent)
(smp-case
(t
(with-locked-structure (pcache-ent)
(if* (pcache-ent-disk-location pcache-ent)
then (retrieve-pcache-from-disk pcache-ent))))
((nil :macros)
(if* (pcache-ent-disk-location pcache-ent)
then (retrieve-pcache-from-disk pcache-ent)))))
(defun retrieve-pcache-from-disk (pcache-ent)
;; read the cache entry back in from the disk
;; This is now called with the pcache-ent locked in smp lisps,
;; so the flagval test isn't needed in smp at all
; ensure the loading flag to true and set flagval
; to the value before we set the flag.
; If the value was nil and thus we set it to true, then
; we are the process responsible for loading in the data
;
#-smp
(let ((flagval (atomically-fast
(let ((val (pcache-ent-loading-flag pcache-ent)))
(if* (null val)
then (setf (pcache-ent-loading-flag pcache-ent) t))
val))))
(if* flagval
then (mp:process-wait "cache entry to be loaded"
#'(lambda (pcache-ent)
(null (pcache-ent-loading-flag pcache-ent)))
pcache-ent)
(return-from retrieve-pcache-from-disk))
)
;; it's our job to load in the entry
(let* ((block-list (pcache-ent-disk-location pcache-ent))
(pcache-disk (pcache-ent-pcache-disk pcache-ent))
(stream (pcache-disk-stream pcache-disk))
(bytes (+ (pcache-ent-data-length pcache-ent)
*header-block-size*))
(res))
(dlogmess (format nil "retrieve ~s in blocks ~s~%"
(pcache-ent-key pcache-ent)
block-list))
(log-proxy (pcache-ent-key pcache-ent) 0 :rd nil)
(mp:with-process-lock ((pcache-disk-lock pcache-disk))
;; get a lock so we're the only thread doing operations
;; on the stream to the cache
(dolist (ent block-list)
(file-position stream (* (car ent) *header-block-size*))
(dotimes (i (1+ (- (cdr ent) (car ent))))
(let ((buff (get-header-block)))
(read-sequence buff stream :end (min *header-block-size*
bytes))
(decf bytes *header-block-size*)
(push buff res))))
(setf (pcache-ent-data pcache-ent) (nreverse res))
(return-free-blocks pcache-disk block-list)
;; insert in the memory ru list
(most-recently-used-ent pcache-ent)
;; insert in memory
(atomically-fast
(setf (pcache-ent-disk-location pcache-ent) nil
(pcache-ent-pcache-disk pcache-ent) nil
(pcache-ent-loading-flag pcache-ent) nil)))))
(defun get-disk-cache-blocks (pcache-disk count)
;; return the location of count cache blocks
(mp:with-process-lock ((pcache-disk-lock pcache-disk))
(let ((free (pcache-disk-free-blocks pcache-disk)))
(decf free count)
(if* (>= free 0)
then (setf (pcache-disk-free-blocks pcache-disk) free)
; now find that many blocks
(let ((free-list (pcache-disk-free-list pcache-disk))
(toret))
(loop
(let ((ent (car free-list)))
(if* (null ent)
then ; should not have run out.. this is bad
(return-from get-disk-cache-blocks nil)
else (let ((amt (1+ (- (cdr ent) (car ent)))))
(if* (< amt count)
then ; need this and more
(push ent toret)
(decf count amt)
(pop free-list)
elseif (eql amt count)
; perfect
then (push ent toret)
(pop free-list)
(return)
else ; too many, take what we need
(push (cons (car ent)
(+ (car ent)
count
-1))
toret)
(incf (car ent) count)
(return))))))
(setf (pcache-disk-free-list pcache-disk) free-list)
toret)))))
(defun return-free-blocks (pcache-disk list-of-blocks)
;; return the given blocks to the free list
;; list of block is a list of conses (start . end)
;; and we must insert them in the free list which has the
;; same form, and we want to merge blocks too.
(mp:with-process-lock ((pcache-disk-lock pcache-disk))
(let ((giveback 0)
(free-list (pcache-disk-free-list pcache-disk)))
(dolist (ent list-of-blocks)
(incf giveback (1+ (- (cdr ent) (car ent))))
(do ((prev nil cur)
(cur free-list (cdr cur)))
((null cur)
; add at end of the line
(if* prev
then (setf (cdr prev) (list ent))
else ; only thing
(setq free-list (list ent))))
(if* (< (cdr ent) (caar cur))
then ; fit it in between prev and cur
; we know that it's not adjacent to the previous entry
; see if adjacent to this cur entry
(if* (eql (1+ (cdr ent)) (caar cur))
then ; adjacent, just adjust that one
(setf (caar cur) (car ent))
else ; not adjacent, link it in
(if* prev
then (setf (cdr prev) (cons ent cur))
else (setq free-list
(cons ent cur))))
(return)
elseif (eql (1+ (cdar cur)) (car ent))
then ; is adjacent at the right end to cur
(setf (cdar cur) (cdr ent))
; see if cur now joins with the one after cur
(setq prev cur
cur (cdr prev))
(if* (and cur (eql (1+ (cdar prev)) (caar cur)))
then ; it does
(setf (cdar prev) (cdar cur))
(setf (cdr prev) (cdr cur)))
(return))))
(setf (pcache-disk-free-list pcache-disk) free-list)
(incf (pcache-disk-free-blocks pcache-disk) giveback))))
(defun store-data-on-disk (pcache-ent pcache-disk list-of-blocks)
;; store the data in the pcache-ent to the disk using
;; the blocks in list-of-blocks (list of cons format)
;;
(let ((buffers (pcache-ent-data pcache-ent))
(stream (pcache-disk-stream pcache-disk))
(bytes (+ *header-block-size* ; for header block
(pcache-ent-data-length pcache-ent))))
(dlogmess (format nil "writing ~d buffers to list ~d~%"
(length buffers)
list-of-blocks))
(dolist (ent list-of-blocks)
; prepare to write
(file-position stream (* (car ent) *header-block-size*))
(dotimes (i (1+ (- (cdr ent) (car ent))))
(if* (null buffers)
then (error "ran out of buffers before blocks"))
(let ((length (min *header-block-size* bytes)))
(if* (> length 0)
then (write-sequence (car buffers) stream :end length)))
(pop buffers)
(decf bytes *header-block-size*)))))
;--- end disk cache
;--- uri transforms
(defparameter *uri-transforms*
;; list of functions that take a string and if they make a change
;; return a string (else they return nil)
nil)
(defun transform-uri (string)
;; transform the string
(let (ans)
(dolist (tr *uri-transforms* string)
(if* (setq ans (funcall tr string))
then (return ans)))))
; define sample transform
(defun add-transform (function)
(pushnew function *uri-transforms*))
;--- specification of uri handling by proxy
(defun handle-uri (host path
&key (server *wserver*)
(extra-lifetime nil el-p)
(scan-depth nil sd-p)
(exclude nil ex-p)
(scan-function nil sf-p)
(offsite t ofs-p)
)
;; store info about how to handle this uri during the scan
;; host can be "foo.com" or "foo.com:8000"
;;
(let ((pcache (wserver-pcache server))
(table)
(uri-info)
(ahost)
(aport)
)
(if* (null pcache) then (error "proxying isn't enabled"))
(setq table (pcache-uri-info-table pcache))
(multiple-value-setq (ahost aport) (get-host-port host))
(if* (null ahost)
then (error "bad form for the host:port ~s" host))
(dolist (ent (gethash ahost table))
(if* (and (equal path (uri-info-path ent))
(eql aport (uri-info-port ent)))
then (return (setq uri-info ent))))
(if* (null uri-info)
then ; add new one
(setq uri-info (make-uri-info
:host ahost
:port aport
:offsite offsite
:path path
:path-regexp (if* path
then (compile-regexp path))))
(push uri-info (gethash ahost table)))
; set fields
(if* el-p
then (setf (uri-info-extra-lifetime uri-info) extra-lifetime))
(if* sd-p
then (setf (uri-info-scan-depth uri-info) scan-depth))
(if* ex-p
then (if* (and exclude
(not (consp exclude)))
then (setq exclude (list exclude)))
(setf (uri-info-exclude uri-info) exclude
(uri-info-exclude-regexp uri-info) (mapcar #'compile-regexp exclude))
)
(if* sf-p
then (setf (uri-info-scan-function uri-info) scan-function))
(if* ofs-p
then (setf (uri-info-offsite uri-info) offsite))
uri-info))
(defmethod find-uri-info ((uri net.uri:uri))
;; locate the uri-info corresponding to this uri, if
;; there is one
(let ((pcache (wserver-pcache *wserver*))
(path (net.uri:uri-path uri))
(host (net.uri:uri-host uri))
(port (or (net.uri:uri-port uri) 80)))
(if* pcache
then (dolist (ent (gethash host (pcache-uri-info-table pcache)))
(if* (eql port (uri-info-port ent))
then
(let ((pregexp (uri-info-path-regexp ent)))
(if* (null pregexp)
then ; matches everything
(return ent)
elseif (match-regexp pregexp path :return nil)
then (return ent))))))))
;-------- state save/restore
; items to save
; pcache (wserver-pcache)
;
; structures needing saving
(defmethod make-load-form ((obj pcache) &optional env)
(make-load-form-saving-slots obj :environment env))
(defmethod make-load-form ((obj pcache-disk) &optional env)
(make-load-form-saving-slots obj :environment env))
(defmethod make-load-form ((obj pcache-ent) &optional env)
(make-load-form-saving-slots obj :environment env))
(defmethod make-load-form ((obj queueobj) &optional env)
(make-load-form-saving-slots obj :environment env))
(without-package-locks
(defmethod make-load-form ((obj mp:process-lock) &optional env)
(make-load-form-saving-slots obj :environment env))
; this is just temporary until we get a patch for this in uri.fasl
(defmethod make-load-form ((self net.uri:uri) &optional env)
(declare (ignore env))
`(make-instance ',(class-name (class-of self))
:scheme ,(uri-scheme self)
:host ,(uri-host self)
:port ,(uri-port self)
:path ',(uri-path self)
:query ,(uri-query self)
:fragment ,(uri-fragment self)
:plist ',(uri-plist self)
:string ,(net.uri::uri-string self)
; bug is missing ' in parsed-path value
:parsed-path ',(net.uri::.uri-parsed-path self)))
)
(defun save-proxy-cache (filename &key (server *wserver*))
;; after the server threads have been saved, this function can
;; be called to save out the state of the proxy cache
; prepare to save by removing objects that can't be saved
(let ((pcache (wserver-pcache server)))
(if* (null pcache)
then (return-from save-proxy-cache nil))
(setf (pcache-cleaner pcache) nil)
; don't save the hash table since we can recreate it as since
; saving it is very expensive due to the fasl-circle check
(setf (pcache-table pcache) nil)
(dolist (pcache-disk (pcache-disk-caches pcache))
; for each disk cache
(ignore-errors (close (pcache-disk-stream pcache-disk)))
(setf (pcache-disk-stream pcache-disk) nil)))
(with-open-file (p filename :direction :output :if-exists :supersede)
(fasl-write (wserver-pcache server) p t))
(setf (wserver-pcache server) nil))
(defun restore-proxy-cache (filename &key (server *wserver*))
(let ((pcache (car (fasl-read filename))))
(if* (not (typep pcache 'pcache))
then (error "file didn't contain a saved cache"))
(dolist (pcache-disk (pcache-disk-caches pcache))
; open each cache
(let ((filename (pcache-disk-filename pcache-disk)))
(setf (pcache-disk-stream pcache-disk)
(open filename
:if-exists :overwrite
:if-does-not-exist :error
:direction :io
#-(and allegro (version>= 6))
:element-type
#-(and allegro (version>= 6))
'(unsigned-byte 8)))))
(setf (wserver-pcache server) pcache)
; rebuild the hash table
(let ((table (make-hash-table :size 1000 :test #'equal)))
(flet ((process-queue (table queueobj)
;; add all entries to the hash table
(let ((lru-head (queueobj-lru queueobj))
(cur (pcache-ent-next (queueobj-mru queueobj))))
(loop
(if* (eq cur lru-head) then (return))
(if* (not (eq :dead (pcache-ent-state cur)))
then (push cur
(gethash (pcache-ent-key cur)
table)))
(setq cur (pcache-ent-next cur))))))
(dolist (pcache-disk (pcache-disk-caches pcache))
(process-queue table (pcache-disk-queueobj pcache-disk)))
(process-queue table (pcache-queueobj pcache))
(setf (pcache-table pcache) table)
))
(start-proxy-cache-processes server pcache)))
;----
