squee.scm 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345
  1. ;;; squee --- A guile interface to postgres via the ffi
  2. ;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
  3. ;; This library is free software; you can redistribute it and/or
  4. ;; modify it under the terms of the GNU Lesser General Public
  5. ;; License as published by the Free Software Foundation; either
  6. ;; version 3 of the License, or (at your option) any later version.
  7. ;;
  8. ;; This library is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this library; if not, write to the Free Software
  15. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. (define-module (squee)
  17. #:use-module (system foreign)
  18. #:use-module (rnrs enums)
  19. #:use-module (ice-9 match)
  20. #:use-module (ice-9 format)
  21. #:use-module (srfi srfi-26)
  22. #:export (;; The important ones
  23. connect-to-postgres-paramstring
  24. exec-query
  25. ;; enums and indexes of enums
  26. conn-status-enum conn-status-enum-index
  27. polling-status-enum polling-status-index
  28. exec-status-enum exec-status-enum-index
  29. transaction-status-enum transaction-status-enum-index
  30. verbosity-enum verbosity-enum-index
  31. ping-enum ping-enum-index
  32. ;; **repl and error messages only!**
  33. enum-set-ref
  34. ;; Connection stuff
  35. <pg-conn> pg-conn? wrap-pg-conn unwrap-pg-conn
  36. ;; @@: We don't export the result pointer though!
  37. ;; as this needs to be cleared to avoid memory
  38. ;; leaks...
  39. ;;
  40. ;; We might provide a (exec-with-result-ptr)
  41. ;; that cleans up the result pointer after calling
  42. ;; some thunk though?
  43. ;;
  44. ;; These are still useful for building your own
  45. ;; serializer though...
  46. result-num-rows result-num-cols result-get-value
  47. result-serializer-simple-list result-metadata))
  48. (define libpq (dynamic-link "libpq"))
  49. ;; ---------------------
  50. ;; Enums from libpq-fe.h
  51. ;; ---------------------
  52. (define conn-status-enum
  53. (make-enumeration
  54. '(connection-ok
  55. connection-bad
  56. connection-started connection-made
  57. connection-awaiting-response connection-auth-ok
  58. connection-auth-ok connection-setenv
  59. connection-ssl-startup
  60. connection-needed)))
  61. (define conn-status-enum-index
  62. (enum-set-indexer conn-status-enum))
  63. (define polling-status-enum
  64. (make-enumeration
  65. '(polling-failed
  66. polling-reading
  67. polling-writing
  68. polling-ok
  69. polling-active)))
  70. (define polling-status-enum-index
  71. (enum-set-indexer polling-status-enum))
  72. (define exec-status-enum
  73. (make-enumeration
  74. '(empty-query
  75. command-ok tuples-ok
  76. copy-out copy-in
  77. bad-response
  78. nonfatal-error fatal-error
  79. copy-both
  80. single-tuple)))
  81. (define exec-status-enum-index
  82. (enum-set-indexer exec-status-enum))
  83. (define transaction-status-enum
  84. (make-enumeration
  85. '(idle active intrans inerror unknown)))
  86. (define transaction-status-enum-index
  87. (enum-set-indexer transaction-status-enum))
  88. (define verbosity-enum
  89. (make-enumeration
  90. '(terse default verbose)))
  91. (define verbosity-enum-index
  92. (enum-set-indexer verbosity-enum))
  93. (define ping-enum
  94. (make-enumeration
  95. '(ok reject no-response no-attempt)))
  96. (define ping-enum-index
  97. (enum-set-indexer ping-enum))
  98. (define-wrapped-pointer-type <pg-conn>
  99. pg-conn?
  100. wrap-pg-conn unwrap-pg-conn
  101. (lambda (pg-conn port)
  102. (format port "#<pg-conn ~x (~a)>"
  103. (pointer-address (unwrap-pg-conn pg-conn))
  104. (let ((status (pg-conn-status pg-conn)))
  105. (cond ((eq? status (conn-status-enum-index 'connection-ok))
  106. "connected")
  107. ((eq? status (conn-status-enum-index 'connection-bad))
  108. (let ((conn-error (pg-conn-error-message pg-conn)))
  109. (if (equal? conn-error "")
  110. "disconnected"
  111. (format #f "disconnected, error: ~s" conn-error))))
  112. (#t
  113. (symbol->string
  114. (pg-conn-status-symbol pg-conn))))))))
  115. ;; This one should NOT be exposed to the outside world! We have our
  116. ;; own result structure...
  117. (define-wrapped-pointer-type <result-ptr>
  118. result-ptr?
  119. wrap-result-ptr unwrap-result-ptr
  120. (lambda (result-ptr port)
  121. (format port "#<result-ptr ~x>"
  122. (pointer-address (unwrap-result-ptr result-ptr)))))
  123. (define (enum-set-ref enum-set k)
  124. "Take an ENUM-SET and get the item at position K
  125. This is O(n) but theoretically we don't use it much.
  126. Again, REPL only!"
  127. (list-ref (enum-set->list enum-set) k))
  128. (define-syntax-rule (define-foreign-libpq name return_type func_name arg_types)
  129. (define name
  130. (pointer->procedure return_type
  131. (dynamic-func func_name libpq)
  132. arg_types)))
  133. (define-foreign-libpq %PQconnectdb '* "PQconnectdb" (list '*))
  134. (define-foreign-libpq %PQstatus int "PQstatus" (list '*))
  135. (define-foreign-libpq %PQerrorMessage '* "PQerrorMessage" (list '*))
  136. (define-foreign-libpq %PQfinish void "PQfinish" (list '*))
  137. (define-foreign-libpq %PQntuples int "PQntuples" (list '*))
  138. (define-foreign-libpq %PQnfields int "PQnfields" (list '*))
  139. (define-foreign-libpq %PQexecParams
  140. '* ;; Returns a PGresult
  141. "PQexecParams"
  142. (list '* ;; connection
  143. '* ;; command, a string
  144. int ;; number of parameters
  145. '* ;; paramTypes, ok to leave NULL
  146. '* ;; paramValues, here goes your actual parameters!
  147. '* ;; paramLengths, ok to leave NULL
  148. '* ;; paramFormats, ok to leave NULL
  149. int)) ;; resultFormat... probably 0!
  150. (define-foreign-libpq %PQresultStatus int "PQresultStatus" (list '*))
  151. (define-foreign-libpq %PQresStatus '* "PQresStatus" (list int))
  152. (define-foreign-libpq %PQresultErrorMessage '* "PQresultErrorMessage" (list '*))
  153. (define-foreign-libpq %PQclear void "PQclear" (list '*))
  154. (define-foreign-libpq %PQntuples int "PQntuples" (list '*))
  155. (define-foreign-libpq %PQnfields int "PQnfields" (list '*))
  156. (define-foreign-libpq %PQgetvalue '* "PQgetvalue" (list '* int int))
  157. ;; Via mark_weaver. Thanks Mark!
  158. ;;
  159. ;; So, apparently we can use a struct of strings just like an array
  160. ;; of strings. Because magic, and because Mark thinks the C standard
  161. ;; allows it enough!
  162. (define (string-list->string-array ls)
  163. "Take a list of strings, generate a C-compatible list of free strings"
  164. (make-c-struct
  165. (make-list (+ 1 (length ls)) '*)
  166. (append (map string->pointer ls)
  167. (list %null-pointer))))
  168. (define (pg-conn-status pg-conn)
  169. "Get the connection status from a postgres connection"
  170. (%PQstatus (unwrap-pg-conn pg-conn)))
  171. (define (pg-conn-status-symbol pg-conn)
  172. "Human readable version of the pg-conn status.
  173. Inefficient... don't use this in normal code... it's just for you and
  174. the REPL! (Well, we do use it for errors, because those are
  175. comparatively \"rare\" so this is okay.) Compare against the enum
  176. value of the symbol instead."
  177. (let ((status (pg-conn-status pg-conn)))
  178. (if (< status (length (enum-set->list conn-status-enum)))
  179. (enum-set-ref conn-status-enum
  180. (pg-conn-status pg-conn))
  181. ;; Weird, this is bigger than our enum of statuses
  182. (string->symbol
  183. (format #f "unknown-status-~a" status)))))
  184. (define (pg-conn-error-message pg-conn)
  185. "Get an error message for this connection"
  186. (pointer->string (%PQerrorMessage (unwrap-pg-conn pg-conn))))
  187. (define (pg-conn-finish pg-conn)
  188. "Close out a database connection.
  189. If the connection is already closed, this simply returns #f."
  190. (if (eq? (pg-conn-status pg-conn)
  191. (conn-status-enum-index 'connection-ok))
  192. (begin
  193. (%PQfinish (unwrap-pg-conn pg-conn))
  194. #t)
  195. #f))
  196. (define (connect-to-postgres-paramstring paramstring)
  197. "Open a connection to the database via a parameter string"
  198. (let* ((conn-pointer (%PQconnectdb (string->pointer paramstring)))
  199. (pg-conn (wrap-pg-conn conn-pointer)))
  200. (if (eq? conn-pointer %null-pointer)
  201. (throw 'psql-connect-error
  202. #f "Unable to establish connection"))
  203. (let ((status (pg-conn-status pg-conn)))
  204. (if (eq? status (conn-status-enum-index 'connection-ok))
  205. pg-conn
  206. (throw 'psql-connect-error
  207. (enum-set-ref conn-status-enum status)
  208. (pg-conn-error-message pg-conn))))))
  209. (define (result-num-rows result-ptr)
  210. (%PQntuples (unwrap-result-ptr result-ptr)))
  211. (define (result-num-cols result-ptr)
  212. (%PQnfields (unwrap-result-ptr result-ptr)))
  213. (define (result-get-value result-ptr row col)
  214. (pointer->string
  215. (%PQgetvalue (unwrap-result-ptr result-ptr) row col)))
  216. ;; @@: We ought to also have a vector version...
  217. ;; and other serializations...
  218. (define (result-serializer-simple-list result-ptr)
  219. "Get a simple list of lists representing the result of the query"
  220. (let ((rows-range (iota (result-num-rows result-ptr)))
  221. (cols-range (iota (result-num-cols result-ptr))))
  222. (map
  223. (lambda (row-i)
  224. (map
  225. (lambda (col-i)
  226. (result-get-value result-ptr row-i col-i))
  227. cols-range))
  228. rows-range)))
  229. ;; TODO
  230. (define (result-metadata result-ptr)
  231. #f)
  232. (define (result-ptr-clear result-ptr)
  233. (%PQclear (unwrap-result-ptr result-ptr)))
  234. (define (result-error-message result-ptr)
  235. (%PQresultErrorMessage (unwrap-result-ptr result-ptr)))
  236. (define* (exec-query pg-conn command #:optional (params '())
  237. #:key (serializer result-serializer-simple-list))
  238. (let ((result-ptr
  239. (wrap-result-ptr
  240. (%PQexecParams
  241. (unwrap-pg-conn pg-conn)
  242. (string->pointer command)
  243. (length params)
  244. %null-pointer
  245. (string-list->string-array params)
  246. %null-pointer %null-pointer 0))))
  247. (if (eq? result-ptr %null-pointer)
  248. ;; Presumably a database connection issue...
  249. (throw 'psql-query-error
  250. ;; See below for psql-query-error param definition
  251. #f #f (pg-conn-error-message pg-conn)))
  252. (let ((status (%PQresultStatus (unwrap-result-ptr result-ptr))))
  253. (cond
  254. ;; This is the kind of query that returns tuples
  255. ((eq? status (exec-status-enum-index 'tuples-ok))
  256. (let ((serialized-result (serializer result-ptr))
  257. (metadata (result-metadata result-ptr)))
  258. ;; Gotta clear the result to prevent memory leaks
  259. (result-ptr-clear result-ptr)
  260. (values serialized-result metadata)))
  261. ;; This doesn't return tuples, eg it's a DELETE or something.
  262. ((eq? status (exec-status-enum-index 'command-ok))
  263. (let ((metadata (result-metadata result-ptr)))
  264. ;; Gotta clear the result to prevent memory leaks
  265. (result-ptr-clear result-ptr)
  266. ;; Just return #t if there's no tuples to look at
  267. (values #t metadata)))
  268. ;; Uhoh, anything else is an error!
  269. (#t
  270. (let ((status-message (pointer->string (%PQresStatus status)))
  271. (error-message (pointer->string
  272. (%PQresultErrorMessage (unwrap-result-ptr
  273. result-ptr)))))
  274. (result-ptr-clear result-ptr)
  275. (throw 'psql-query-error
  276. ;; @@: Do we need result-status?
  277. ;; (error-symbol result-status result-error-message)
  278. (enum-set-ref exec-status-enum status)
  279. status-message error-message)))))))
  280. ;; (define conn (connect-to-postgres-paramstring "dbname=sandbox"))