Hi,
I have changed the code for RbaseXClient.R in such a way that it
complies more to the server protocol and to the R-style of coding.
- 'execute' has been renamed to 'command'
- All the functions in the Command Protocol section return a list with
the complete server response. This makes it much easier to handle errors
(see lines 8-14 in TestRBaseXClient.R).
In the Query Command Protocol section, the functions 'more()' (as being
called by results) and 'full()' now return the results, prefixed with a
byte that represents the Type ID.
Cheers,
Ben Engbers
library(utils)
library(R6)
library(openssl)
library(dplyr)
library(purrr)
library(stringr)
library(magrittr)
BasexClient <- R6Class("BasexClient",
public = list(
initialize = function(host, port, username, password) {
private$sock <- socketConnection(host = "localhost", port = 1984L,
open = "w+b", server = FALSE, blocking = TRUE,
encoding = "utf-8")
private$response <- self$str_receive()
splitted <-strsplit(private$response, "\\:")
ifelse(length(splitted[[1]]) > 1,
{ code <- paste(username, splitted[[1]][1],password, sep=":")
nonce <- splitted[[1]][2]
},
{ code <- password
nonce <- splitted[[1]][1]
}
)
code <- md5(paste(md5(code), nonce, sep = ""))
class(code) <- "hash"
private$void_send(username)
private$void_send(code)
if (!self$bool_test_sock()) stop("Access denied")},
command = function(command) {
private$void_send(command)
private$result <- self$str_receive()
private$info <- self$str_receive()
if (length(private$info) > 0) cat(private$info, "\n")
return(list(result = private$result %>% strsplit("\n", fixed = TRUE),
info = private$info,
success = self$bool_test_sock()))
},
query = function(query) {
return(list(query = Query$new(query, private$get_sock()), success = self$bool_test_sock()))
},
create = function(name, input) {
if (missing(input)) input <- ""
writeBin(as.raw(0x08), private$sock)
writeBin(private$raw_terminated_string(name), private$sock)
writeBin(private$raw_terminated_string(input), private$sock)
private$info <- self$str_receive()
return(list(info = private$info, success = self$bool_test_sock()))
},
add = function(name, path, input) {
writeBin(as.raw(0x09), private$sock)
writeBin(private$raw_terminated_string(name), private$sock)
writeBin(private$raw_terminated_string(path), private$sock)
writeBin(private$raw_terminated_string(input), private$sock)
private$info <- self$str_receive()
return(list(info = private$info, success = self$bool_test_sock()))
# success <- self$bool_test_sock()
},
replace = function(path, input) {
writeBin(as.raw(0x0C), private$sock)
writeBin(private$raw_terminated_string(path), private$sock)
writeBin(private$raw_terminated_string(input), private$sock)
private$info <- self$str_receive()
return(list(info = private$info, success = self$bool_test_sock()))
# success <- self$bool_test_sock()
},
store = function(path, input) {
writeBin(as.raw(0x0D), private$sock)
writeBin(private$raw_terminated_string(path), private$sock)
writeBin(private$raw_terminated_string(input), private$sock)
private$info <- self$str_receive()
# success <- self$bool_test_sock()
},
bool_test_sock = function(socket) {
if (missing(socket)) socket <- private$get_sock()
test <- readBin(socket, what = "raw", n =1)
return(test == 0x00)
},
finalize = function() {
private$close_sock()},
print = function(...) {
cat("Socket: ", private$get_sock(), "\n", sep = "")
invisible(self)},
str_receive = function(input, output) {
if (missing(input)) input <- private$get_sock()
if (missing(output)) output <- raw(0)
while ((rd <- readBin(input, what = "raw", n =1)) > 0) {
if (rd == 0xff) next
output <- c(output, rd)
}
ret <- rawToChar(output)
return(ret)},
term_string = function(string) {
return(charToRaw(string) %>% append(0) %>% as.raw())}
),
private = list(
result = NULL,
info = NULL,
sock = NULL,
response = NULL,
get_sock = function() { private$sock },
close_sock = function() { close(private$sock)},
raw_terminated_string = function(string) {
return(charToRaw(string) %>% append(0) %>% as.raw())},
void_send = function(code, todo, input) {
if (missing(todo)) { # 'code' to be handled is either a string, hash or stream
classTest <- class(code)
if (class(code) == "character" || (class(code) == "hash")) private$void_send0term_string(code)
} else {
writeBin(as.raw(code), private$get_sock())
private$void_send0term_string(todo)
private$void_send_stream(input)
}},
void_send0term_string = function(string) {
zero_term <- self$term_string(string)
writeBin(zero_term, private$get_sock())},
void_send_stream = function(input) {
rd_id <- 1
end <- length(input)
zero_term <- raw()
while (rd_id < end) {
rd <- c(input[rd_id])
if (rd == 255 || rd == 0) zero_term <- c(zero_term, c(0x00))
rd_id <- rd_id + 1
zero_term <- c(zero_term, rd)
}
zero_term <- c(zero_term, c(0x00))
writeBin(zero_term, private$get_sock())}
)
)
Query <- R6Class("Query",
inherit = BasexClient,
public = list(
str_id = NULL,
raw_id = NULL,
initialize = function(query, sock) {
private$sock <- sock
out_stream <- super$get_sock()
writeBin(as.raw(0x00), out_stream)
writeBin(super$term_string(query), out_stream)
self$str_id <- super$str_receive()
self$raw_id <- super$term_string(self$str_id)},
close = function() {
private$req_exe(0x02, self$raw_id)
if (!private$req_success) cat("Query \'", self$str_id, "\' could not be closed.", "\n")
return(private$req_success)
},
bind = function(name, value, type) {
socket <- super$get_sock()
if (missing(type)) type = ""
private$write_code_ID(0x03, self$raw_id)
name %>% charToRaw() %>% append(0) %>% as.raw() %>% writeBin(socket)
value %>% charToRaw() %>% append(0) %>% as.raw() %>% writeBin(socket)
type %>% charToRaw() %>% append(0) %>% as.raw() %>% writeBin(socket)
private$req_result <- super$str_receive()
private$req_success <- super$bool_test_sock()
return(private$req_success)
},
execute = function() {
private$req_exe(0x05, self$raw_id)
result <- private$req_result %>% private$clean()
return(result)
},
more = function() {
if (is.null(private$cache)) {
in_stream <- out_stream <- super$get_sock()
writeBin(as.raw(0x04), out_stream)
writeBin(self$raw_id, out_stream)
cache <- c()
while ((rd <- readBin(in_stream, what = "raw", n =1)) > 0) {
cache <- c(cache, as.character(rd))
cache <- c(cache, super$str_receive())
}
private$req_success <- super$bool_test_sock()
private$cache <- cache
private$pos <- 0
}
if ( length(private$cache) > private$pos) return(TRUE)
else
{ private$cache <- NULL
return(FALSE)
}},
next_row = function() {
if (self$more()) {
private$pos <- private$pos + 1
result <- private$cache[private$pos]
}
return(result)},
info = function() {
private$req_exe(0x06, self$raw_id)
result <- private$req_result %>% private$clean()
return(result)},
options = function() {
private$req_exe(0x07, self$raw_id)
res <- private$req_result
res <- ifelse(length(private$req_result) > 1,
private$req_result %>% private$clean(), "No options set")},
updating = function() {
private$req_exe(0x1E, self$raw_id)
result <- private$req_result %>% as.logical()
return(result)},
full = function() {
in_stream <- out_stream <- super$get_sock()
writeBin(as.raw(0x1F), out_stream)
writeBin(self$raw_id, out_stream)
cache <- c()
while ((rd <- readBin(in_stream, what = "raw", n =1)) > 0) {
cache <- c(cache, as.character(rd))
cache <- c(cache, super$str_receive())
}
private$req_success <- super$bool_test_sock()
result <- cache
return(result)},
print = function(...) {
cat("Query-ID: ", self$str_id, "\n", sep = "")
invisible(self)}
),
private = list(
cache = NULL,
pos = NULL,
req_result = NULL,
req_success = NULL,
write_code_ID = function(id_code, arg) {
out_stream <- super$get_sock()
writeBin(as.raw(id_code), out_stream)
writeBin(arg, out_stream)},
req_exe = function(id_code, arg) {
private$write_code_ID(id_code, arg)
private$req_result <- super$str_receive()
private$req_success <- super$bool_test_sock()
},
receive_more = function(input, output) {
if (missing(input)) input <- private$get_sock()
if (missing(output)) output <- raw(0)
while ((rd <- readBin(input, what = "raw", n =1)) > 0) {
if (rd == 0xff) next
output <- c(output, rd)
}
ret <- rawToChar(output)
return(ret)},
clean = function(input) {
result <- input %>% strsplit("\n", fixed = TRUE)
if ((result[[1]][1] == "")) result <- result[[1]][2]
return(result)
}
)
)
source("RbaseXClient.R")
BasexClient$undebug("query")
# Test 'command'
Session <- BasexClient$new("localhost", 1984, "admin", "admin")
test <- Session$command("OPEN test1")
if (!test$success) {
test <- Session$create("test1", "<xml>Create test1</xml>")
if (test$success) {cat( test$info, "\n")
} else {
cat("Could not create database\n")
}
}
cat("Create database \"test2\" with empty resources\n")
Session$create("test2")
print(Session$command("list")$result)
print(Session$command("xquery 1 to 5")$result)
Session$command("CLOSE")
Session$command("DROP DB test2")
Session$command("DROP DB test1")
# Test 'query'
cat("Test Query1\n\n")
query1 <- "for $i in 1 to 2 return <xml>Text { $i }</xml>"
query1 <- Session$query(query1)
cat("query1$query$options():", query1$query$options(), sep = " ", "\n")
cat("query1$query$execute(): ")
print(query1$query$execute())
cat("query1$query$info():", query1$query$info(), sep = " ", "\n")
cat("query1$query$updating():", query1$query$updating(), sep = " ", "\n")
cat("query1$query$full(): ")
print(query1$query$full())
if (query1$query$close()) {
cat("query1 closed\n")
} else {
cat("query1 could not be closed")}
cat("\n")
cat("Test Query2\n\n")
query2 <- "for $i in 3 to 4 return <xml>Text { $i }</xml>"
query2 <- Session$query(query2)$query
print(query2)
while (query2$more()) {
cat(query2$next_row(), "\n")
}
query2$close()
cat("Test Query3\n\n")
query3 <- "declare variable $name external; for $i in 5 to 6 return element { $name } { $i }"
query3 <- Session$query(query3)$query
query3$bind("$name", "number", "")
print(query3)
print(query3$execute())
print(query3$info())
