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