view base/database/database-connect.lisp @ 191:4d06910b6f0f

New base module for general database functions

Ignore-this: 403f22ca6285cba4a23eeddb1d0a806f

Currently just provides a slightly more secure way of connecting to a database.

darcs-hash:20090519135617-16a00-ce026a38abfb53e5728cd0cbb6c976e403691dde.gz

(cl:in-package #:amuse-database-admin)

(defparameter *amuse-database* nil)

(defun connect-to-database (&key (database-name "amuse") username
			    use-tunnel (make-default t))
  "Well, slightly more secure I guess. Requires that an option file
exists containing connection-spec s-expressions. If no such file
exists a skeleton file can be created by calling
make-db-option-file (the password still needs to be added
manually). The path is ~/.amuse.lisp.

A better approach might be to use something like:
http://www.cliki.net/trivial-configuration-parser. Or for slime to
prompt the user for the password something
like (swank::eval-in-emacs `(read-passwd \"Password: \")). However,
this presents other security issues.

If use-tunnel is t, then regardless of the host specified in the
connection-spec, it will be set to localhost. It is assumed that the
tunnel is already set up.

When make-default is t, the newly created connection is assigned to
*amuse-database*. If make-default is nil, then the connection is
returned and is expected to be handled by the caller. This is useful
for connecting to different databases within individual
implementations (mainly for testing purposes)."
  (if (and make-default
	   *amuse-database*
	   (clsql-mysql::is-database-open *amuse-database*))
      (error "A default AMuSE database connection already exists:
~S" (clsql:database-name *amuse-database*))
      (let ((connection-spec (%get-connection-spec database-name
						   username)))
	(when use-tunnel
	  (setf (car connection-spec) "127.0.0.1"))
	(let ((connection (%get-database-connection connection-spec)))
	  (when make-default
	    (setf *amuse-database* connection))
	  connection))))

(defun disconnect-from-database (&optional (database-connection
					    *amuse-database*))
  (clsql:disconnect :database database-connection))

(defun make-db-option-file (&key database-name host username (port "3306"))
  (with-open-file (stream (%make-db-option-file-pathname) :direction :output)
    (sb-ext:run-program "chmod"
			(list "600" (namestring
				     (%make-db-option-file-pathname)))
			:search t)
    (princ "
;;; Option file containing connection-spec s-expressions for connecting
;;; to a database from within AMuSE. You can have multiple specifications,
;;; but they must be uniquely identifiable by database name or a combination
;;; of database and username.

;;; You need to fill in the missing <details>." stream)
    (format stream "~2%(~S ~S ~S \"<pwd>\" ~S)"
	    (if host host "<host>")
	    (if database-name database-name "<db-name>")
	    (if username username "<username>")
	    port))
  (warn "You now need to manually edit ~A."
	(namestring (%make-db-option-file-pathname))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Helper functions

(defun %get-database-connection (connection-spec)
  (clsql:connect connection-spec
		 :if-exists :old
		 :database-type :mysql))

(defun %get-connection-spec (db-name username)
  (let ((option-file (probe-file (%make-db-option-file-pathname))))
    (if option-file
	(with-open-file (stream option-file)
	  (loop for connection-spec = (read stream nil)
	     while connection-spec
	     do (destructuring-bind (host db usr pwd prt)
		    connection-spec
		  (declare (ignore host pwd prt))
		  (when (equal db-name db)
		    (when (or (null username)
			      (equal username usr))
		      (return connection-spec))))
	     finally (error "No connection-spec exists matching
database: ~A and username: ~A" db-name username)))
	;; If file doesn't exist, create it.
	(error "~A option file does not exist.
You need to run: amuse-database-admin:make-db-option-file."
	       (namestring (%make-db-option-file-pathname))))))

(defun %make-db-option-file-pathname ()
  (merge-pathnames (user-homedir-pathname) ".amuse.lisp"))