Permalink
Switch branches/tags
save2011_02_16 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_2012-11-29T20-34-03 install-spider_2012-11-14T13-43-28 install-spider_2012-11-14T08-05-32 install-spider_2012-10-30T13-50-49 install-spider_2012-10-12T11-40-36 install-spider_2012-09-18T18-29-59 install-spider_2012-09-12T15-43-10 install-spider_2012-09-12T15-24-10 install-spider_2012-09-12T14-50-31 install-spider_2012-09-06T14-19-49 install-spider_2012-08-28T12-31-12 install-spider_2012-08-27T20-00-25 install-spider_2012-08-27T19-52-01 install-spider_2012-08-27T19-33-52 install-spider_2012-08-22T17-09-50 install-spider_2012-08-21T17-46-52 install-spider_2012-08-17T14-51-58 install-spider_2012-08-08T15-08-02 install-spider_2012-08-08T14-51-20 install-spider_2012-07-23T16-04-01 install-spider_2012-07-18T17-20-52 install-spider_2012-07-12T08-56-47 install-spider_2012-07-05T13-48-05 install-spider_2012-06-21T09-51-57 install-spider_2012-06-06T13-05-15 install-spider_2012-06-05T14-14-49 install-spider_2012-06-04T08-53-44 install-spider_2012-06-04T07-50-26 install-spider_2012-06-03T14-12-55 install-spider_2012-05-31T13-48-36 install-spider_2012-05-30T11-57-41 install-spider_2012-05-21T12-22-17 install-spider_2012-05-16T09-36-52 install-spider_2012-05-11T14-24-54 install-spider_2012-05-11T13-14-50 install-spider_2012-05-11T12-56-55 install-spider_2012-05-11T10-52-54 install-spider_2012-05-11T10-39-51 install-spider_2012-05-11T10-24-19 install-spider_2012-05-11T10-09-34 install-spider_2012-05-11T09-11-17 install-spider_2012-05-10T16-09-49 install-spider_2012-05-10T15-42-21 install-spider_2012-05-08T15-25-39 install-spider_2012-05-07T13-53-30 install-spider_2012-05-07T12-10-19 install-spider_2012-04-13T11-45-09 install-spider_2012-04-02T16-02-14 install-spider_2012-03-29T10-05-37 install-spider_2012-03-27T17-01-57 install-spider_2012-03-22T19-06-00 install-spider_2012-03-21T05-20-21 install-spider_2012-03-13T17-00-15 install-duck_2012-11-29T20-32-40 install-duck_2012-11-15T10-49-25 install-duck_2012-10-30T13-49-28 install-duck_2012-10-12T11-39-14 install-duck_2012-09-18T18-28-40 install-duck_2012-09-12T15-42-08 install-duck_2012-09-12T15-31-13 install-duck_2012-09-12T15-23-04 install-duck_2012-09-12T14-49-24 install-duck_2012-09-06T14-18-29 install-duck_2012-08-28T12-30-03 install-duck_2012-08-27T19-59-23 install-duck_2012-08-27T19-51-02 install-duck_2012-08-27T19-32-52 install-duck_2012-08-22T17-08-59 install-duck_2012-08-21T17-44-57 install-duck_2012-08-17T14-50-34 install-duck_2012-08-08T15-07-05 install-duck_2012-08-08T14-49-51 install-duck_2012-07-23T16-02-40
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
184 lines (168 sloc) 7.05 KB
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; log.cl
;;
;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2000-2012 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: log.cl,v 1.27 2008/02/04 19:03:59 jkf Exp $
;; Description:
;; iserve's logging
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(in-package :net.aserve)
(defun log1 (category level message &key (logger *logger*))
(log1* logger category level message))
(defgeneric log1* (logger category level message)
(:documentation "This the new, extensible logger interface to which
all others defer. By default, category :access is handled by
log-request* while the rest goes to logmess-stream. Note message is
not necessarily a string: for instance it is a request object
for :access which allows for more flexibility in presentation.")
(:method (logger category level message)
(declare (ignore logger))
(logmess-stream category level message *debug-stream*))
(:method (logger (category (eql :xmit-server-response-headers)) level message)
(declare (ignore logger))
;; time is :pre or :post depending on whether the headers are
;; generated before or after the body
(destructuring-bind (time string) message
(logmess-stream category level (format nil "~a ~s" time string)
*debug-stream*)))
(:method (logger (category (eql :access)) level (request http-request))
(declare (ignore logger level))
(log-request* request)))
(defvar *enable-logging* t) ; to turn on/off the standard logging method
(defvar *save-commands* nil) ; if true then a stream to which to write commands
(defun logmess (message &optional (format :long))
(log-for-wserver *wserver* message format))
(defmethod log-for-wserver ((wserver wserver) message format)
;; send log message to the default vhost's error stream
(let ((*debug-stream* (vhost-error-stream (wserver-default-vhost wserver)))
(*debug-format* format))
(log1 :aserve :info message)))
(defvar *log-time-zone* 0)
(defmethod logmess-stream (category level message stream
&optional (format *debug-format*))
;; send the log message to the given stream which should be a
;; stream object and not a stream indicator (like t)
;; If the stream has a lock use that.
(declare (ignore level))
(multiple-value-bind (csec cmin chour cday cmonth cyear)
(decode-universal-time (get-universal-time) *log-time-zone*)
(let* ((*print-pretty* nil)
(str (ecase format
(:long
(format
nil "[~a] ~a: ~2,'0d/~2,'0d/~2,'0d - ~2,'0d:~2,'0d:~2,'0d - ~a~%"
category (mp:process-name sys:*current-process*)
cmonth cday (mod cyear 100) chour cmin csec
message))
(:brief
(format nil "~2,'0d:~2,'0d:~2,'0d - ~a~%" chour cmin csec
message))))
(lock (getf (excl::stream-property-list stream) :lock)))
(if* lock
then (mp:with-process-lock (lock)
(if* (open-stream-p stream)
then (write-sequence str stream)
(finish-output stream)))
else (write-sequence str stream)
(finish-output stream)))))
(defmethod log-request ((req http-request))
;; after the request has been processed, write out log line
(if* *enable-logging*
then ;; By default this ends up calling log-request*.
(log1 :access :info req))
(if* *save-commands*
then (multiple-value-bind (ok whole uri-string)
(match-re "^[^ ]+\\s+([^ ]+)" (request-raw-request req))
(declare (ignore ok whole))
(format *save-commands*
"((:method . ~s) (:uri . ~s) (:proto . ~s) ~% (:code . ~s)~@[~% (:body . ~s)~]~@[~% (:auth . ~s)~]~@[~% (:ctype . ~s)~])~%"
(request-method req)
uri-string
(request-protocol req)
(let ((obj (request-reply-code req)))
(if* obj
then (response-number obj)
else 999))
(let ((bod (request-request-body req)))
(and (not (equal "" bod)) bod))
(multiple-value-list (get-basic-authorization req))
(header-slot-value req :content-type)))
(force-output *save-commands*)))
(defun log-request* (req)
(let* ((entry (format-access-log-entry req))
(stream (vhost-log-stream (request-vhost req)))
(lock (and (streamp stream)
(getf (excl::stream-property-list stream)
:lock))))
(macrolet ((do-log ()
'(progn (format stream "~a~%" entry)
(force-output stream))))
(if* lock
then (mp:with-process-lock (lock)
; in case stream switched out while we weren't busy
; get the stream again
(setq stream (vhost-log-stream (request-vhost req)))
(do-log))
else (do-log)))))
(defun format-access-log-entry (req)
(let* ((ipaddr (socket:remote-host (request-socket req)))
(time (request-reply-date req))
(code (let ((obj (request-reply-code req)))
(if* obj
then (response-number obj)
else 999)))
(length (or (request-reply-content-length req)
#+(and allegro (version>= 6))
(excl::socket-bytes-written
(request-socket req)))))
(format nil "~A~A~a - - [~a] ~s ~s ~s"
(if* *log-wserver-name*
then (wserver-name *wserver*)
else "")
(if* *log-wserver-name*
then " "
else "")
(socket:ipaddr-to-dotted ipaddr)
(maybe-universal-time-to-date time)
(request-raw-request req)
code
(or length -1))))
(defun log-proxy (uri level action extra)
;; log information from the proxy module
;;
(logmess
(format nil "~a ~d ~a ~a~@[ ~s~]"
(or (getf (mp:process-property-list mp:*current-process*)
'short-name)
(mp:process-name mp:*current-process*))
level
action
(if* (stringp uri)
then uri
else (net.uri:render-uri uri nil))
extra)
:brief))