guile-squee/squee/squee.scm

;;; squee --- A guile interface to postgres via the ffi

;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;; 
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (squee squee)
  #:use-module (system foreign)
  #:use-module (rnrs enums)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-26)
  #:use-module (squee enum)
  
  #:export (;; The important ones
            connect-to-postgres-paramstring
            exec-query

            ;; Connection stuff
            <pg-conn> pg-conn? wrap-pg-conn unwrap-pg-conn
            
            ;; @@: We don't export the result pointer though!
            ;;   as this needs to be cleared to avoid memory
            ;;   leaks...
            ;;
            ;;   We might provide a (exec-with-result-ptr)
            ;;   that cleans up the result pointer after calling
            ;;   some thunk though?
            ;;
            ;;   These are still useful for building your own
            ;;   serializer though...
            result-num-rows result-num-cols result-get-value
            result-serializer-simple-list result-metadata))


(define %libpq (dynamic-link "libpq"))


(define-wrapped-pointer-type <pg-conn>
  pg-conn?
  wrap-pg-conn unwrap-pg-conn
  (lambda (pg-conn port)
    (format port "#<pg-conn ~x (~a)>"
            (pointer-address (unwrap-pg-conn pg-conn))
            (let ((status (pg-conn-status pg-conn)))
              (cond ((eq? status (conn-status-enum-index 'connection-ok))
                     "connected")
                    ((eq? status (conn-status-enum-index 'connection-bad))
                     (let ((conn-error (pg-conn-error-message pg-conn)))
                       (if (equal? conn-error "")
                           "disconnected"
                           (format #f "disconnected, error: ~s" conn-error))))
                    (#t
                     (symbol->string
                      (pg-conn-status-symbol pg-conn))))))))


;; This one should NOT be exposed to the outside world!  We have our
;; own result structure...

(define-wrapped-pointer-type <result-ptr>
  result-ptr?
  wrap-result-ptr unwrap-result-ptr
  (lambda (result-ptr port)
    (format port "#<result-ptr ~x>"
            (pointer-address (unwrap-result-ptr result-ptr)))))

(define-syntax-rule (define-foreign-libpq name return_type func_name arg_types)
  (define name
    (pointer->procedure return_type
                        (dynamic-func func_name %libpq)
                        arg_types)))


(define-foreign-libpq %PQconnectdb '* "PQconnectdb" (list '*))
(define-foreign-libpq %PQstatus int "PQstatus" (list '*))
(define-foreign-libpq %PQerrorMessage '* "PQerrorMessage" (list '*))
(define-foreign-libpq %PQfinish void "PQfinish" (list '*))
(define-foreign-libpq %PQntuples int "PQntuples" (list '*))
(define-foreign-libpq %PQnfields int "PQnfields" (list '*))


(define-foreign-libpq %PQexecParams
  '*  ;; Returns a PGresult
  "PQexecParams"
  (list '* ;; connection
        '* ;; command, a string
        int ;; number of parameters
        '* ;; paramTypes, ok to leave NULL
        '* ;; paramValues, here goes your actual parameters!
        '* ;; paramLengths, ok to leave NULL
        '* ;; paramFormats, ok to leave NULL
        int)) ;; resultFormat... probably 0!

(define-foreign-libpq %PQresultStatus int "PQresultStatus" (list '*))
(define-foreign-libpq %PQresStatus '* "PQresStatus" (list int))
(define-foreign-libpq %PQresultErrorMessage '* "PQresultErrorMessage" (list '*))
(define-foreign-libpq %PQclear void "PQclear" (list '*))

(define-foreign-libpq %PQntuples int "PQntuples" (list '*))
(define-foreign-libpq %PQnfields int "PQnfields" (list '*))
(define-foreign-libpq %PQgetvalue '* "PQgetvalue" (list '* int int))


;; Via mark_weaver.  Thanks Mark!
;;
;; So, apparently we can use a struct of strings just like an array
;; of strings.  Because magic, and because Mark thinks the C standard
;; allows it enough!

(define (string-list->string-array ls)
  "Take a list of strings, generate a C-compatible list of free strings"
  (make-c-struct
   (make-list (+ 1 (length ls)) '*)
   (append (map string->pointer ls)
           (list %null-pointer))))

(define (pg-conn-status pg-conn)
  "Get the connection status from a postgres connection"
  (%PQstatus (unwrap-pg-conn pg-conn)))

(define (pg-conn-status-symbol pg-conn)
  "Human readable version of the pg-conn status.

Inefficient... don't use this in normal code... it's just for you and
the REPL!  (Well, we do use it for errors, because those are
comparatively \"rare\" so this is okay.)  Compare against the enum
value of the symbol instead."
  (let ((status (pg-conn-status pg-conn)))
    (if (< status (length (enum-set->list conn-status-enum)))
        (enum-set-ref conn-status-enum
                (pg-conn-status pg-conn))
        ;; Weird, this is bigger than our enum of statuses
        (string->symbol
         (format #f "unknown-status-~a" status)))))


(define (pg-conn-error-message pg-conn)
  "Get an error message for this connection"
  (pointer->string (%PQerrorMessage (unwrap-pg-conn pg-conn))))


(define (pg-conn-finish pg-conn)
  "Close out a database connection.

If the connection is already closed, this simply returns #f."
  (if (eq? (pg-conn-status pg-conn)
           (conn-status-enum-index 'connection-ok))
      (begin
        (%PQfinish (unwrap-pg-conn pg-conn))
        #t)
      #f))

(define (connect-to-postgres-paramstring paramstring)
  "Open a connection to the database via a parameter string"
  (let* ((conn-pointer (%PQconnectdb (string->pointer paramstring)))
         (pg-conn (wrap-pg-conn conn-pointer)))
    (if (eq? conn-pointer %null-pointer)
        (throw 'psql-connect-error
               #f "Unable to establish connection"))
    (let ((status (pg-conn-status pg-conn)))
      (if (eq? status (conn-status-enum-index 'connection-ok))
          pg-conn
          (throw 'psql-connect-error
                (enum-set-ref conn-status-enum status)
                (pg-conn-error-message pg-conn))))))


(define (result-num-rows result-ptr)
  (%PQntuples (unwrap-result-ptr result-ptr)))

(define (result-num-cols result-ptr)
  (%PQnfields (unwrap-result-ptr result-ptr)))

(define (result-get-value result-ptr row col)
  (pointer->string
   (%PQgetvalue (unwrap-result-ptr result-ptr) row col)))


;; @@: We ought to also have a vector version...
;;     and other serializations...
(define (result-serializer-simple-list result-ptr)
  "Get a simple list of lists representing the result of the query"
  (let ((rows-range (iota (result-num-rows result-ptr)))
        (cols-range (iota (result-num-cols result-ptr))))
    (map
     (lambda (row-i)
       (map
        (lambda (col-i)
          (result-get-value result-ptr row-i col-i))
        cols-range))
     rows-range)))

;; TODO
(define (result-metadata result-ptr)
  #f)


(define (result-ptr-clear result-ptr)
  (%PQclear (unwrap-result-ptr result-ptr)))

(define (result-error-message result-ptr)
  (%PQresultErrorMessage (unwrap-result-ptr result-ptr)))


(define* (exec-query pg-conn command #:optional (params '())
                     #:key (serializer result-serializer-simple-list))
  (let ((result-ptr
         (wrap-result-ptr
          (%PQexecParams
           (unwrap-pg-conn pg-conn)
           (string->pointer command)
           (length params)
           %null-pointer
           (string-list->string-array params)
           %null-pointer %null-pointer 0))))
    (if (eq? result-ptr %null-pointer)
        ;; Presumably a database connection issue...
        (throw 'psql-query-error
               ;; See below for psql-query-error param definition
               #f #f (pg-conn-error-message pg-conn)))

    (let ((status (%PQresultStatus (unwrap-result-ptr result-ptr))))
      (cond
       ;; This is the kind of query that returns tuples
       ((eq? status (exec-status-enum-index 'tuples-ok))
        (let ((serialized-result (serializer result-ptr))
              (metadata (result-metadata result-ptr)))
          ;; Gotta clear the result to prevent memory leaks
          (result-ptr-clear result-ptr)
          (values serialized-result metadata)))

       ;; This doesn't return tuples, eg it's a DELETE or something.
       ((eq? status (exec-status-enum-index 'command-ok))
        (let ((metadata (result-metadata result-ptr)))
          ;; Gotta clear the result to prevent memory leaks 
          (result-ptr-clear result-ptr)
          ;; Just return #t if there's no tuples to look at
          (values #t metadata)))

       ;; Uhoh, anything else is an error!
       (#t
        (let ((status-message (pointer->string (%PQresStatus status)))
              (error-message (pointer->string
                              (%PQresultErrorMessage (unwrap-result-ptr
                                                      result-ptr)))))
          (result-ptr-clear result-ptr)
          (throw 'psql-query-error
                 ;; @@: Do we need result-status?
                 ;; (error-symbol result-status result-error-message)
                 (enum-set-ref exec-status-enum status)
                 status-message error-message)))))))

;; (define conn (connect-to-postgres-paramstring "dbname=sandbox"))