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