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
  11            #:*config* #:*init-functions* #:on-init #:*setup-functions* #:on-setup
  12            #:*db*
  13            #:make-keyword #:named-lambda #:random-string))
  14
  15 ;; Package for use outside of project
  16 (defpackage #:cl-trane
  17   (:use #:common-lisp))
  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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;;; Initialization and setup protocol
  49
  50 (defvar *config* (py-configparser:make-config)
  51   "Parsed configuration file.")
  52
  53 (defvar *config-files* (list "config.ini")
  54   "List of default configuration files.")
  55
  56 (defun read-configuration (&rest files)
  57   "Read configuration from FILES.
  58
  59 If no files are given, read files listed in *CONFIG-FILES*."
  60   (py-configparser:read-files *config* (or files *config-files*)))
  61
  62 (defvar *init-functions* ()
  63   "Functions (symbols) that are FUNCALLed on initialization.
  64
  65 No assumption about init function order should be made.")
  66
  67 (defun init ()
  68   "Initialize everything."
  69   (read-configuration)
  70   (mapcar #'funcall *init-functions*))
  71
  72 (defmacro on-init (&body body)
  73   "BODY should be sequence of DEFUN forms containing functions
  74 that are to be executed on initialization."
  75   (cons 'progn
  76         (loop for defun in body
  77            collect `(push ,defun *init-functions*))))
  78
  79 (defvar *setup-functions* ()
  80   "Functions (symbols) that are FUNCALLed on setup.
  81
  82 No assumption about setup function order should be made.")
  83
  84 (defun setup ()
  85   "Setup everything."
  86   (read-configuration)
  87   (mapcar #'funcall *setup-functions*))
  88
  89 (defmacro on-setup (&body body)
  90     "BODY should be sequence of DEFUN forms containing functions
  91 that are to be executed on setup."
  92     (cons 'progn
  93           (loop for defun in body
  94              collect `(push ,defun *setup-functions*))))
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97 ;;; DB sugar
  98
  99 (defvar *db* nil
 100   "Database connection specification")
 101
 102 (defmethod hunchentoot:dispatch-request :around (dispatch-table)
 103   "Take care of database connection during HTTP request."
 104   (postmodern:with-connection *db*
 105     (call-next-method)))
 106
 107 (on-init
 108   (defun init-db-connection ()
 109     "Initialize database connection from config.ini"
 110     (flet ((opt (name)
 111              (py-configparser:get-option *config* "db" name)))
 112       (setf *db* (list (opt "database")
 113                        (opt "username")
 114                        (opt "password")
 115                        (opt "host")
 116                        :pooled-p t)))))
 117
 118 (defmethod print-object :around ((timestamp simple-date:timestamp) stream)
 119   (if *print-escape*
 120       (call-next-method)
 121       (multiple-value-bind (year month day hour minute second millisecond)
 122           (simple-date:decode-timestamp timestamp)
 123         (declare (ignore millisecond))
 124         (format stream "~D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
 125                 year month day hour minute second))))
 126
 127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128 ;;; General utility functions
 129
 130
 131 (defun make-keyword (str)
 132   "Convert a string or symbol to a keyword."
 133   (intern (string-upcase (string str)) :keyword))
 134
 135 (defmacro named-lambda (name args &body body)
 136   "Version of LAMBDA that returns anonymous function defined with
 137 FLET and named NAME, which it's PRINTed with a name in most Lisp
 138 implementations."
 139   `(flet ((,name ,args ,@body))
 140      #',name))
 141
 142 (defun random-string (&key
 143                       (alphabet "123456790abcdefghijklmnopqrstuvwxyz")
 144                       (min-length 17)
 145                       (max-length 40))
 146   "Simple random string for initial password to use in account activation process."
 147   (coerce (loop for i from 0 to (+ min-length (random (- max-length min-length)))
 148              collect (aref alphabet (random (length alphabet))))
 149           'string))
 150
 151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 152 ;;; Externally exported symbols
 153 (import 'init :cl-trane)
 154 (import 'setup :cl-trane)
 155 (export 'init :cl-trane)
 156 (export 'setup :cl-trane)