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