diff --git a/src/package.lisp b/src/package.lisp index 2ce701b..c6c72ce 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -100,6 +100,7 @@ #:format-interval #:camelCase-to-colname #:unquote + #:expand-user-homedir-pathname ;; threads #:make-kernel diff --git a/src/pgsql/queries.lisp b/src/pgsql/queries.lisp index 07b8e3d..1ab8228 100644 --- a/src/pgsql/queries.lisp +++ b/src/pgsql/queries.lisp @@ -22,6 +22,10 @@ (pgconn-table-name clone) (pgconn-table-name c)) clone)) +(defmethod ssl-enable-p ((pgconn pgsql-connection)) + "Return non-nil when the connection uses SSL" + (member (pgconn-use-ssl pgconn) '(:try :yes))) + (defun new-pgsql-connection (pgconn) "Prepare a new connection object with all the same properties as pgconn, so as to avoid stepping on it's handle" @@ -34,6 +38,16 @@ :use-ssl (pgconn-use-ssl pgconn) :table-name (pgconn-table-name pgconn))) +;;; +;;; Implement SSL Client Side certificates +;;; http://www.postgresql.org/docs/current/static/libpq-ssl.html#LIBPQ-SSL-FILE-USAGE +;;; +(defvar *pgsql-client-certificate* "~/.postgresql/postgresql.crt" + "File where to read the PostgreSQL Client Side SSL Certificate.") + +(defvar *pgsql-client-key* "~/.postgresql/postgresql.key" + "File where to read the PostgreSQL Client Side SSL Private Key.") + ;;; ;;; We need to distinguish some special cases of PostgreSQL errors within ;;; Class 53 — Insufficient Resources: in case of "too many connections" we @@ -58,25 +72,33 @@ (defmethod open-connection ((pgconn pgsql-connection) &key username) "Open a PostgreSQL connection." - (flet ((connect (pgconn username) - (handler-case - (pomo:connect (db-name pgconn) - (or username (db-user pgconn)) - (db-pass pgconn) - (let ((host (db-host pgconn))) - (if (and (consp host) (eq :unix (car host))) - :unix - host)) - :port (db-port pgconn) - :use-ssl (or (pgconn-use-ssl pgconn) :no)) - ((or too-many-connections configuration-limit-exceeded) (e) - (log-message :error - "Failed to connect to ~a: ~a; will try again in ~fs" - pgconn e *retry-connect-delay*) - (sleep *retry-connect-delay*))))) - (loop :while (null (conn-handle pgconn)) - :repeat *retry-connect-times* - :do (setf (conn-handle pgconn) (connect pgconn username)))) + (let* ((crt-file (expand-user-homedir-pathname *pgsql-client-certificate*)) + (key-file (expand-user-homedir-pathname *pgsql-client-key*)) + (pomo::*ssl-certificate-file* (when (and (ssl-enable-p pgconn) + (probe-file crt-file)) + crt-file)) + (pomo::*ssl-key-file* (when (and (ssl-enable-p pgconn) + (probe-file key-file)) + key-file))) + (flet ((connect (pgconn username) + (handler-case + (pomo:connect (db-name pgconn) + (or username (db-user pgconn)) + (db-pass pgconn) + (let ((host (db-host pgconn))) + (if (and (consp host) (eq :unix (car host))) + :unix + host)) + :port (db-port pgconn) + :use-ssl (or (pgconn-use-ssl pgconn) :no)) + ((or too-many-connections configuration-limit-exceeded) (e) + (log-message :error + "Failed to connect to ~a: ~a; will try again in ~fs" + pgconn e *retry-connect-delay*) + (sleep *retry-connect-delay*))))) + (loop :while (null (conn-handle pgconn)) + :repeat *retry-connect-times* + :do (setf (conn-handle pgconn) (connect pgconn username))))) (unless (conn-handle pgconn) (error "Failed ~d times to connect to ~a" *retry-connect-times* pgconn)) pgconn) diff --git a/src/utils/utils.lisp b/src/utils/utils.lisp index 98b8171..b95c3da 100644 --- a/src/utils/utils.lisp +++ b/src/utils/utils.lisp @@ -33,3 +33,24 @@ (if (char= quote (aref string 0) (aref string (1- l))) (subseq string 1 (1- l)) string)))) + +;;; +;;; Process ~/ references at run-time (not at compile time!) +;;; +(defun expand-user-homedir-pathname (namestring) + "Expand NAMESTRING replacing leading ~ with (user-homedir-pathname)" + (typecase namestring + (pathname namestring) + (string + (cond ((or (string= "~" namestring) (string= "~/" namestring)) + (user-homedir-pathname)) + + ((and (<= 2 (length namestring)) + (char= #\~ (aref namestring 0)) + (char= #\/ (aref namestring 1))) + (uiop:merge-pathnames* + (uiop:parse-unix-namestring (subseq namestring 2)) + (user-homedir-pathname))) + + (t + (uiop:parse-unix-namestring namestring))))))