#cs(module sedna-api mzscheme
(require "myenv.ss")
(require "srfi-12.ss")
(require "sedna-low.ss")
(define (sedna:read-n-bytes n input-port)
(cond
((= n 0) '())
((eof-object? (sedna:peek-byte input-port))
(sedna:raise-exn "sedna:read-n-bytes: Unexpected end of input port")
#f)
(else
(cons (sedna:read-byte input-port)
(sedna:read-n-bytes (- n 1) input-port)))))
(define (sedna:read-n-or-less n input-port)
(if
(or (eof-object? (sedna:peek-byte input-port)) (= n 0))
'()
(cons (sedna:read-byte input-port)
(sedna:read-n-or-less (- n 1) input-port))))
(define (sedna:chars->network chars)
(cons
sedna:char000
(append
(sedna:integer->chars (length chars))
chars)))
(define sedna:ItemPart 360)
(define sedna:ItemEnd 370)
(define (sedna:read-package-as-chars input-port)
(let* ((header-code
(sedna:chars->integer
(sedna:read-n-bytes 4 input-port)))
(body-size
(sedna:chars->integer
(sedna:read-n-bytes 4 input-port))))
(values header-code
(sedna:read-n-bytes body-size input-port))))
(define (sedna:read-package-after-item-parts input-port)
(call-with-values
(lambda () (sedna:read-package-as-chars input-port))
(lambda (header-code body-char-list)
(if
(or (= header-code sedna:ItemPart) (= header-code sedna:ItemEnd))
(sedna:read-package-after-item-parts input-port)
(values header-code body-char-list)))))
(define (sedna:connection? obj)
(and (pair? obj) (not (null? obj))
(eq? (car obj) 'connection)
(assq 'host (cdr obj)) (assq 'db-name (cdr obj))
(assq 'user (cdr obj)) (assq 'password (cdr obj))
(assq 'connection-input-port (cdr obj))
(assq 'connection-output-port (cdr obj))
#t))
(define (sedna:construct-connection host db-name user password
tcp-input-port tcp-output-port)
`(connection
(host ,host)
(db-name ,db-name)
(user ,user)
(password ,password)
(connection-input-port ,tcp-input-port)
(connection-output-port ,tcp-output-port)))
(define (sedna:parameterized-connection-accessor entry)
(lambda (connection)
(cond
((assq entry (cdr connection))
=> cadr)
(else #f))))
(define sedna:connection-host
(sedna:parameterized-connection-accessor 'host))
(define sedna:connection-db-name
(sedna:parameterized-connection-accessor 'db-name))
(define sedna:connection-user
(sedna:parameterized-connection-accessor 'user))
(define sedna:connection-password
(sedna:parameterized-connection-accessor 'password))
(define sedna:connection-input
(sedna:parameterized-connection-accessor 'connection-input-port))
(define sedna:connection-output
(sedna:parameterized-connection-accessor 'connection-output-port))
(define (sedna:error-code+info body-chars)
(if
(null? body-chars) "no error message transferred"
(let ((code (sedna:chars->integer (sedna:first-n 4 body-chars))))
(let-values*
(((info dummy)
(sedna:extract-string (list-tail body-chars 4))))
(string-append info ".\n")))))
(define (sedna:raise-with-info msg body-chars)
(if
(null? body-chars) (begin
(sedna:raise-exn
msg ": Server reported of an unknown error")
#f)
(let ((code
(sedna:chars->integer (sedna:first-n 4 body-chars))))
(let-values*
(((info dummy)
(sedna:extract-string (list-tail body-chars 4))))
(sedna:raise-exn
msg ": " info)
#f))))
(define (sedna:raise-server-error body-chars)
(sedna:raise-with-info "Server reported of an error" body-chars))
(define sedna:Start-Up 110)
(define sedna:SessionParameters 120)
(define sedna:AuthentificationParameters 130)
(define sedna:SendSessionParameters 140)
(define sedna:SendAuthParameters 150)
(define sedna:AuthentificationOk 160)
(define sedna:AuthentificationFailed 170)
(define sedna:ErrorResponse 100)
(define (sedna:connect-to-database host db-name user password)
(let* ((host (if (string=? host "localhost")
"127.0.0.1" host))
(ports
(sedna:open-tcp-connection host 5050))
(in (car ports))
(out (cdr ports)))
(sedna:write-package-as-bytes sedna:Start-Up '() out)
(let-values*
(((code body-chars)
(sedna:read-package-as-chars in)))
(cond
((= code sedna:SendSessionParameters)
(sedna:write-package-as-bytes
sedna:SessionParameters
(cons
sedna:char001 (cons
sedna:char000 (append
(sedna:string->network user)
(sedna:string->network db-name))))
out)
(let-values*
(((code body-chars)
(sedna:read-package-as-chars in)))
(cond
((= code sedna:SendAuthParameters)
(sedna:write-package-as-bytes
sedna:AuthentificationParameters
(sedna:string->network password)
out)
(let-values*
(((code body-chars)
(sedna:read-package-as-chars in)))
(cond
((= code sedna:AuthentificationOk)
(sedna:construct-connection
host db-name user password in out))
((= code sedna:AuthentificationFailed)
(sedna:raise-exn
"sedna:connect-to-database: Authentification failed")
#f)
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:connect-to-database: Unexpected header code from server: "
(number->string code))))))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:connect-to-database: Unexpected header code from server: "
(number->string code))))))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:connect-to-database: Unexpected header code from server: "
(number->string code)))))))
(define sedna:CloseConnection 500)
(define sedna:CloseConnectionOk 510)
(define sedna:TransactionRollbackBeforeClose 520)
(define (sedna:disconnect-from-database connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-package-as-bytes sedna:CloseConnection '() out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(sedna:close-tcp-connection out) (sedna:close-tcp-connection in) (cond
((or (= code sedna:CloseConnectionOk)
(= code sedna:TransactionRollbackBeforeClose))
#t)
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:disconnect-from-database: Unexpected header code from server: "
(number->string code))))))))
(define sedna:BeginTransaction 210)
(define sedna:CommitTransaction 220)
(define sedna:RollbackTransaction 225)
(define sedna:BeginTransactionOk 230)
(define sedna:BeginTransactionFailed 240)
(define sedna:CommitTransactionOk 250)
(define sedna:RollbackTransactionOk 255)
(define sedna:CommitTransactionFailed 260)
(define sedna:RollbackTransactionFailed 265)
(define (sedna:begin-transaction connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-package-as-bytes sedna:BeginTransaction '() out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:BeginTransactionOk)
#t)
((= code sedna:BeginTransactionFailed)
(sedna:raise-exn
"sedna:begin-transaction: Begin transaction failed")
#f)
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:begin-transaction: Unexpected header code from server: "
(number->string code))))))))
(define (sedna:end-transaction connection action)
(cond
((eq? action 'COMMIT)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-package-as-bytes sedna:CommitTransaction '() out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:CommitTransactionOk)
#t)
((= code sedna:CommitTransactionFailed)
(sedna:raise-with-info "Transaction commit failed" body-chars))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:end-transaction: Unexpected header code from server: "
(number->string code))))))))
((eq? action 'ROLLBACK)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-package-as-bytes sedna:RollbackTransaction '() out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:RollbackTransactionOk)
#t)
((= code sedna:RollbackTransactionFailed)
(sedna:raise-with-info "Transaction rollback failed" body-chars))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:end-transaction: Unexpected header code from server: "
(number->string code))))))))
(else
(sedna:raise-exn "sedna:end-transaction: unknown action specified")
#f)))
(define sedna:Execute 300)
(define sedna:ExecuteLong 301)
(define sedna:LongQueryEnd 302)
(define sedna:write-query-out
(let ((max-query-length 10000))
(lambda (query result-type-sxml? out)
(if
(< (string-length query) max-query-length) (sedna:write-package-as-bytes
sedna:Execute
(cons
(if result-type-sxml? sedna:char001 sedna:char000)
(sedna:string->network query))
out)
(let ((res-type-char
(if result-type-sxml? sedna:char001 sedna:char000))
(lng (string-length query)))
(let loop ((i 0))
(if
(< (- lng i) max-query-length)
(begin
(sedna:write-package-as-bytes
sedna:ExecuteLong
(cons res-type-char
(sedna:string->network (substring query i lng)))
out)
(sedna:write-package-as-bytes
sedna:LongQueryEnd '() out)
#t)
(begin
(sedna:write-package-as-bytes
sedna:ExecuteLong
(cons res-type-char
(sedna:string->network
(substring query i (+ i max-query-length))))
out)
(loop (+ i max-query-length))))))))))
(define (sedna:next result)
(force (cdr result)))
(define (sedna:result->list result)
(if
(not (pair? result)) result
(let loop ((pair result)
(lst '()))
(cond
((null? pair)
(reverse lst))
((null? (cdr pair))
(reverse (cons (car pair) lst)))
(else
(loop (sedna:next pair)
(cons (car pair) lst)))))))
(define sedna:GetNextItem 310)
(define sedna:ResultEnd 375)
(define (sedna:get-next-xml-item connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(let loop ((res '())
(frst #t))
(let-values*
(((code body-chars)
(sedna:read-package-as-chars in)))
(cond
((= code sedna:ItemPart)
(loop (append
res
(let-values*
(((part dummy)
(sedna:extract-string body-chars)))
(list part)))
#f))
((= code sedna:ResultEnd)
(if frst '()
(list (sedna:apply-string-append res))))
((= code sedna:ItemEnd)
(if
frst (begin
(sedna:write-package-as-bytes sedna:GetNextItem '() out)
(sedna:get-next-xml-item connection))
(let ((curr-position (sedna:port-position in)))
(cons
(sedna:apply-string-append res)
(delay
(cond
((not (= (sedna:port-position in) curr-position))
(sedna:raise-exn
"sedna:get-next-xml-item: "
"Result invalid since the next query was executed")
'())
(else
(sedna:write-package-as-bytes sedna:GetNextItem '() out)
(sedna:get-next-xml-item connection))))))))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:get-next-xml-item: Unexpected header code from server: "
(number->string code))))))))
(define (sedna:get-next-item connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(let loop ((res '())
(frst #t))
(let-values*
(((code body-chars)
(sedna:read-package-as-chars in)))
(cond
((= code sedna:ItemPart)
(loop (append
res
(let-values*
(((part dummy)
(sedna:extract-string body-chars)))
(list part)))
#f))
((= code sedna:ResultEnd)
(if frst '()
(list (call-with-input-string
(sedna:apply-string-append res)
read))))
((= code sedna:ItemEnd)
(if
frst (begin
(sedna:write-package-as-bytes sedna:GetNextItem '() out)
(sedna:get-next-xml-item connection))
(let ((curr-position (sedna:port-position in)))
(cons
(call-with-input-string
(sedna:apply-string-append res)
read)
(delay
(cond
((not (= (sedna:port-position in) curr-position))
(sedna:raise-exn
"sedna:get-next-item: "
"Result invalid since the next query was executed")
'())
(else
(sedna:write-package-as-bytes sedna:GetNextItem '() out)
(sedna:get-next-item connection))))))))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:get-next-item: Unexpected header code from server: "
(number->string code))))))))
(define sedna:BulkLoadError 400)
(define sedna:BulkLoadPortion 410)
(define sedna:BulkLoadEnd 420)
(define sedna:BulkLoadFileName 430)
(define sedna:BulkLoadFromStream 431)
(define sedna:BulkLoadSucceeded 340) (define sedna:BulkLoadFailed 450)
(define (sedna:bulk-load-file filename connection)
(if
(file-exists? filename)
(sedna:bulk-load-port (open-input-file filename) connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-package-as-bytes
sedna:BulkLoadError
(append
(sedna:integer->chars 666)
(sedna:string->network "Requested file doesn't exist"))
out)
(sedna:read-package-as-chars in)
(sedna:raise-exn
"sedna:bulk-load-file: Requested file doesn't exist: " filename)
#f)))
(define (sedna:bulk-load-port port connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(let loop ((ch (sedna:peek-byte port)))
(cond
((eof-object? ch)
(close-input-port port)
(sedna:write-package-as-bytes sedna:BulkLoadEnd '() out)
(sedna:flush-output-port out)
(let-values*
(((code body-chars)
(sedna:read-package-as-chars in)))
(cond
((= code sedna:BulkLoadSucceeded)
#t)
((= code sedna:BulkLoadFailed)
(sedna:raise-exn
"sedna:bulk-load-stream: Bulk load failed: "
(sedna:error-code+info body-chars))
#f)
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:bulk-load-stream: Unexpected header code from server: "
(number->string code))))))
(else
(sedna:write-package-as-bytes
sedna:BulkLoadPortion
(sedna:chars->network (sedna:read-n-or-less 1000 port))
out)
(loop (sedna:peek-byte port)))))))
(define sedna:QuerySucceeded 320)
(define sedna:QueryFailed 330)
(define sedna:UpdateSucceeded 340)
(define sedna:UpdateFailed 350)
(define (sedna:execute-query-xml connection query)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-query-out query #f out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:QuerySucceeded)
(sedna:get-next-xml-item connection))
((= code sedna:QueryFailed)
(sedna:raise-exn
"sedna:execute-query-xml: " (sedna:error-code+info body-chars))
#f)
((= code sedna:UpdateSucceeded)
#t)
((= code sedna:UpdateFailed)
(sedna:raise-exn
"sedna:execute-query: Update failed"
(sedna:error-code+info body-chars))
#f)
((= code sedna:BulkLoadFileName)
(let-values*
(((filename dummy)
(sedna:extract-string body-chars)))
(sedna:bulk-load-file filename connection)))
((= code sedna:BulkLoadFromStream)
(sedna:bulk-load-port (current-input-port) connection))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:execute-query-xml: Unexpected header code from server: "
(number->string code))))))))
(define (sedna:execute-query connection query)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-query-out query #t out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:QuerySucceeded)
(sedna:get-next-item connection))
((= code sedna:QueryFailed)
(sedna:raise-exn
"sedna:execute-query: " (sedna:error-code+info body-chars))
#f)
((= code sedna:UpdateSucceeded)
#t)
((= code sedna:UpdateFailed)
(sedna:raise-exn
"sedna:execute-query: Update failed"
(sedna:error-code+info body-chars))
#f)
((= code sedna:BulkLoadFileName)
(let-values*
(((filename dummy)
(sedna:extract-string body-chars)))
(sedna:bulk-load-file filename connection)))
((= code sedna:BulkLoadFromStream)
(sedna:bulk-load-port (current-input-port) connection))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:execute-query: Unexpected header code from server: "
(number->string code))))))))
(define (sedna:input-stream? obj)
(and (pair? obj) (not (null? obj))
(eq? (car obj) 'sedna:input-stream)
(assq 'stream-input-port (cdr obj))
(assq 'item-part-getter (cdr obj))))
(define (sedna:construct-input-stream input-port lambda-with-no-arguments)
`(sedna:input-stream
(stream-input-port ,input-port)
(item-part-getter ,lambda-with-no-arguments)))
(define sedna:input-stream-port
(sedna:parameterized-connection-accessor 'stream-input-port))
(define sedna:input-stream-item-part-getter
(sedna:parameterized-connection-accessor 'item-part-getter))
(define (sedna:char-reader-helper port-reader)
(lambda (input-stream)
(let ((port (sedna:input-stream-port input-stream)))
(begin
(if
(char-ready? port)
#t
((sedna:input-stream-item-part-getter input-stream)))
(port-reader port)))))
(define sedna:sedna:read-byte (sedna:char-reader-helper sedna:read-byte))
(define sedna:sedna:peek-byte (sedna:char-reader-helper sedna:peek-byte))
(define (sedna:read-line input-stream)
(let ((port (sedna:input-stream-port input-stream)))
(let loop ((char-lst '()))
(let ((ch (begin
(if
(char-ready? port)
#t
((sedna:input-stream-item-part-getter input-stream)))
(sedna:read-byte port))))
(cond
((eof-object? ch) (if (null? char-lst) ch
(list->string (reverse char-lst))))
((memv ch '(#\return #\newline))
(begin
(if (and
(not (and (char-ready? port)
(eof-object? (sedna:peek-byte port))))
(begin
(if
(char-ready? port)
#t
((sedna:input-stream-item-part-getter input-stream)))
(char=? (sedna:peek-byte port) #\newline)))
(sedna:read-byte port) #t )
(list->string (reverse char-lst))))
(else
(loop (cons ch char-lst))))))))
(define (sedna:get-next-xml-stream-item connection)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(call-with-values
(lambda () (sedna:read-package-as-chars in))
(lambda (code body-chars)
(cond
((= code sedna:ItemPart)
(let* ((ports-pair (sedna:make-pipe))
(pipe-from (car ports-pair))
(pipe-to (cdr ports-pair))
(curr-position (sedna:port-position out))
(item-part-getter
(lambda ()
(cond ((and (char-ready? pipe-from)
(eof-object? (sedna:peek-byte pipe-from)))
#f )
((not (= (sedna:port-position out) curr-position))
(sedna:raise-exn
"Sedna item-part-getter: "
"Result invalid since the next query was executed")
#f)
(else
(call-with-values
(lambda () (sedna:read-package-as-chars in))
(lambda (code body-chars)
(cond
((= code sedna:ItemPart)
(call-with-values
(lambda () (sedna:extract-string body-chars))
(lambda (part dummy)
(display part pipe-to)))
#t)
((= code sedna:ItemEnd)
(sedna:close-output-pipe pipe-to)
#f)
(else
(sedna:raise-exn
"Sedna item-part-getter: "
"Unexpected header code from server: "
(number->string code)))))))))))
(call-with-values
(lambda () (sedna:extract-string body-chars))
(lambda (part dummy)
(display part pipe-to)
(cons
(sedna:construct-input-stream pipe-from item-part-getter)
(delay
(if
(not (= (sedna:port-position out) curr-position))
(sedna:raise-exn
"sedna:get-next-xml-stream-item: "
"Result invalid since the next query was executed")
(let loop ((consumed? item-part-getter))
(if
consumed?
(loop (item-part-getter))
(begin
(sedna:write-package-as-bytes sedna:GetNextItem '() out)
(sedna:get-next-xml-stream-item connection)))))))))))
((= code sedna:ItemEnd)
(sedna:write-package-as-bytes sedna:GetNextItem '() out)
(sedna:get-next-xml-stream-item connection))
((= code sedna:ResultEnd)
'())
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:get-next-xml-stream-item: Unexpected header code from server: "
(number->string code))))))))
(define (sedna:execute-query-xml-stream connection query)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-query-out query #f out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:QuerySucceeded)
(sedna:get-next-xml-stream-item connection))
((= code sedna:QueryFailed)
(sedna:raise-exn
"sedna:execute-query-xml: " (sedna:error-code+info body-chars))
#f)
((= code sedna:UpdateSucceeded)
#t)
((= code sedna:UpdateFailed)
(sedna:raise-exn
"sedna:execute-query: Update failed"
(sedna:error-code+info body-chars))
#f)
((= code sedna:BulkLoadFileName)
(let-values*
(((filename dummy)
(sedna:extract-string body-chars)))
(sedna:bulk-load-file filename connection)))
((= code sedna:BulkLoadFromStream)
(sedna:bulk-load-port (current-input-port) connection))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:execute-query-xml: Unexpected header code from server: "
(number->string code))))))))
(define (sedna:bulk-load-from-xml-stream
connection port document-name . collection-name)
(let ((in (sedna:connection-input connection))
(out (sedna:connection-output connection)))
(sedna:write-query-out
(if
(null? collection-name) (string-append "LOAD STDIN \"" document-name "\"")
(string-append
"LOAD STDIN \"" document-name "\" \"" (car collection-name) "\""))
#t out)
(call-with-values
(lambda () (sedna:read-package-after-item-parts in))
(lambda (code body-chars)
(cond
((= code sedna:BulkLoadFromStream)
(sedna:bulk-load-port port connection))
((= code sedna:ErrorResponse)
(sedna:raise-server-error body-chars))
(else
(sedna:raise-exn
"sedna:bulk-load-from-xml-stream: "
"Unexpected header code from server: " (number->string code))))))))
(define (sedna:transaction connection . queries)
(handle-exceptions
exc
(begin
(sedna:end-transaction connection 'ROLLBACK)
(exc:signal exc))
(begin
(sedna:begin-transaction connection)
(let loop ((queries queries)
(last-res #t))
(cond
((null? queries) (sedna:end-transaction connection 'COMMIT)
last-res)
(else
(let* ((res (sedna:execute-query connection (car queries)))
(res (if (pair? res) (sedna:result->list res)
res)))
(loop (cdr queries)
res))))))))
(provide sedna:connection? sedna:connect-to-database sedna:disconnect-from-database sedna:begin-transaction sedna:end-transaction sedna:next sedna:result->list sedna:execute-query-xml sedna:execute-query sedna:execute-query-xml-stream sedna:bulk-load-from-xml-stream sedna:transaction))