(define-module(database postgres-types)#:export(oid-type-name-cache dbcoltypes dbcoltype-lookup dbcoltype:stringifier dbcoltype:default dbcoltype:objectifier define-db-col-type define-db-col-type-array-variant)#:autoload(database postgres)(pg-exec))
(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)))))))(cond((and(not(null? opt))(car opt))(set!(o/t conn)(fresh)))((o/t conn))(else(set!(o/t conn)(fresh)))))
(define *db-col-types* '())
(define(dbcoltypes)(map car *db-col-types*))
(define(dbcoltype-lookup type-name)(assq-ref *db-col-types* type-name))
(define(dbcoltype:stringifier tc)(vector-ref tc 0))
(define(dbcoltype:default tc)(vector-ref tc 1))
(define(dbcoltype:objectifier tc)(vector-ref tc 2))
(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(list->string(reverse! iacc))))(else(iloop(read-char port)(cons 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-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)(set! *db-col-types*(assq-set! *db-col-types* name(vector stringifier default objectifier))))
(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 (define-db-col-type-array-variant composed simple . procs)(let*((lookup(dbcoltype-lookup simple))(stringifier(or(and(not(null? procs))(car procs))(dbcoltype:stringifier lookup)))(objectifier(or(and(not(null? procs))(not(null?(cdr procs)))(cadr procs))(dbcoltype:objectifier lookup))))(define-db-col-type composed "{}"(dimension->string-proc stringifier)(read-array-string-proc objectifier))))
(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))(substring val 0 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))(char=? #\\(string-ref s 0))(char=? #\x(string-ref s 1)))(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 s i)))((char=? #\\(string-ref s(#{1+}# b)))(display(substring s i(#{1+}# b)))(loop(+ 2 b)))(else(display(substring s i b))(display(integer->char(string->number(substring 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)(simple-format #f "~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(substring s 0 cut))(string->number(substring 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)(simple-format #f "~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 simple-format #f "~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 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)
(define-db-col-type-array-variant  'text() 'text double-quote identity)
(define-db-col-type-array-variant  'text()() 'text double-quote identity)
(define-db-col-type-array-variant  'int4() 'int4)
(define-db-col-type-array-variant  'aclitem() 'aclitem double-quote identity)
