log.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011, 2012 Bert Burgemeister
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2 of the License, or
   7 ;;; (at your option) any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; You should have received a copy of the GNU General Public License along
  15 ;;; with this program; if not, write to the Free Software Foundation, Inc.,
  16 ;;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  17
  18
  19 (in-package :phoros)
  20
  21 (cl-log:defcategory :access)
  22 (cl-log:defcategory :db-sys)
  23 (cl-log:defcategory :db-dat)
  24 (cl-log:defcategory :db (or :db-sys :db-dat))
  25 (cl-log:defcategory :orphan)
  26 (cl-log:defcategory :info (or :info :db :orphan))
  27 (cl-log:defcategory :warning)
  28 (cl-log:defcategory :error)
  29 (cl-log:defcategory :debug (or :debug :db :info :warning :error))
  30 (cl-log:defcategory :sql)
  31
  32 (defun launch-logger (&optional (log-dir ""))
  33   "Start logging facility.  Create log-dir if necessary."
  34   (flet ((start-log-messenger (name-keyword)
  35            (cl-log:start-messenger
  36             'cl-log:text-file-messenger
  37             :name name-keyword
  38             :filename (make-pathname
  39                        :directory (pathname-directory
  40                                    (ensure-directories-exist
  41                                     (pathname log-dir)))
  42                        :name (string-downcase name-keyword)
  43                        :type "log")
  44             :category name-keyword))
  45          (stop-log-messenger (name-keyword)
  46            (when (cl-log:find-messenger name-keyword)
  47              (cl-log:stop-messenger name-keyword))))
  48
  49     (setf (cl-log:log-manager)
  50           (make-instance 'cl-log:log-manager
  51                          :message-class 'cl-log:formatted-message))
  52     (values
  53      (start-log-messenger :access)
  54      (start-log-messenger :db)
  55      (start-log-messenger :orphan)
  56      (start-log-messenger :info)
  57      (start-log-messenger :warning)
  58      (start-log-messenger :error)
  59      (if *log-sql-p* (start-log-messenger :sql) (stop-log-messenger :sql))
  60      (start-log-messenger :debug)
  61
  62      (cl-log:start-messenger
  63       'cl-log:text-stream-messenger
  64       :name :debug-stream
  65       :stream *error-output*
  66       :category :debug))))
  67
  68 (defmethod cl-log:format-message ((self cl-log:formatted-message))
  69   (if (eq (cl-log:message-category self) :access)
  70       (destructuring-bind (remote-addr*
  71                            header-in*
  72                            authorization
  73                            ;;iso-time
  74                            request-method*
  75                            script-name*
  76                            query-string*
  77                            server-protocol*
  78                            return-code
  79                            content
  80                            content-length
  81                            referer
  82                            user-agent)
  83           (cl-log:message-arguments self)
  84         (format
  85          nil
  86          "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
  87          ~A\" ~A ~:[~*-~;~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
  88          remote-addr*
  89          header-in*
  90          authorization
  91          (timestring (cl-log:timestamp-universal-time
  92                       (cl-log:message-timestamp self)))
  93          request-method*
  94          script-name*
  95          query-string*
  96          server-protocol*
  97          return-code
  98          content
  99          content-length
 100          referer
 101          user-agent))
 102       (format nil "~A ~A ~?~&"
 103               (timestring (cl-log:timestamp-universal-time
 104                            (cl-log:message-timestamp self)))
 105               (cl-log:message-category self)
 106               (cl-log:message-description self)
 107               (cl-log:message-arguments self))))
 108
 109 (defun timestring (time)
 110   "ISO 8601 representation of time."
 111   (multiple-value-bind (whole-seconds remainder) (floor time)
 112     (when (zerop remainder) (setf remainder nil))
 113     (multiple-value-bind (second minute hour date month year)
 114         (decode-universal-time whole-seconds 0)
 115       (format
 116        nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~@[~0F~]Z"
 117        year month date hour minute second remainder))))
 118
 119 (defmethod hunchentoot:acceptor-log-access :around
 120     ((acceptor t) &key return-code content content-length)
 121   "Log HTTP server access."
 122   (cl-log:log-message :access nil
 123                       (hunchentoot:remote-addr*)
 124                       (hunchentoot:header-in* :x-forwarded-for)
 125                       (hunchentoot:authorization)
 126                       ;;(hunchentoot:iso-time)
 127                       (hunchentoot:request-method*)
 128                       (hunchentoot:script-name*)
 129                       (hunchentoot:query-string*)
 130                       (hunchentoot:server-protocol*)
 131                       return-code
 132                       content
 133                       content-length
 134                       (hunchentoot:referer)
 135                       (hunchentoot:user-agent)))
 136
 137 (defmethod hunchentoot:acceptor-log-message :around
 138     ((acceptor t) severity format-string &rest args)
 139   "Log HTTP server messages.  For severity, hunchentoot uses :info,
 140 :warning, and :error."
 141   (cl-log:log-message severity "~?" format-string args))