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