log.lisp

   1 ;;; PHOROS -- Photogrammetric Road Survey
   2 ;;; Copyright (C) 2010, 2011 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
  31 (defun launch-logger (&optional (log-dir ""))
  32   "Start logging facility.  Create log-dir if necessary."
  33   (let ((log-dir (pathname-directory (ensure-directories-exist
  34                                       (pathname log-dir)))))
  35
  36     (setf (cl-log:log-manager)
  37           (make-instance 'cl-log:log-manager
  38                          :message-class 'cl-log:formatted-message))
  39
  40     (cl-log:start-messenger
  41      'cl-log:text-file-messenger
  42      :name :access
  43      :filename (make-pathname :directory log-dir :name "access" :type "log")
  44      :category :access)
  45
  46     (cl-log:start-messenger
  47      'cl-log:text-file-messenger
  48      :name :db
  49      :filename (make-pathname :directory log-dir :name "db" :type "log")
  50      :category :db)
  51
  52     (cl-log:start-messenger
  53      'cl-log:text-file-messenger
  54      :name :orphan
  55      :filename (make-pathname :directory log-dir :name "orphan" :type "log")
  56      :category :orphan)
  57
  58     (cl-log:start-messenger
  59      'cl-log:text-file-messenger
  60      :name :info
  61      :filename (make-pathname :directory log-dir :name "info" :type "log")
  62      :category :info)
  63
  64     (cl-log:start-messenger
  65      'cl-log:text-file-messenger
  66      :name :warning
  67      :filename (make-pathname :directory log-dir :name "warning" :type "log")
  68      :category :warning)
  69
  70     (cl-log:start-messenger
  71      'cl-log:text-file-messenger
  72      :name :error
  73      :filename (make-pathname :directory log-dir :name "error" :type "log")
  74      :category :error)
  75
  76     (cl-log:start-messenger
  77      'cl-log:text-file-messenger
  78      :name :debug
  79      :filename (make-pathname :directory log-dir :name "debug" :type "log")
  80      :category :debug)
  81
  82     (cl-log:start-messenger
  83      'cl-log:text-stream-messenger
  84      :name :stream
  85      :stream *error-output*
  86      :category :debug)))
  87
  88 (defmethod cl-log:format-message ((self cl-log:formatted-message))
  89   (if (eq (cl-log:message-category self) :access)
  90       (destructuring-bind (remote-addr*
  91                            header-in*
  92                            authorization
  93                            ;;iso-time
  94                            request-method*
  95                            script-name*
  96                            query-string*
  97                            server-protocol*
  98                            return-code
  99                            content
 100                            content-length
 101                            referer
 102                            user-agent)
 103           (cl-log:message-arguments self)
 104         (format nil
 105                 "~:[-~@[ (~A)~]~;~:*~A~@[ (~A)~]~] ~:[-~;~:*~A~] [~A] \"~A ~A~@[?~A~] ~
 106                       ~A\" ~A ~:[~*-~;~D~] \"~:[-~;~:*~A~]\" \"~:[-~;~:*~A~]\"~%"
 107                 remote-addr*
 108                 header-in*
 109                 authorization
 110                 (timestring (cl-log:timestamp-universal-time
 111                              (cl-log:message-timestamp self)))
 112                 request-method*
 113                 script-name*
 114                 query-string*
 115                 server-protocol*
 116                 return-code
 117                 content
 118                 content-length
 119                 referer
 120                 user-agent))
 121       (format nil "~A ~A ~?~&"
 122               (timestring (cl-log:timestamp-universal-time
 123                            (cl-log:message-timestamp self)))
 124               (cl-log:message-category self)
 125               (cl-log:message-description self)
 126               (cl-log:message-arguments self))))
 127
 128 (defun timestring (time)
 129   "ISO 8601 representation of time."
 130   (multiple-value-bind (whole-seconds remainder) (floor time)
 131     (when (zerop remainder) (setf remainder nil))
 132     (multiple-value-bind (second minute hour date month year)
 133         (decode-universal-time whole-seconds 0)
 134       (format
 135        nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~@[~0F~]Z"
 136        year month date hour minute second remainder))))
 137
 138 (defun log-http-access (&key return-code content content-length)
 139   "Log HTTP access.  Use as :access-logger in a hunchentoot:accessor."
 140   (cl-log:log-message :access nil
 141                       (hunchentoot:remote-addr*)
 142                       (hunchentoot:header-in* :x-forwarded-for)
 143                       (hunchentoot:authorization)
 144                       ;;(hunchentoot:iso-time)
 145                       (hunchentoot:request-method*)
 146                       (hunchentoot:script-name*)
 147                       (hunchentoot:query-string*)
 148                       (hunchentoot:server-protocol*)
 149                       return-code
 150                       content
 151                       content-length
 152                       (hunchentoot:referer)
 153                       (hunchentoot:user-agent)))
 154
 155 (defun log-hunchentoot-message (severity format-string &rest args)
 156   "Log hunchentoot messages.  Use as :message-logger in a
 157 hunchentoot:accessor.  For severity, hunchentoot uses :info, :warning,
 158 and :error."
 159   (cl-log:log-message severity "~?" format-string args))