(define-module(database postgres-types)#:export(oid-type-name-cache type-registered? type-stringifier type-default type-objectifier type-sql-name define-db-col-type register-array-variant)#:use-module((srfi srfi-13)#:select(string-prefix? substring/shared string-concatenate-reverse string-take))#:autoload(database postgres)(pg-exec))
(define (fs s . args)(apply simple-format #f s args))
(define o/t(make-object-property))
(define (oid-type-name-cache conn . opt)(define(fresh)(let((res(pg-exec conn "SELECT oid,typname FROM pg_type;")))(and(eq?  'PGRES_TUPLES_OK(pg-result-status res))(let loop((n(#{1-}#(pg-ntuples res)))(acc '()))(if(> 0 n)acc(loop(#{1-}# n)(acons(string->number(pg-getvalue res n 0))(pg-getvalue res n 1)acc)))))))(define(fresh!)(let((alist(fresh)))(set!(o/t conn)alist)alist))(cond((and(not(null? opt))(car opt))(fresh!))((o/t conn))(else(fresh!))))
(define ALL(make-hash-table))
(define ARRAY-VARIANT-INFO(make-hash-table))
(define(av-lookup symbol)(hashq-ref ARRAY-VARIANT-INFO symbol))
(define(make-array-variant-info sql-name rank simple canonical-name)(vector sql-name rank simple canonical-name))
(define(av-sql-name v)(vector-ref v 0))
(define(av-rank v)(vector-ref v 1))
(define(av-simple v)(vector-ref v 2))
(define(av-canonical v)(vector-ref v 3))
(define(tc-l-i idx)(lambda(type)(vector-ref(hashq-ref ALL(cond((av-lookup type)=> av-canonical)(else type)))idx)))
(define(type-registered? type)(->bool(hashq-get-handle ALL type)))
(define type-stringifier(tc-l-i 0))
(define type-default(tc-l-i 1))
(define type-objectifier(tc-l-i 2))
(define(type-sql-name type)(cond((av-lookup type)=> av-sql-name)(else(symbol->string type))))
(define(read-pgarray-1 objectifier port)(let((next(lambda()(peek-char port))))(let loop((c(next))(acc '()))(cond((eof-object? c)(reverse! acc))((char=? #\} c)(read-char port)(reverse! acc))((char=? #\{ c)(read-char port)(let((sub(read-pgarray-1 objectifier port)))(loop(next)(cons sub acc))))((char=? #\" c)(let((string(read port)))(loop(next)(cons(objectifier string)acc))))((char=? #\, c)(read-char port)(loop(next)acc))(else(let((o(let iloop((ic(read-char port))(iacc '()))(case ic((#\} #\,)(unread-char ic port)(objectifier(string-concatenate-reverse iacc)))(else(iloop(read-char port)(cons(string ic)iacc)))))))(loop(next)(cons o acc))))))))
(define(read-array-string objectifier string)(call-with-input-string string(lambda(port)(read-char port)(read-pgarray-1 objectifier port))))
(define(dimension->string stringifier x)(letrec((dive(lambda(ls)(list "{"(dimension->string stringifier(car ls))(map(lambda(y)(list ","(dimension->string stringifier y)))(cdr ls))"}")))(walk(lambda(x)(cond((string? x)(display x))((list? x)(for-each walk x))(else(error "bad type:" x)))))(flatten(lambda(tree)(with-output-to-string(lambda()(walk tree))))))(cond((list? x)(flatten(dive x)))((vector? x)(flatten(dive(vector->list x))))(else(stringifier x)))))
(define(dimension->string-proc stringifier)(lambda(ls/vec)(dimension->string stringifier ls/vec)))
(define(read-array-string-proc objectifier)(lambda(string)(read-array-string objectifier string)))
(define(define-db-col-type name default stringifier objectifier)(hashq-set! ALL name(vector stringifier default objectifier)))
(define (register-array-variant rank simple . procs)(define(array-variant-name)(string-append(make-string rank #\*)(symbol->string simple)))(define(sql-name)(apply string-append(symbol->string simple)(make-list rank "[]")))(or(type-registered? simple)(error "unregistered type:" simple))(let*((stringifier(and(not(null? procs))(car procs)))(objectifier(and(not(null? procs))(not(null?(cdr procs)))(cadr procs)))(name(string->symbol(array-variant-name))))(hashq-set! ARRAY-VARIANT-INFO name(make-array-variant-info(sql-name)rank simple name))(define-db-col-type name "{}"(dimension->string-proc(or stringifier(type-stringifier simple)))(read-array-string-proc(or objectifier(type-objectifier simple))))name))
(define(double-quote s)(string-append "\"" s "\""))
(define-db-col-type  'smallint "0" number->string string->number)
(define-db-col-type  'integer "0" number->string string->number)
(define-db-col-type  'bigint "0" number->string string->number)
(define-db-col-type  'int "0" number->string string->number)
(define-db-col-type  'int2 "0" number->string string->number)
(define-db-col-type  'int4 "0" number->string string->number)
(define-db-col-type  'int8 "0" number->string string->number)
(define-db-col-type  'numeric "0" number->string string->number)
(define-db-col-type  'decimal "0" number->string string->number)
(define-db-col-type  'real "0.0" number->string string->number)
(define-db-col-type  'double "0.0" number->string string->number)
(define-db-col-type  'float4 "0.0" number->string string->number)
(define-db-col-type  'float8 "0.0" number->string string->number)
(define-db-col-type  'serial "0" number->string string->number)
(define-db-col-type  'bigserial "0" number->string string->number)
(define-db-col-type  'serial4 "0" number->string string->number)
(define-db-col-type  'serial8 "0" number->string string->number)
(define-db-col-type  'varchar #f identity identity)
(define-db-col-type  'character #f identity identity)
(define-db-col-type  'char "?"(lambda(c)(make-string 1 c))(lambda(s)(string-ref s 0)))
(define-db-col-type  'text "" identity identity)
(define-db-col-type  'name "???"(lambda(val)(if(< 63(string-length val))(string-take val 62)val))identity)
(define-db-col-type  'bytea #f(lambda(s)(with-output-to-string(lambda()(define(out! zeroes n)(display "\\")(display zeroes)(display(number->string n 8)))(let((len(string-length s))(c #f)(n #f))(do((i 0(#{1+}# i)))((= len i))(set! c(string-ref s i))(set! n(char->integer c))(cond((= 39 n)(out! "0" n))((= 92 n)(out! "" n))((<= 32 n 126)(display c))((<= 0 n 7)(out! "00" n))((<= 8 n 63)(out! "0" n))(else(out! "" n))))))))(lambda(s)(if(and(<= 4(string-length s))(string-prefix? "\\x" s))(let*((from-a(-(char->integer #\a)10))(from-0(char->integer #\0))(end(string-length s))(ans(make-string(ash(- end 2)-1)#\nul)))(define(n<- idx)(let((c(string-ref s idx)))(-(char->integer c)(case c((#\a #\b #\c #\d #\e #\f)from-a)(else from-0)))))(do((i 2(+ 2 i))(o 0(#{1+}# o)))((= end i))(string-set! ans o(integer->char(logior(ash(n<- i)4)(n<-(#{1+}# i))))))ans)(with-output-to-string(lambda()(let((len(string-length s))(b #f))(let loop((i 0))(set! b(string-index s #\\ i))(cond((not b)(display(substring/shared s i)))((char=? #\\(string-ref s(#{1+}# b)))(display(substring/shared s i(#{1+}# b)))(loop(+ 2 b)))(else(display(substring/shared s i b))(display(integer->char(string->number(substring/shared s(#{1+}# b)(+ 4 b))8)))(loop(+ 4 b)))))))))))
(define-db-col-type  'timestamp "1970-01-01 00:00:00"(lambda(time)(cond((string? time)time)((number? time)(strftime "%Y-%m-%d %H:%M:%S"(localtime time)))(else(error "bad timestamp-type input:" time))))(lambda(string)(car(mktime(car(strptime "%Y-%m-%d %H:%M:%S" string))))))
(define-db-col-type  'boolean "f"(lambda(x)(if x "t" "f"))(lambda(s)(not(string=? "f" s))))
(define-db-col-type  'bool "f"(lambda(x)(if x "t" "f"))(lambda(s)(not(string=? "f" s))))
(define(n+m-stringifier n+m)(fs "~A/~A"(inet-ntoa(vector-ref n+m 0))(vector-ref n+m 1)))
(define(n+m-objectifier s)(let((cut(string-index s #\/)))(if cut(vector(inet-aton(string-take s cut))(string->number(substring/shared s(#{1+}# cut))))(vector(inet-aton s)32))))
(define-db-col-type  'inet "0.0.0.0" n+m-stringifier n+m-objectifier)
(define-db-col-type  'cidr "0.0.0.0" n+m-stringifier n+m-objectifier)
(define(host-stringifier n)(fs "~A/32"(inet-ntoa n)))
(define(host-objectifier s)(vector-ref(n+m-objectifier s)0))
(define-db-col-type  'inet-host "127.0.0.1" host-stringifier host-objectifier)
(define-db-col-type  'macaddr "00:00:00:00:00:00"(lambda(n)(let loop((bpos 0)(acc '())(n n))(if(= bpos 48)(apply fs "~A:~A:~A:~A:~A:~A"(map(lambda(x)(number->string x 16))acc))(loop(+ bpos 8)(cons(logand 255 n)acc)(ash n -8)))))(lambda(s)(let loop((cut 2)(acc '())(shift 40))(if(> 0 shift)(apply + acc)(loop(+ 3 cut)(cons(ash(string->number(substring/shared s(- cut 2)cut)16)shift)acc)(- shift 8))))))
(define-db-col-type  'oid "-1" number->string string->number)
(define-db-col-type  'aclitem "?" identity identity)
(register-array-variant 1  'text double-quote identity)
(register-array-variant 2  'text double-quote identity)
(register-array-variant 1  'int4)
(register-array-variant 1  'aclitem double-quote identity)
