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