couchdb.R

## Usage:
## db <- Database("http://208.78.99.54:5984/", "packages")
##
## Insert(key, value, db)
##
## Note that values are automatically converted to JSON.

source("curr.R")

# The DB is created if it doesnt exist
Database <- function(url, db.name) {
  db <- list(sess=CurrNew(url, format="json",
               headers="Content-Type: application/json"),
             database=db.name)
  if (!ExistsDb(db)) { CreateDb(db) }
  return(db)
}

CreateDb <- function(db) {
  CurrPut(db$database, sess=db$sess)$status == 201
}

DropDb <- function(db) {
  CurrDelete(db$database, db$sess)$status == 200
}

ExistsDb <- function(db) {
  CurrGet(db$database, db$sess)$status == 200
}

Insert <- function(key, value, db, timestamp=TRUE) {
  if (timestamp) value$created_at <- Timestamp()
  CurrPut(paste(db$database, "/", key, sep=""), value, sess=db$sess)
}

Delete <- function(key, db) {
  rev <- LastRev(key, db)
  CurrDelete(paste(db$database, "/", key, "?rev=", rev, sep=""),
             sess=db$sess)$status == 200
}

GetKey <- function(key, db) {
  CurrGet(paste(db$database, "/", key, sep=""), db$sess)
}

LastRev <- function(key, db) {
  GetKey(key, db)$body$`_rev`
}

## Utilities

## timestamp
Timestamp <- function() {
  format(as.POSIXlt(Sys.time(), "UTC"), "%Y/%m/%d %H:%M:%S +0000")
}

curr.R

## Early development version of an envisioned HTTP client for R
##
## Usage:
##
## sess <- CurrNew("http://208.78.99.54:5984")
##
## > CurrGet("/packages", sess)
##
## Which results in a GET request to http://208.78.99.54:5984/packages
##
## So basically sess is like a config store, which must be passed in to all the
## other functions.

library(RCurl)
library(rjson)

CurrNew <- function(base.url, timeout=5, format="", headers=NULL) {
  list(base.url=base.url, timeout=timeout, format=tolower(format), headers=headers)
}

CurrDelete <- function(path, sess) {
  curr("DELETE", path, sess)
}

CurrGet <- function(path, sess) {
  curr("GET", path, sess)
}

CurrPost <- function() {
}

CurrPut <- function(path, content="", header="", sess) {
  if (!is.null(sess$headers)) header <- sess$headers
  curr("PUT", path, sess, content, header)
}


## Utilities -- not exported

## TODO: XML
curr <- function(method, path, sess, content=NULL, header=NULL) {
  handle <- getCurlHandle()
  url <- paste(sess$base.url, path, sep="")

  if (!is.null(content)) {
    if (sess$format == "json") {
      content <- toJSON(content)
    }
  }

  body <- if (method == "DELETE") {

    body <- getURL(url,
                   customrequest=method,
                   curl=handle)

  } else if (method == "PUT") {

    getURL(url,
           customrequest=method,
           postfields=content,
           postfieldsize=strlen(content),
           httpheader=header,
           curl=handle)

  } else {

    getURL(url, curl=handle)

  }

  if (sess$format == "json") {
    body <- fromJSON(body)
  }

  response(body, handle)
}

response <- function(body, handle) {
  info <- getCurlInfo(handle)
  list(body=body,
       content.type=info$content.type,
       status=info$response.code,
       redirect.count=info$redirect.count,
       url=info$effective.url)
}

strlen <- function(str) {
  length(strsplit(str, "")[[1]])
}

is.empty.str <- function(str) {
  str == ""
}