sql.ss 3.27 KB
Newer Older
Dave Griffiths's avatar
Dave Griffiths committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
#lang racket

;; MongooseWeb Copyright (C) 2013 Dave Griffiths
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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 Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(require (planet jaymccarthy/sqlite:5:1/sqlite))
(require "utils.ss")
(provide (all-defined-out))

;; tinyscheme
;(define db-select db-exec)

dave griffiths's avatar
dave griffiths committed
25 26 27 28
(define (db-exec . args) 
  (with-handlers (((lambda (x) #t) (lambda (x) (msg "error:" x))))
		 (apply exec/ignore args)))

Dave Griffiths's avatar
Dave Griffiths committed
29 30 31 32 33 34 35 36
;; racket
(define db-select select)
(define db-insert insert)
(define (db-status db) (errmsg db))
(define (time) (list (random) (random))) ; ahem

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Dave Griffiths's avatar
Dave Griffiths committed
37 38 39 40 41 42 43 44 45 46 47 48 49 50
(define (db-open db-name setup-fn)
  (cond
    ((file-exists? (string->path db-name))
     (display "open existing db")(newline)
     (open (string->path db-name)))
    (else
     (display "making new db")(newline)
     (let ((db (open (string->path db-name))))
       ;; todo, dynamically create these tables
       (setup-fn db "sync")
       (setup-fn db "stream")
       db))))


Dave Griffiths's avatar
Dave Griffiths committed
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
;; helper to return first instance from a select
(define (select-first db str . args)
  (let ((s (apply db-select (append (list db str) args))))
    (if (or (null? s) (eq? s #t))
        '()
        (vector-ref (cadr s) 0))))

;; get a unique hash for this user (used for all the unique-ids)
(define (get-unique user)
  (let ((t (time)))
    (string-append
     user "-" (number->string (car t)) ":" (number->string (cadr t)))))


;; tests...

(define (sql-test db)
  (db-exec db "create table unittest ( id integer primary key autoincrement, name varchar(256), num int, r real )")

  (define id (db-insert db "insert into unittest values (null, ?, ?, ?)" "hello" 23 1.1))
  (asserteq "sql autoinc" (+ id 1) (db-insert db "insert into unittest values (null, ?, ?, ?)" "hello2" 26 2.3))

  (let ((q (db-select db "select * from unittest")))
    (assert "sql length" (> (length q) 2)))

  (let ((q (db-select db "select * from unittest where id = ?" id)))
    (asserteq "sql select one" (length q) 2)
    (assert "sql select two" (vector? (car q)))
    (asserteq "sql select 3" (vector-ref (cadr q) 2) 23)
    (assert "sql select 4" (feq (vector-ref (cadr q) 3) 1.1)))

  (db-exec db "update unittest set name=? where id = ?" "bob" id)

  (let ((q (db-select db "select * from unittest where id = ?" id)))
    (asserteq "sql update" (vector-ref (cadr q) 1) "bob"))

  (db-exec db "update unittest set name=? where id = ?" "Robert'); DROP TABLE unittest;--" id)

  (let ((q (db-select db "select * from unittest where id = ?" id)))
    (asserteq "bobby tables sql injection" (vector-ref (cadr q) 1) "Robert'); DROP TABLE unittest;--"))

  (asserteq "select first" (select-first db "select name from unittest where id = ?" (+ id 1))
            "hello2")

  )