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
  14            #:make-keyword #:named-lambda #:random-string #:salted-password
  15            #:start-hunchentoot))
  16
  17 (in-package #:trane-common)
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;;; Common access methods for database objects
  21
  22 (defgeneric id (object)
  23   (:documentation "Numeric ID or :NULL for DAOs and, if it makes sense, other objects.
  24
  25 Usually it will be a reader method automatically defined for ID column of a DAO."))
  26
  27 ;;; To enable using integer as a DAO when only ID is needed
  28 (defmethod id ((i integer))
  29   i)
  30
  31 ;;; NULL database id for NIL object.
  32 (defmethod id ((n null))
  33   :NULL)
  34
  35 (defmethod id ((n string))
  36   (parse-integer n :junk-allowed t))
  37
  38 (defgeneric slug (object)
  39   (:documentation "Get short, unique, urlified name of OBJECT."))
  40
  41 (defun slug-dao (class slug)
  42   "Select DAO of CLASS having \"slug\" column set to SLUG."
  43   (first (postmodern:select-dao class (:= 'slug slug))))
  44
  45 ;;; FIXME:flatten characters, unicode and so on
  46 (defun slugify (str)
  47   (iterate (for cs in-string str)
  48            (for c = (char-downcase cs))
  49            (for safe-p = (find c "abcdefghijklmnopqrstuvwxyz"))
  50            (for previous-safe-p previous safe-p initially t)
  51            (when safe-p
  52              (unless previous-safe-p
  53                (collect #\- result-type string))
  54              (collect c result-type string))))
  55
  56 (defclass dirtiness-mixin ()
  57   ((dirty-p :initform nil :accessor dirty-p)))
  58
  59 (defun mark-as-dirty (dao)
  60   (setf (dirty-p dao) t))
  61
  62 (defun update-dao-if-dirty (dao)
  63   (when (dirty-p dao)
  64     (postmodern:update-dao dao)
  65     (setf (dirty-p dao) nil)))
  66
  67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68 ;;; Initialization protocol
  69
  70 (defvar *config* (py-configparser:make-config)
  71   "Parsed configuration file.")
  72
  73 (defvar *config-files* (list "config.ini")
  74   "List of default configuration files.")
  75
  76 (defun init-config (&rest files)
  77   "Read in the configuration from files, defaulting to ones listed in *CONFIG-FILES*.
  78
  79 Should be first thing called in final init routine."
  80   (py-configparser:read-files *config* (or files *config-files*)))
  81
  82 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83 ;;; DB sugar
  84
  85 (defvar *db* nil
  86   "Database connection specification")
  87
  88 (defmethod hunchentoot:dispatch-request :around (dispatch-table)
  89   "Take care of database connection during HTTP request."
  90   (declare (ignore dispatch-table))
  91   (if *db*
  92       (postmodern:with-connection *db*
  93         (call-next-method))
  94       (call-next-method)))
  95
  96 (defun init-db-connection (&optional (section-name "db") (connect-toplevel-p t))
  97   "Initialize database connection from config.ini"
  98   (flet ((opt (name)
  99            (py-configparser:get-option *config* section-name name)))
 100     (setf *db* (list (opt "database")
 101                      (opt "username")
 102                      (opt "password")
 103                      (opt "host")
 104                      :pooled-p t)))
 105   (when connect-toplevel-p
 106     (apply #'postmodern:connect-toplevel (butlast *db* 2))))
 107
 108 (defmethod print-object :around ((timestamp simple-date:timestamp) stream)
 109   (if *print-escape*
 110       (call-next-method)
 111       (multiple-value-bind (year month day hour minute second millisecond)
 112           (simple-date:decode-timestamp timestamp)
 113         (declare (ignore millisecond))
 114         (format stream "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
 115                 year month day hour minute second))))
 116
 117 (defun execute* (statements &optional (query-log *standard-output*))
 118   "Execute a possibly nested list of sql STATEMENTS.
 119
 120 STATEMENTS may be either S-SQL expressions, literal SQL strings, or
 121 lists of statements."
 122   (labels ((execute-stmts (statements)
 123              (dolist (stmt statements)
 124                (etypecase stmt
 125                  (null)                 ; ignore NILs.
 126                  (string (postmodern:execute stmt))
 127                  (list (if (keywordp (first stmt))
 128                            (postmodern:execute (s-sql:sql-compile stmt))
 129                            (execute-stmts stmt)))))))
 130     (let ((cl-postgres:*query-log* query-log))
 131       (execute-stmts statements))))
 132
 133 (defun unless-null (v)
 134   "If V equals :NULL, return NIL, otherwise return V."
 135   (unless (eq :null v)
 136     v))
 137
 138 (defun null-or (v)
 139   "If V is NIL or an empty string, return :NULL, otherwise return V."
 140   (if (or (null v) (string= "" v))
 141       :null
 142       v))
 143
 144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 145 ;;; URIs
 146
 147 (defmethod uri ((u symbol))
 148   "URI on keybord -> look up from config."
 149   (parse-uri (py-configparser:get-option *config* "uri"
 150                                          (string-downcase (string u)))))
 151
 152 ;; Allow merging any URI designators
 153 (defmethod merge-uris (u b &optional p)
 154   (merge-uris (uri u) (uri b) p))
 155
 156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 157 ;;; Hunchentoot
 158
 159 (defun start-hunchentoot (&optional (section-name "hunchentoot"))
 160   (hunchentoot:start-server
 161    :port (py-configparser:get-option *config* section-name "port" :type :number)
 162    ;; SBCL barfs without coerce, WTF?
 163    :address (coerce (py-configparser:get-option *config* section-name "address")
 164                     'simple-string)))
 165
 166 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 167 ;;; General utility functions
 168
 169 (defun make-keyword (str)
 170   "Convert a string or symbol to a keyword."
 171   (intern (string-upcase (string str)) :keyword))
 172
 173 (defmacro named-lambda (name args &body body)
 174   "Version of LAMBDA that returns anonymous function defined with
 175 FLET and named NAME, which it's PRINTed with a name in most Lisp
 176 implementations."
 177   `(flet ((,name ,args ,@body))
 178      #',name))
 179
 180 (defun random-string (&key
 181                       (alphabet "123456790abcdefghijklmnopqrstuvwxyz")
 182                       (min-length 17)
 183                       (max-length 40))
 184   "Simple random string for initial password to use in account activation process."
 185   (coerce (loop for i from 0 to (+ min-length (random (- max-length min-length)))
 186              collect (aref alphabet (random (length alphabet))))
 187           'string))
 188
 189 (defun salted-password (salt password)
 190   "Return Base64-encoded MD5 checksum of SALT concatenated with PASSWORD."
 191   (cl-base64:usb8-array-to-base64-string
 192    (md5:md5sum-sequence (concatenate 'string salt password))))