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-functions* #:on-init
  13            #:*db* #:execute* #:unless-null #:null-or
  14            #:make-keyword #:named-lambda #:random-string #:salted-password
  15            #:start-hunchentoot))
  16
  17 ;; Package for use outside of project
  18 (defpackage #:cl-trane
  19   (:use #:common-lisp))
  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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72 ;;; Initialization protocol
  73
  74 (defvar *config* (py-configparser:make-config)
  75   "Parsed configuration file.")
  76
  77 (defvar *config-files* (list "config.ini")
  78   "List of default configuration files.")
  79
  80 (defun read-configuration (&rest files)
  81   "Read configuration from FILES.
  82
  83 If no files are given, read files listed in *CONFIG-FILES*."
  84   (py-configparser:read-files *config* (or files *config-files*)))
  85
  86 (defvar *init-functions* ()
  87   "Functions (symbols) that are FUNCALLed on initialization.
  88
  89 No assumption about init function order should be made.")
  90
  91 (defun init ()
  92   "Initialize everything."
  93   (read-configuration)
  94   (mapcar #'funcall *init-functions*))
  95
  96 (defmacro on-init (&body body)
  97   "BODY should be sequence of DEFUN forms containing functions
  98 that are to be executed on initialization."
  99   (cons 'progn
 100         (loop for defun in body
 101            collect `(push ,defun *init-functions*))))
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 ;;; DB sugar
 105
 106 (defvar *db* nil
 107   "Database connection specification")
 108
 109 (defmethod hunchentoot:dispatch-request :around (dispatch-table)
 110   "Take care of database connection during HTTP request."
 111   (declare (ignore dispatch-table))
 112   (postmodern:with-connection *db*
 113     (call-next-method)))
 114
 115 (on-init
 116   (defun init-db-connection ()
 117     "Initialize database connection from config.ini"
 118     (flet ((opt (name)
 119              (py-configparser:get-option *config* "db" name)))
 120       (setf *db* (list (opt "database")
 121                        (opt "username")
 122                        (opt "password")
 123                        (opt "host")
 124                        :pooled-p t)))
 125     (apply #'postmodern:connect-toplevel (nbutlast *db* 2))))
 126
 127 (defmethod print-object :around ((timestamp simple-date:timestamp) stream)
 128   (if *print-escape*
 129       (call-next-method)
 130       (multiple-value-bind (year month day hour minute second millisecond)
 131           (simple-date:decode-timestamp timestamp)
 132         (declare (ignore millisecond))
 133         (format stream "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
 134                 year month day hour minute second))))
 135
 136 (defun execute* (statements &optional (query-log *standard-output*))
 137   "Execute a possibly nested list of sql STATEMENTS.
 138
 139 STATEMENTS may be either S-SQL expressions, literal SQL strings, or
 140 lists of statements."
 141   (labels ((execute-stmts (statements)
 142              (dolist (stmt statements)
 143                (etypecase stmt
 144                  (null)                 ; ignore NILs.
 145                  (string (postmodern:execute stmt))
 146                  (list (if (keywordp (first stmt))
 147                            (postmodern:execute (s-sql:sql-compile stmt))
 148                            (execute-stmts stmt)))))))
 149     (let ((cl-postgres:*query-log* query-log))
 150       (execute-stmts statements))))
 151
 152 (defun unless-null (v)
 153   "If V equals :NULL, return NIL, otherwise return V."
 154   (unless (eq :null v)
 155     v))
 156
 157 (defun null-or (v)
 158   "If V is NIL or an empty string, return :NULL, otherwise return V."
 159   (if (or (null v) (string= "" v))
 160       :null
 161       v))
 162
 163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 164 ;;; URIs
 165
 166 (defmethod uri ((u symbol))
 167   "URI on keybord -> look up from config."
 168   (parse-uri (py-configparser:get-option *config* "uri"
 169                                          (string-downcase (string u)))))
 170
 171 ;; Allow merging any URI designators
 172 (defmethod merge-uris (u b &optional p)
 173   (merge-uris (uri u) (uri b) p))
 174
 175 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 176 ;;; Hunchentoot
 177
 178 (on-init
 179   (defun start-hunchentoot ()
 180     (when (py-configparser:has-section-p *config* "hunchentoot")
 181       (hunchentoot:start-server :port (py-configparser:get-option *config* "hunchentoot" "port" :type :number)
 182                                 :address (py-configparser:get-option *config* "hunchentoot" "address")))))
 183
 184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 185 ;;; General utility functions
 186
 187
 188 (defun make-keyword (str)
 189   "Convert a string or symbol to a keyword."
 190   (intern (string-upcase (string str)) :keyword))
 191
 192 (defmacro named-lambda (name args &body body)
 193   "Version of LAMBDA that returns anonymous function defined with
 194 FLET and named NAME, which it's PRINTed with a name in most Lisp
 195 implementations."
 196   `(flet ((,name ,args ,@body))
 197      #',name))
 198
 199 (defun random-string (&key
 200                       (alphabet "123456790abcdefghijklmnopqrstuvwxyz")
 201                       (min-length 17)
 202                       (max-length 40))
 203   "Simple random string for initial password to use in account activation process."
 204   (coerce (loop for i from 0 to (+ min-length (random (- max-length min-length)))
 205              collect (aref alphabet (random (length alphabet))))
 206           'string))
 207
 208 (defun salted-password (salt password)
 209   "Return Base64-encoded MD5 checksum of SALT concatenated with PASSWORD."
 210   (cl-base64:usb8-array-to-base64-string
 211    (md5:md5sum-sequence (concatenate 'string salt password))))
 212
 213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 214 ;;; Externally exported symbols
 215 (import 'init :cl-trane)
 216 (import 'setup :cl-trane)
 217 (export 'init :cl-trane)
 218 (export 'setup :cl-trane)