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 #:qp-utf8 #: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
  86 Returns DAO"
  87   (when (boundp '-dao-cache-)
  88     (push (cons (cons (class-name (class-of dao))
  89                       (postmodern:dao-keys dao))
  90                 dao)
  91           -dao-cache-))
  92   dao)
  93
  94 (defmacro with-dao-cache (&body body)
  95   "Cache DAOs within dynamic extent of BODY.
  96
  97 Within BODY, DAO objects obtained by GET-DAO are cached to avoid
  98 repeated queries fot the same objects.  DAO objects are added
  99 automatically before being returned by GET-DAO, or can be added
 100 manually with CACHE-DAO (e.g. when obtained by QUERY-DAO)."
 101   `(let ((-dao-cache- nil))
 102      ,@body))
 103
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 ;;; Initialization protocol
 106
 107 (defvar *config* (py-configparser:make-config)
 108   "Parsed configuration file.")
 109
 110 (defvar *config-files* (list "config.ini")
 111   "List of default configuration files.")
 112
 113 (defun init-config (&rest files)
 114   "Read in the configuration from files, defaulting to ones listed in *CONFIG-FILES*.
 115
 116 Should be first thing called in final init routine."
 117   (py-configparser:read-files *config* (or files *config-files*)))
 118
 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 120 ;;; DB sugar
 121
 122 (defvar *db* nil
 123   "Database connection specification")
 124
 125 (defmethod hunchentoot:dispatch-request :around (dispatch-table)
 126   "Take care of database connection during HTTP request."
 127   (declare (ignore dispatch-table))
 128   (if *db*
 129       (postmodern:with-connection *db*
 130         (call-next-method))
 131       (call-next-method)))
 132
 133 (defun init-db-connection (&optional (section-name "db") (connect-toplevel-p t))
 134   "Initialize database connection from config.ini"
 135   (flet ((opt (name)
 136            (py-configparser:get-option *config* section-name name)))
 137     (setf *db* (list (opt "database")
 138                      (opt "username")
 139                      (opt "password")
 140                      (opt "host")
 141                      :pooled-p t)))
 142   (when connect-toplevel-p
 143     (apply #'postmodern:connect-toplevel (butlast *db* 2))))
 144
 145 (defmethod print-object :around ((timestamp simple-date:timestamp) stream)
 146   (if *print-escape*
 147       (call-next-method)
 148       (multiple-value-bind (year month day hour minute second millisecond)
 149           (simple-date:decode-timestamp timestamp)
 150         (declare (ignore millisecond))
 151         (format stream "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
 152                 year month day hour minute second))))
 153
 154 (defun execute* (statements &optional (query-log *standard-output*))
 155   "Execute a possibly nested list of sql STATEMENTS.
 156
 157 STATEMENTS may be either S-SQL expressions, literal SQL strings, or
 158 lists of statements."
 159   (labels ((execute-stmts (statements)
 160              (dolist (stmt statements)
 161                (etypecase stmt
 162                  (null)                 ; ignore NILs.
 163                  (string (postmodern:execute stmt))
 164                  (list (if (keywordp (first stmt))
 165                            (postmodern:execute (s-sql:sql-compile stmt))
 166                            (execute-stmts stmt)))))))
 167     (let ((cl-postgres:*query-log* query-log))
 168       (execute-stmts statements))))
 169
 170 (defun unless-null (v)
 171   "If V equals :NULL, return NIL, otherwise return V."
 172   (unless (eq :null v)
 173     v))
 174
 175 (defun null-or (v)
 176   "If V is NIL or an empty string, return :NULL, otherwise return V."
 177   (if (or (null v) (and (stringp v) (string= "" v)))
 178       :null
 179       v))
 180
 181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 182 ;;; URIs
 183
 184 (defmethod uri ((u symbol))
 185   "URI on keybord -> look up from config."
 186   (parse-uri (py-configparser:get-option *config* "uri"
 187                                          (string-downcase (string u)))))
 188
 189 ;; Allow merging any URI designators
 190 (defmethod merge-uris (u b &optional p)
 191   (merge-uris (uri u) (uri b) p))
 192
 193 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 194 ;;; Mailing
 195
 196 (defun qp-utf8 (string)
 197   "Encode STRING as quoted-printable UTF-8"
 198   (cl-qprint:encode (map 'string #'code-char (trivial-utf-8:string-to-utf-8-bytes string))))
 199
 200 (defun invoke-sendmail (sender rcpt body-and-headers
 201                         &key (sendmail-binary (py-configparser:get-option *config* "mailing" "sendmail")) )
 202   "Invoke sendmail binary.
 203
 204 SENDER is envelope sender address, RCPT is envelope recipient
 205 address (may be a list), BODY-AND-HEADERS is fed to sendmail binary as
 206 stdin and it may be a string or an input stream.  SENDMAIL-BINARY is
 207 full path to sendmail binary, as a string, default is taken from
 208 *CONFIG* section mailing, variable sendmail."
 209   (flet ((ss (s)
 210            (coerce s 'simple-string)))
 211     (external-program:run
 212      sendmail-binary
 213      (if (listp rcpt)
 214          (list* (concatenate 'string "-f" (ss sender)) (mapcar #'ss rcpt))
 215          (list (concatenate 'string "-f" (ss sender)) (ss rcpt)))
 216      :input (etypecase body-and-headers
 217               (stream body-and-headers)
 218               (string (make-string-input-stream body-and-headers))))))
 219
 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221 ;;; Reporting conditions.
 222
 223 (defun format-request-details (&optional stream)
 224   "Format Hunchentoot request details to STREAM"
 225   (format stream
 226           "From ~A:~A ~A to ~A~%~A ~A ~A~%~{  ~S~%~}~@[Request body: ~S~%~]~@[GET params: ~S~%~]~@[POST params: ~S~%~]~@[Cookies: ~S~%~]"
 227           (hunchentoot:remote-addr) (hunchentoot:remote-port) (multiple-value-list (hunchentoot:real-remote-addr)) (hunchentoot:host)
 228           (hunchentoot:server-protocol) (hunchentoot:request-method) (hunchentoot:request-uri)
 229           (hunchentoot:headers-in)
 230           (hunchentoot:raw-post-data) (hunchentoot:get-parameters) (hunchentoot:post-parameters) (hunchentoot:cookies-in)))
 231
 232 (defun file-timestamp ()
 233   "Timestamp string to generate unique file names."
 234   (multiple-value-bind (s n h d m y wd dp zn) (get-decoded-time)
 235     (declare (ignore wd dp zn))
 236     (format nil "~4,'0d~2,'0d~2,'0d-~2,'0d~2,'0d~2,'0d"
 237             y m d h n s)))
 238
 239 (defmacro with-open-file-unique ((stream base-pathname) &body body)
 240   "Open new unique file for writing and execute BODY with new file opened as STREAM.
 241
 242 File name is named like BASE-PATHNAME, with PATHNAME-TYPE set to time
 243 stamp and (if needed) a unique integer."
 244   (let ((p (gensym)) (pp (gensym)) (i (gensym)) (tt (gensym)))
 245     `(let ((,p (pathname ,base-pathname))
 246            (,tt (file-timestamp))
 247            (,i nil))
 248        (loop
 249           for ,pp = (catch 'loop
 250                       (let ((,pp (make-pathname :defaults ,p
 251                                                 :type (format nil "~A~@[-~2,'0d~]" ,tt ,i))))
 252                         (with-open-file (,stream ,pp :direction :output :if-exists nil)
 253                           (unless ,stream
 254                             (if ,i (incf ,i) (setf ,i 1))
 255                             (throw 'loop nil))
 256                           ,@body
 257                           ,pp)))
 258           until ,pp
 259           finally (return ,pp)))))
 260
 261 (defvar *error-context-hook* nil
 262   "When set to a function designator, designated function will be
 263   FUNCALled when generating error report, with condition instance as
 264   an argument, and result will be inserted into error report as an
 265   error context.")
 266
 267 (defun format-error-report (s e)
 268   (format s "Error report from ~A, caught on ~A:~%~%" (machine-instance) (hunchentoot::iso-time))
 269   (when (boundp 'hunchentoot:*request*)
 270     (format-request-details s)
 271     (terpri s))
 272   (when *error-context-hook*
 273     (format s "Context: ~A~%"
 274             (handler-case (funcall *error-context-hook* e)
 275               (error (ee)
 276                 (format nil "CONTEXT FN ERRED! ~A~%Context backtrace:~%~A"
 277                         ee (hunchentoot:get-backtrace ee)))))
 278     (terpri s))
 279
 280   (format s "Original error: ~A~%~A~%" e (hunchentoot::get-backtrace e)))
 281
 282 (defvar *error-report-pathname-defaults* (merge-pathnames "error")
 283   "Base pathname for error reports when written to file.
 284
 285 Defaults to \"error\" in *DEFAULT-PATHNAME-DEFAULTS*.")
 286
 287 (defun report-error-to-file (e)
 288   (with-open-file-unique (s *error-report-pathname-defaults*)
 289     (format-error-report s e)))
 290
 291 (defun report-error-by-email (e rcpt &optional (sender (py-configparser:get-option *config* "mailing" "sender")))
 292   (invoke-sendmail sender rcpt
 293                    (format nil "From: <~A>~%To: <~A>~%Subject: Uncaught error ~A~%Content-Type: text/plain; charset=utf-8~%Content-Transfer-Encoding: Quoted-Printable~%~%~A"
 294                            sender rcpt e
 295                            (qp-utf8
 296                             (with-output-to-string (s)
 297                               (format-error-report s e))))))
 298
 299 (defun report-error (e &optional (mailto (ignore-errors
 300                                            (py-configparser:get-option *config* "mailing" "error_mailto"))))
 301   (if mailto
 302       (report-error-by-email e mailto)
 303       (report-error-to-file e)))
 304
 305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 306 ;;; Hunchentoot
 307
 308 (defun start-hunchentoot (&optional (section-name "hunchentoot"))
 309   (hunchentoot:start-server
 310    :port (py-configparser:get-option *config* section-name "port" :type :number)
 311    ;; SBCL barfs without coerce, WTF?
 312    :address (coerce (py-configparser:get-option *config* section-name "address")
 313                     'simple-string)))
 314
 315 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 316 ;;; General utility functions
 317
 318 (defun make-keyword (str)
 319   "Convert a string or symbol to a keyword."
 320   (intern (string-upcase (string str)) :keyword))
 321
 322 (defmacro named-lambda (name args &body body)
 323   "Version of LAMBDA that returns anonymous function defined with
 324 FLET and named NAME, which it's PRINTed with a name in most Lisp
 325 implementations."
 326   `(flet ((,name ,args ,@body))
 327      #',name))
 328
 329 (defun random-string (&key
 330                       (alphabet "123456790abcdefghijklmnopqrstuvwxyz")
 331                       (min-length 17)
 332                       (max-length 40))
 333   "Simple random string for initial password to use in account activation process."
 334   (coerce (loop for i from 0 to (+ min-length (random (- max-length min-length)))
 335              collect (aref alphabet (random (length alphabet))))
 336           'string))
 337
 338 (defun salted-password (salt password)
 339   "Return Base64-encoded MD5 checksum of SALT concatenated with PASSWORD."
 340   (cl-base64:usb8-array-to-base64-string
 341    (md5:md5sum-sequence (concatenate 'string salt password))))
 342
 343 (defun hex-md5 (sequence)
 344   "Return MD5 checksum of SEQUENCE as a hexadecimal string."
 345   (format nil "~(~{~2,'0x~}~)"
 346           (coerce (md5:md5sum-sequence sequence)
 347                   'list)))
 348
 349 (defvar *handler-package* nil
 350   "Package, in which HANDLER-FUNCTION looks for handlers.
 351
 352 When NIL, *PACKAGE* is assumed, which is probably not what you want.")
 353
 354 (defun handler-function (&rest name-parts)
 355   "Return handler function whose name consists of NAME-PARTS.
 356
 357 Handler function name is NAME-PARTS joined with slash signes, and
 358 starting with a slash; NIL part means an empty place.  E.g. for
 359 NAME-PARTS :FOO :BAR :BAZ, it's /FOO/BAR/BAZ; for :FOO NIL it's /FOO/;
 360 and for NIL :XYZZY it's //XYZZY.
 361
 362 If symbol with such name exists in *HANDLER-PACKAGE* (or in *PACKAGE*,
 363 if *HANDLER-PACKAGE* is NIL, but probably it's not what you want), and
 364 it names a function, this function is returned."
 365   (multiple-value-bind (sym type)
 366       (find-symbol (format nil "~{/~@[~A~]~}" name-parts)
 367                    (or *handler-package* *package*))
 368     (when (and (not (eql type :inherited))
 369                (fboundp sym))
 370       (let ((fn (symbol-function sym)))
 371         (when (functionp fn)
 372           fn)))))