[racket] DB and named query parameters

Hello,

Ok it's a bit off topic, i was asking myself how much effort it could take to
make some sql statement typecheck at expansion time.

It takes me 1h30 to do this code, so it seem possible for you to do a subset of
sql that fit your project.

The main defect i see is the parser couldn't not take into account specific
Database sql. So other is it will take some work :).


#lang racket

(require parser-tools/yacc
         parser-tools/lex
         (prefix-in : parser-tools/lex-sre))

(module+ test
  (require rackunit))

(define-empty-tokens op-tokens
  (SELECT WHERE LIKE FROM ASTERISK BLANKS EOF LESS GREAT LESS-EQUAL GREAT-EQUAL COMMA EQUAL))

(define-tokens value-tokens
  (NAME PARAM NUMBER STRING))

(define (tokenize-string quote-char input-port)
  (define (recur data)
    (define read/c (read-char input-port))
    (cond
     [(eof-object? read/c) data]
     [(equal? #\\ read/c) (recur (string-append data (string read/c)
					   (string (read-char input-port))))]
     [(equal? quote-char read/c) (string-append data (string read/c))]
     [else (recur (string-append data (string read/c)))]))
  (recur ""))

(define sql-lexer
  (lexer-src-pos
   ["select" 'SELECT]
   ["SELECT" 'SELECT]
   ["where" 'WHERE]
   ["WHERE" 'WHERE]
   ["like" 'LIKE]
   ["LIKE" 'LIKE]
   ["from" 'FROM]
   ["FROM" 'FROM]
   ["*" 'ASTERISK]
   ["=" 'EQUAL]
   ["<" 'LESS]
   ["<=" 'LESS-EQUAL]
   [">" 'GREAT] 
   [">=" 'GREAT-EQUAL]
   [#\, 'COMMA]
   [(:or #\space #\tab #\newline "\r") 'BLANKS]
   [(:: #\$ (:+ (:or (:/ #\0 #\9) (:/ #\a #\z) (:/ #\A #\Z) #\- #\_))) (token-PARAM lexeme)]
   [(:+ (:or (:/ #\a #\z) (:/ #\A #\Z) #\- #\_)) (token-NAME lexeme)]
   [(:: #\" (:+ (:or (:/ #\a #\z) (:/ #\A #\Z) #\- #\_)) #\") (token-NAME lexeme)]
   [(:+ (:/ #\0 #\9)) (token-NUMBER (string->number lexeme))]
   [#\' (let ([data (tokenize-string #\' input-port)])
	  (token-STRING (string-append "'" data)))]
   [(eof) 'EOF]))

(define (lexer-thunk input-port)
  (port-count-lines! input-port)
  (define (this)
    (let ([token (sql-lexer input-port)])
      (if (equal? (position-token-token token) 'BLANKS)
          (this)
          token)))
    this)

(module+ test
  (define (input-port->list-token input-port #:blanks? [blanks? #f])
    (let loop ([tokens '()])
      (let ([token (sql-lexer input-port)])
        (case (position-token-token token)
          [(EOF) (reverse tokens)]
          [(BLANKS) 
           (loop
            (if blanks?
                (cons token tokens)
                tokens))]
          [else
           (loop (cons token tokens))]))))
  
  (let ([data (input-port->list-token (open-input-string "SELECT * FROM my_table"))])
    (check-equal? (position-token-token (first data)) 'SELECT)
    (check-equal? (position-token-token (second data)) 'ASTERISK)
    (check-equal? (position-token-token (third data)) 'FROM)
    (check-equal? (token-name (position-token-token (fourth data))) 'NAME)))
    
(struct WhereExpr (op left right) #:transparent)

;; projection list? or 'all
(struct SelectStmt (projection table where) #:transparent)


(define sql-parser
  (parser
   (src-pos)
   (start select-statement)
   (end EOF)
   
   (tokens value-tokens op-tokens)
   
   (error (lambda x (print x)))
  
   (grammar
    (select-statement
     [(SELECT ASTERISK FROM NAME) (SelectStmt 'all $4 #f)]
     [(SELECT ASTERISK FROM NAME WHERE where-expr) (SelectStmt 'all $4 $6)]
     [(SELECT project-list FROM NAME) (SelectStmt $2 $4 #f)]
     [(SELECT project-list FROM NAME WHERE where-expr) (SelectStmt $2 $4 $6)])
             
    (project-list
     [(NAME) (list $1)]
     [(NAME COMMA project-list) (cons $1 $3)])
                
    (where-expr
     [(NAME where-op PARAM) (WhereExpr $2 $1 $3)]
     [(NAME LIKE STRING) (WhereExpr 'LIKE $1 $3)]
     [(NAME where-op-number NUMBER) (WhereExpr $2 $1 $3)])
    
    (where-op
     [(LIKE) 'LIKE]
     [(where-op-number) $1])
    
    (where-op-number
     [(EQUAL) 'EQUAL]
     [(LESS) 'LESS]
     [(LESS-EQUAL) 'LESS-EQUAL]
     [(GREAT) 'GREAT] 
     [(GREAT-EQUAL) 'GREAT-EQUAL]))))


(define schema
  (hash "house" (hash "nb_door" number? "owner" string?)
        "car" (hash "horse_power" number? "make"  string?)))

(define (schema-field-pred table field)
  (define fields (hash-ref schema table #f))
  (and fields
       (hash-ref fields field #f)))

(define (sql str)
  (define parsed 
    (let ([oip (open-input-string str)])
      (begin0
        (sql-parser (lexer-thunk oip))
        (close-input-port oip))))
  (define where (SelectStmt-where parsed))
  (define pred
    (and where
	 (schema-field-pred (SelectStmt-table parsed)
			    (WhereExpr-left where))))
  (if pred
      (lambda (param)
            (when (not (pred param))
	      (raise "Don't match the condition"))
	    str)
      (lambda ()
	str)))
                    
(define my-query (sql "SELECT * FROM house WHERE nb_door = $nb"))

(my-query 12) ; => SELECT * FROM house WHERE nb_door = $nb
(my-query "abc") ; => exception: "Don't match the condition"