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) ; referenced with package name: #:py-configparser
  10   (:export #:id #:slug #:slug-dao #:slugify
  11            #:dirtyness-mixin #:dirty-p #:mark-as-dirty #:update-dao-if-dirty
  12            #:*config* #:*init-functions* #:on-init #:*setup-functions* #:on-setup
  13            #:*db*
  14            #:make-keyword #:named-lambda #:random-string))
  15
  16 ;; Package for use outside of project
  17 (defpackage #:cl-trane
  18   (:use #:common-lisp))
  19
  20 (in-package #:trane-common)
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;;; Common access methods for database objects
  24
  25 (defgeneric id (object)
  26   (:documentation "Numeric ID or :NULL for DAOs and, if it makes sense, other objects.
  27
  28 Usually it will be a reader method automatically defined for ID column of a DAO."))
  29
  30 ;;; To enable using integer as a DAO when only ID is needed
  31 (defmethod id ((i integer))
  32   i)
  33
  34 ;;; NULL database id for NIL object.
  35 (defmethod id ((n null))
  36   :NULL)
  37
  38 (defmethod id ((n string))
  39   (parse-integer n :junk-allowed t))
  40
  41 (defgeneric slug (object)
  42   (:documentation "Get short, unique, urlified name of OBJECT."))
  43
  44 (defun slug-dao (class slug)
  45   "Select DAO of CLASS having \"slug\" column set to SLUG."
  46   (first (postmodern:select-dao class (:= 'slug slug))))
  47
  48 ;;; FIXME:flatten characters, unicode and so on
  49 (defun slugify (str)
  50   (iterate (for cs in-string str)
  51            (for c = (char-downcase cs))
  52            (for safe-p = (find c "abcdefghijklmnopqrstuvwxyz"))
  53            (for previous-safe-p previous safe-p initially t)
  54            (when safe-p
  55              (unless previous-safe-p
  56                (collect #\- result-type string))
  57              (collect c result-type string))))
  58
  59 (defclass dirtyness-mixin ()
  60   ((dirty-p :initform nil :accessor dirty-p)))
  61
  62 (defun mark-as-dirty (dao)
  63   (setf (dirty-p dao) t))
  64
  65 (defun update-dao-if-dirty (dao)
  66   (when (dirty-p dao)
  67     (update-dao dao)
  68     (setf (dirty-p dao) nil)))
  69
  70 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71 ;;; Initialization and setup protocol
  72
  73 (defvar *config* (py-configparser:make-config)
  74   "Parsed configuration file.")
  75
  76 (defvar *config-files* (list "config.ini")
  77   "List of default configuration files.")
  78
  79 (defun read-configuration (&rest files)
  80   "Read configuration from FILES.
  81
  82 If no files are given, read files listed in *CONFIG-FILES*."
  83   (py-configparser:read-files *config* (or files *config-files*)))
  84
  85 (defvar *init-functions* ()
  86   "Functions (symbols) that are FUNCALLed on initialization.
  87
  88 No assumption about init function order should be made.")
  89
  90 (defun init ()
  91   "Initialize everything."
  92   (read-configuration)
  93   (mapcar #'funcall *init-functions*))
  94
  95 (defmacro on-init (&body body)
  96   "BODY should be sequence of DEFUN forms containing functions
  97 that are to be executed on initialization."
  98   (cons 'progn
  99         (loop for defun in body
 100            collect `(push ,defun *init-functions*))))
 101
 102 (defvar *setup-functions* ()
 103   "Functions (symbols) that are FUNCALLed on setup.
 104
 105 No assumption about setup function order should be made.")
 106
 107 (defun setup ()
 108   "Setup everything."
 109   (read-configuration)
 110   (mapcar #'funcall *setup-functions*))
 111
 112 (defmacro on-setup (&body body)
 113     "BODY should be sequence of DEFUN forms containing functions
 114 that are to be executed on setup."
 115     (cons 'progn
 116           (loop for defun in body
 117              collect `(push ,defun *setup-functions*))))
 118
 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 120 ;;; DB sugar
 121
 122 (defvar *db* nil
 123   "Database connection specification")
 124
 125 (defmethod hunchentoot:dispatch-request :around (dispatch-table)
 126   "Take care of database connection during HTTP request."
 127   (postmodern:with-connection *db*
 128     (call-next-method)))
 129
 130 (on-init
 131   (defun init-db-connection ()
 132     "Initialize database connection from config.ini"
 133     (flet ((opt (name)
 134              (py-configparser:get-option *config* "db" name)))
 135       (setf *db* (list (opt "database")
 136                        (opt "username")
 137                        (opt "password")
 138                        (opt "host")
 139                        :pooled-p t)))))
 140
 141 (defmethod print-object :around ((timestamp simple-date:timestamp) stream)
 142   (if *print-escape*
 143       (call-next-method)
 144       (multiple-value-bind (year month day hour minute second millisecond)
 145           (simple-date:decode-timestamp timestamp)
 146         (declare (ignore millisecond))
 147         (format stream "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
 148                 year month day hour minute second))))
 149
 150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 151 ;;; General utility functions
 152
 153
 154 (defun make-keyword (str)
 155   "Convert a string or symbol to a keyword."
 156   (intern (string-upcase (string str)) :keyword))
 157
 158 (defmacro named-lambda (name args &body body)
 159   "Version of LAMBDA that returns anonymous function defined with
 160 FLET and named NAME, which it's PRINTed with a name in most Lisp
 161 implementations."
 162   `(flet ((,name ,args ,@body))
 163      #',name))
 164
 165 (defun random-string (&key
 166                       (alphabet "123456790abcdefghijklmnopqrstuvwxyz")
 167                       (min-length 17)
 168                       (max-length 40))
 169   "Simple random string for initial password to use in account activation process."
 170   (coerce (loop for i from 0 to (+ min-length (random (- max-length min-length)))
 171              collect (aref alphabet (random (length alphabet))))
 172           'string))
 173
 174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 175 ;;; Externally exported symbols
 176 (import 'init :cl-trane)
 177 (import 'setup :cl-trane)
 178 (export 'init :cl-trane)
 179 (export 'setup :cl-trane)