#lang scheme/unit
(require srfi/13
srfi/19
(only-in srfi/43 vector-map)
(planet schematics/spgsql:2/spgsql)
(planet untyped/unlib:3/time)
"../base.ss"
"../era/era.ss"
"../generic/sql-data-sig.ss")
(import)
(export sql-data^)
(define (escape-value type value)
(define (date-to-string str)
(string-append "'" (string-pad (date->string str "~Y-~m-~d ~H:~M:~S.~N") 29 #\0) "'"))
(cond [(boolean-type? type) (guard value boolean? "boolean") (if value "true" "false")]
[(not value) "NULL"]
[(guid-type? type) (guard value guid? "(U guid #f)") (if (eq? (guid-entity value) (guid-type-entity type))
(number->string (guid-id value))
(raise-exn exn:fail:contract
(format "Could not escape value for SQL: wrong GUID entity: expected ~a, received ~a."
(entity-name (guid-entity value))
(entity-name (guid-type-entity type)))))]
[(integer-type? type) (guard value integer? "(U integer #f)") (number->string value)]
[(real-type? type) (guard value real? "(U real #f)") (number->string value)]
[(string-type? type) (guard value string? "(U string #f)") (string-append "'" (regexp-replace* #rx"'" value "''") "'")]
[(symbol-type? type) (guard value symbol? "(U symbol #f)") (string-append "'" (regexp-replace* #rx"'" (symbol->string value) "''") "'")]
[(time-tai-type? type) (guard value time-tai? "(U time-tai #f)") (date-to-string (time-tai->date value 0))]
[(time-utc-type? type) (guard value time-utc? "(U time-utc #f)") (date-to-string (time-utc->date value 0))]
[else (raise-exn exn:fail:contract (format "Unrecognised type: ~s" type))]))
(define (parse-value type value)
(with-handlers ([exn? (lambda (exn) (raise-exn exn:fail:contract (exn-message exn)))])
(cond [(guid-type? type) (let ([id (inexact->exact value)])
(and id (make-guid (guid-type-entity type) id)))]
[(sql-null? value) #f]
[(boolean-type? type) value]
[(integer-type? type) (inexact->exact value)]
[(real-type? type) value]
[(string-type? type) value]
[(symbol-type? type) (string->symbol value)]
[(time-tai-type? type) (date->time-tai (sql-datetime->srfi-date value))]
[(time-utc-type? type) (date->time-utc (sql-datetime->srfi-date value))]
[else (raise-exn exn:fail:contract (format "Unrecognised type: ~s" type))])))
(define (make-parser type-list)
(define type-vector
(list->vector type-list))
(lambda (value-vector)
(if value-vector
(vector-map (lambda (index type val)
(parse-value type val))
type-vector
value-vector)
#f)))
(define (escape-string str)
(regexp-replace* #rx"'" str "''"))
(define-syntax guard
(syntax-rules ()
[(guard value predicate message)
(unless (predicate value)
(raise-exn exn:fail:contract
(format "Could not escape value for SQL: expected ~a, received ~s." message value)))]))