src/common.lisp

   1 ;;;; -*- lisp -*- common.lisp -- common functionality used by CL-Trane libraries and projects
   2
   3 ;;;; Copyright (c) 2008, Maciej Pasternacki <maciej@pasternacki.net>
   4 ;;;; All rights reserved.  This file is available on the terms
   5 ;;;; detailed in COPYING file included with it.
   6
   7 ;; Package for internal use in libraries and projects
   8 (defpackage #:trane-common
   9   (:use #:common-lisp #:iterate #:puri)
  10   (:export #:id #:slug #:slug-dao #:slugify
  11            #:dirtiness-mixin #:dirty-p #:mark-as-dirty #:update-dao-if-dirty
  12            #:cache-dao #:with-dao-cache
  13            #:*config* #:init-config #:*db* #:init-db-connection #:execute*
  14            #:unless-null #:null-or #:invoke-sendmail
  15            #:report-error #:report-error-by-email #:report-error-to-file #:format-error-report
  16            #:*error-context-hook* #:*error-report-pathname-defaults*
  17            #:make-keyword #:named-lambda #:random-string #:salted-password #:hex-md5
  18            #:*handler-package* #:handler-function
  19            #:start-hunchentoot))
  20
  21 (in-package #:trane-common)
  22
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;;; Common access methods for database objects
  25
  26 (defgeneric id (object)
  27   (:documentation "Numeric ID or :NULL for DAOs and, if it makes sense, other objects.
  28
  29 Usually it will be a reader method automatically defined for ID column of a DAO."))
  30
  31 ;;; To enable using integer as a DAO when only ID is needed
  32 (defmethod id ((i integer))
  33   i)
  34
  35 ;;; NULL database id for NIL object.
  36 (defmethod id ((n null))
  37   :NULL)
  38
  39 (defmethod id ((n string))
  40   (parse-integer n :junk-allowed t))
  41
  42 (defgeneric slug (object)
  43   (:documentation "Get short, unique, urlified name of OBJECT."))
  44
  45 (defun slug-dao (class slug)
  46   "Select DAO of CLASS having \"slug\" column set to SLUG."
  47   (first (postmodern:select-dao class (:= 'slug slug))))
  48
  49 ;;; FIXME:flatten characters, unicode and so on
  50 (defun slugify (str)
  51   (iterate (for cs in-string str)
  52            (for c = (char-downcase cs))
  53            (for safe-p = (find c "abcdefghijklmnopqrstuvwxyz"))
  54            (for previous-safe-p previous safe-p initially t)
  55            (when safe-p
  56              (unless previous-safe-p
  57                (collect #\- result-type string))
  58              (collect c result-type string))))
  59
  60 (defclass dirtiness-mixin ()
  61   ((dirty-p :initform nil :accessor dirty-p)))
  62
  63 (defun mark-as-dirty (dao)
  64   (setf (dirty-p dao) t))
  65
  66 (defun update-dao-if-dirty (dao)
  67   (when (dirty-p dao)
  68     (postmodern:update-dao dao)
  69     (setf (dirty-p dao) nil)))
  70
  71 ;;; DAO caching
  72 (defvar -dao-cache-)
  73
  74 (defmethod postmodern:get-dao :around (type &rest keys)
  75   (if (boundp '-dao-cache-)
  76       (cdr
  77        (or (assoc (cons type keys) -dao-cache- :test #'equal)
  78            (first (push (cons (cons type keys)
  79                               (call-next-method))
  80                         -dao-cache-))))
  81       (call-next-method)))
  82
  83 (defun cache-dao (dao)
  84   "Manually add DAO to cache used by WITH-DAO-CACHE."
  85   (when (boundp '-dao-cache-)
  86     (push (cons (cons (class-name (class-of dao))
  87                       (postmodern:dao-keys dao))
  88                 dao)
  89           -dao-cache-)))
  90
  91 (defmacro with-dao-cache (&body body)
  92   "Cache DAOs within dynamic extent of BODY.
  93
  94 Within BODY, DAO objects obtained by GET-DAO are cached to avoid
  95 repeated queries fot the same objects.  DAO objects are added
  96 automatically before being returned by GET-DAO, or can be added
  97 manually with CACHE-DAO (e.g. when obtained by QUERY-DAO)."
  98   `(let ((-dao-cache- nil))
  99      ,@body))
 100
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102 ;;; Initialization protocol
 103
 104 (defvar *config* (py-configparser:make-config)
 105   "Parsed configuration file.")
 106
 107 (defvar *config-files* (list "config.ini")
 108   "List of default configuration files.")
 109
 110 (defun init-config (&rest files)
 111   "Read in the configuration from files, defaulting to ones listed in *CONFIG-FILES*.
 112
 113 Should be first thing called in final init routine."
 114   (py-configparser:read-files *config* (or files *config-files*)))
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 117 ;;; DB sugar
 118
 119 (defvar *db* nil
 120   "Database connection specification")
 121
 122 (defmethod hunchentoot:dispatch-request :around (dispatch-table)
 123   "Take care of database connection during HTTP request."
 124   (declare (ignore dispatch-table))
 125   (if *db*
 126       (postmodern:with-connection *db*
 127         (call-next-method))
 128       (call-next-method)))
 129
 130 (defun init-db-connection (&optional (section-name "db") (connect-toplevel-p t))
 131   "Initialize database connection from config.ini"
 132   (flet ((opt (name)
 133            (py-configparser:get-option *config* section-name name)))
 134     (setf *db* (list (opt "database")
 135                      (opt "username")
 136                      (opt "password")
 137                      (opt "host")
 138                      :pooled-p t)))
 139   (when connect-toplevel-p
 140     (apply #'postmodern:connect-toplevel (butlast *db* 2))))
 141
 142 (defmethod print-object :around ((timestamp simple-date:timestamp) stream)
 143   (if *print-escape*
 144       (call-next-method)
 145       (multiple-value-bind (year month day hour minute second millisecond)
 146           (simple-date:decode-timestamp timestamp)
 147         (declare (ignore millisecond))
 148         (format stream "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
 149                 year month day hour minute second))))
 150
 151 (defun execute* (statements &optional (query-log *standard-output*))
 152   "Execute a possibly nested list of sql STATEMENTS.
 153
 154 STATEMENTS may be either S-SQL expressions, literal SQL strings, or
 155 lists of statements."
 156   (labels ((execute-stmts (statements)
 157              (dolist (stmt statements)
 158                (etypecase stmt
 159                  (null)                 ; ignore NILs.
 160                  (string (postmodern:execute stmt))
 161                  (list (if (keywordp (first stmt))
 162                            (postmodern:execute (s-sql:sql-compile stmt))
 163                            (execute-stmts stmt)))))))
 164     (let ((cl-postgres:*query-log* query-log))
 165       (execute-stmts statements))))
 166
 167 (defun unless-null (v)
 168   "If V equals :NULL, return NIL, otherwise return V."
 169   (unless (eq :null v)
 170     v))
 171
 172 (defun null-or (v)
 173   "If V is NIL or an empty string, return :NULL, otherwise return V."
 174   (if (or (null v) (string= "" v))
 175       :null
 176       v))
 177
 178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 179 ;;; URIs
 180
 181 (defmethod uri ((u symbol))
 182   "URI on keybord -> look up from config."
 183   (parse-uri (py-configparser:get-option *config* "uri"
 184                                          (string-downcase (string u)))))
 185
 186 ;; Allow merging any URI designators
 187 (defmethod merge-uris (u b &optional p)
 188   (merge-uris (uri u) (uri b) p))
 189
 190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 191 ;;; Mailing
 192
 193 (defun invoke-sendmail (sender rcpt body-and-headers
 194                         &key (sendmail-binary (py-configparser:get-option *config* "mailing" "sendmail")) )
 195   "Invoke sendmail binary.
 196
 197 SENDER is envelope sender address, RCPT is envelope recipient
 198 address (may be a list), BODY-AND-HEADERS is fed to sendmail binary as
 199 stdin and it may be a string or an input stream.  SENDMAIL-BINARY is
 200 full path to sendmail binary, as a string, default is taken from
 201 *CONFIG* section mailing, variable sendmail."
 202   (external-program:run
 203    sendmail-binary
 204    (if (listp rcpt)
 205        (list* (concatenate 'string "-f" sender) rcpt)
 206        (list (concatenate 'string "-f" sender) rcpt))
 207    :input (etypecase body-and-headers
 208             (stream body-and-headers)
 209             (string (make-string-input-stream body-and-headers)))))
 210
 211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 212 ;;; Reporting conditions.
 213
 214 (defun format-request-details (&optional stream)
 215   "Format Hunchentoot request details to STREAM"
 216   (format stream
 217           "From ~A:~A ~A to ~A~%~A ~A ~A~%~{  ~S~%~}~@[Request body: ~S~%~]~@[GET params: ~S~%~]~@[POST params: ~S~%~]~@[Cookies: ~S~%~]"
 218           (hunchentoot:remote-addr) (hunchentoot:remote-port) (multiple-value-list (hunchentoot:real-remote-addr)) (hunchentoot:host)
 219           (hunchentoot:server-protocol) (hunchentoot:request-method) (hunchentoot:request-uri)
 220           (hunchentoot:headers-in)
 221           (hunchentoot:raw-post-data) (hunchentoot:get-parameters) (hunchentoot:post-parameters) (hunchentoot:cookies-in)))
 222
 223 (defun file-timestamp ()
 224   "Timestamp string to generate unique file names."
 225   (multiple-value-bind (s n h d m y wd dp zn) (get-decoded-time)
 226     (declare (ignore wd dp zn))
 227     (format nil "~4,'0d~2,'0d~2,'0d-~2,'0d~2,'0d~2,'0d"
 228             y m d h n s)))
 229
 230 (defmacro with-open-file-unique ((stream base-pathname) &body body)
 231   "Open new unique file for writing and execute BODY with new file opened as STREAM.
 232
 233 File name is named like BASE-PATHNAME, with PATHNAME-TYPE set to time
 234 stamp and (if needed) a unique integer."
 235   (let ((p (gensym)) (pp (gensym)) (i (gensym)) (tt (gensym)))
 236     `(let ((,p (pathname ,base-pathname))
 237            (,tt (file-timestamp))
 238            (,i nil))
 239        (loop
 240           for ,pp = (catch 'loop
 241                       (let ((,pp (make-pathname :defaults ,p
 242                                                 :type (format nil "~A~@[-~2,'0d~]" ,tt ,i))))
 243                         (with-open-file (,stream ,pp :direction :output :if-exists nil)
 244                           (unless ,stream
 245                             (if ,i (incf ,i) (setf ,i 1))
 246                             (throw 'loop nil))
 247                           ,@body
 248                           ,pp)))
 249           until ,pp
 250           finally (return ,pp)))))
 251
 252 (defvar *error-context-hook* nil
 253   "When set to a function designator, designated function will be
 254   FUNCALled when generating error report, with condition instance as
 255   an argument, and result will be inserted into error report as an
 256   error context.")
 257
 258 (defun format-error-report (s e)
 259   (format s "Error report from ~A, caught on ~A:~%~%" (machine-instance) (hunchentoot::iso-time))
 260   (when (boundp 'hunchentoot:*request*)
 261     (format-request-details s)
 262     (terpri s))
 263   (when *error-context-hook*
 264     (format s "Context: ~A~%"
 265             (handler-case (funcall *error-context-hook* e)
 266               (error (ee)
 267                 (format nil "CONTEXT FN ERRED! ~A~%Context backtrace:~%~A"
 268                         ee (hunchentoot:get-backtrace ee)))))
 269     (terpri s))
 270
 271   (format s "Original error: ~A~%~A~%" e (hunchentoot::get-backtrace e)))
 272
 273 (defvar *error-report-pathname-defaults* (merge-pathnames "error")
 274   "Base pathname for error reports when written to file.
 275
 276 Defaults to \"error\" in *DEFAULT-PATHNAME-DEFAULTS*.")
 277
 278 (defun report-error-to-file (e)
 279   (with-open-file-unique (s *error-report-pathname-defaults*)
 280     (format-error-report s e)))
 281
 282 (defun report-error-by-email (e rcpt &optional (sender (py-configparser:get-option *config* "mailing" "sender")))
 283   (invoke-sendmail sender rcpt
 284                    (format nil "From: <~A>~%To: <~A>~%Subject: Uncaught error ~A~%~%~A"
 285                            sender rcpt e
 286                            (with-output-to-string (s)
 287                              (format-error-report s e)))))
 288
 289 (defun report-error (e &optional (mailto (ignore-errors
 290                                            (py-configparser:get-option *config* "mailing" "error_mailto"))))
 291   (if mailto
 292       (report-error-by-email e mailto)
 293       (report-error-to-file e)))
 294
 295 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 296 ;;; Hunchentoot
 297
 298 (defun start-hunchentoot (&optional (section-name "hunchentoot"))
 299   (hunchentoot:start-server
 300    :port (py-configparser:get-option *config* section-name "port" :type :number)
 301    ;; SBCL barfs without coerce, WTF?
 302    :address (coerce (py-configparser:get-option *config* section-name "address")
 303                     'simple-string)))
 304
 305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 306 ;;; General utility functions
 307
 308 (defun make-keyword (str)
 309   "Convert a string or symbol to a keyword."
 310   (intern (string-upcase (string str)) :keyword))
 311
 312 (defmacro named-lambda (name args &body body)
 313   "Version of LAMBDA that returns anonymous function defined with
 314 FLET and named NAME, which it's PRINTed with a name in most Lisp
 315 implementations."
 316   `(flet ((,name ,args ,@body))
 317      #',name))
 318
 319 (defun random-string (&key
 320                       (alphabet "123456790abcdefghijklmnopqrstuvwxyz")
 321                       (min-length 17)
 322                       (max-length 40))
 323   "Simple random string for initial password to use in account activation process."
 324   (coerce (loop for i from 0 to (+ min-length (random (- max-length min-length)))
 325              collect (aref alphabet (random (length alphabet))))
 326           'string))
 327
 328 (defun salted-password (salt password)
 329   "Return Base64-encoded MD5 checksum of SALT concatenated with PASSWORD."
 330   (cl-base64:usb8-array-to-base64-string
 331    (md5:md5sum-sequence (concatenate 'string salt password))))
 332
 333 (defun hex-md5 (sequence)
 334   "Return MD5 checksum of SEQUENCE as a hexadecimal string."
 335   (format nil "~(~{~2,'0x~}~)"
 336           (coerce (md5:md5sum-sequence sequence)
 337                   'list)))
 338
 339 (defvar *handler-package* nil
 340   "Package, in which HANDLER-FUNCTION looks for handlers.
 341
 342 When NIL, *PACKAGE* is assumed, which is probably not what you want.")
 343
 344 (defun handler-function (&rest name-parts)
 345   "Return handler function whose name consists of NAME-PARTS.
 346
 347 Handler function name is NAME-PARTS joined with slash signes, and
 348 starting with a slash; NIL part means an empty place.  E.g. for
 349 NAME-PARTS :FOO :BAR :BAZ, it's /FOO/BAR/BAZ; for :FOO NIL it's /FOO/;
 350 and for NIL :XYZZY it's //XYZZY.
 351
 352 If symbol with such name exists in *HANDLER-PACKAGE* (or in *PACKAGE*,
 353 if *HANDLER-PACKAGE* is NIL, but probably it's not what you want), and
 354 it names a function, this function is returned."
 355   (multiple-value-bind (sym type)
 356       (find-symbol (format nil "~{/~@[~A~]~}" name-parts)
 357                    (or *handler-package* *package*))
 358     (when (and (not (eql type :inherited))
 359                (fboundp sym))
 360       (let ((fn (symbol-function sym)))
 361         (when (functionp fn)
 362           fn)))))