Archive version of: couchdb3.r ... version: 1 ... iho 20-Jan-2010

Amendment note: new script || Publicly available? Yes

REBOL [
	Title: "CouchDB Client"
	Author: "Ingo Hohmann"
	Version: 0.0.10
	Date: 2009-11-05
	File: %couchdb3.r
	Purpose: {Use couchdb as a datastore ( http://couchdb.apache.org/ )}
   Comments: {
      Api to access a CouchDB instance.
      - no special handling of login
      - no https
      - no error handling
   }
	library: [ 
		level: 'intermediate 
		platform: 'all 
		type: [tool module] 
		domain: [database http] 
		tested-under: {R3 2.100.96.3.1} 
		support: none 
		license: bsd
		see-also: none 
	] 
]

secure [debug allow]
trace/back on

;do %json3.r

json: module [
	Title: "JSON to Rebol Converter"
	Name: 'json
	Version: 0.0.5
	Type: 'module
	Exports: [json-to-rebol rebol-to-json]
	Comments: {
		The json.r script on rebol.org doesn't work on r3, and instead of trying to 
		make it work, I thought, I'd just write a really basic json converter to play
		with. (My first version was abuot ten lines all in all). In the end, this is what
		happened.
	}
	History: [
		0.0.1 "first version trying to be complete"
		0.0.2 "in work attach"
		0.0.3 "in work view query"
		0.0.4 "start of bulk api"
		0.0.5 "error handling"
	]
	Todo: [
		"string: handling of special characters"
		"Testing"
		"check, if all datatypes are handled correctly"
		"embedded objects in rebol"
		"error handling!"
	]
	Done: []
][
	;======== Helper Functions ========
	to-isodate: funct [date [date!] /timestamp][
		rejoin [date/year #"-" either date/month < 10 [#"0"][""] date/month #"-" either date/day < 10 [#"0"][""] date/day either timestamp [rejoin [#" " date/time #"+" date/zone]][""]]
	]

	;======= JSON to REBOL ==========
	object: [remove #"{" opt members spc remove #"}"]
	embedded-object: [change #"{" "#[object! [" opt members spc change #"}" "]]"]
	members: [ pair any [change #"," #" " members]]
	pair: [ spc name-string remove spc #":" insert #" " spc value]
	array: [#"[" spc opt elements spc #"]"]
	elements: [ value spc any [change #"," #" " spc value ]]
	value: [ string | number | embedded-object | array | vtrue | vfalse | vnull]
	vtrue: [change "true" "#[true]"]
	vfalse: [change "false" "#[false]"]
	vnull: [change "null" "#[none]"]
	string: [change #"^"" #"{" any chars change #"^"" #"}"]
	name-string: [remove #"^"" any chars remove #"^""]
	chars: [ 
		any [char | change "{" "^{" | change "}" "^}" ;| change "^^"  "^^^^"
			| remove #"\" [ 
				#"^"" | #"\" | #"/" 
				| change #"b" #"^H" | change #"f" #"^L" | change #"n" #"^/" 
				| change #"r" #"^M" | change #"t" #"^-" 
	]]]
	char: complement charset {"\^{^}}
	hexdigit: charset [#"a" - #"f" #"A" - #"F" #"0" - #"1"]
	number: [int opt [frac | exp opt frac]]
	int: [ opt [#"-" | #"+"] some digit ]
	digit: charset [#"-" #"0" - #"9"]
	frac: [#"." some digit]
	exp: [ e some digit]
	e: [[#"e" | #"E"] opt [#"+" | #"-"]]
	space: charset " ^/^-"
	spc: [any space]

	json-to-rebol: func [
		"Converts JSON String to Rebol object! / block!"
		json [string! binary!] /local type
	][
		if binary? json [json: to-string json]
		parse c: json [object (type: 'object)| array (type: 'array)]
		either 'object = type [
			make object! load c
		][
			load c
		]
	]
	
	;========== REBOL to JSON ===========
	json-string: none
	rebol-object: [(emit #"{") any [rname (emit #":") rvalue (emit #",")] (change back tail json-string #"}")]
	rebol-block: [(emit #"[") any [rvalue (emit #",")] (change back tail json-string #"]")]
	rname: [set name skip (emit mold form to-word name)]
	rvalue: [ rnumber | rstring | and block! into rebol-block | robject | rnone | rtrue | rfalse | rfile | rdate | copy v skip (emit mold form v)]
	robject: [and change copy o object! (to-block o) into rebol-object]
	rnumber: [set v number! (emit v)]
	rnone: [none! (emit "null")]
	rtrue: [true (emit "true")]
	rfalse: [false (emit "false")]
	rfile: [ set v file! (emit mold json-escape-string to-local-file v)]
	rstring: [set v string! (emit mold json-escape-string v)]
	rblock: [and block! into [any rvalue]]
	rdate: [set v date! (emit mold to-isodate/timestamp v)]
    escape-table: [
        {\"} "^""
        {\\} "\"
        {\/} "/"
        {\>} ">"
        {\b} "^H"
        {\f} "^L"
        {\r} "^M"
        {\n} "^/"
        {\t} "^-"
    ]

	json-escape-string: func[s [string!]][
		foreach [json rebol] escape-table [
			replace/all s rebol json 
		]
		s
	]
	
	rebol-to-json: func [
		"Converts Rebol object! to JSON String"
		val [object!]
		;/local json-string
	][
		json-string: copy ""
		emit: func[v][append json-string v]
		
		if object? val [
			val: copy/deep to-block val
			parse val rebol-object
		]
		json-string
	]
]

couchdb: module [
	Title: "CouchDB Client"
	Name: 'couchdb
	Version: 0.0.4
	Type: 'module
	Author: "Ingo Hohmann"
	Exports: []
	Todo: [
		"work with views"
		"attachments"
		"bulk api"
	]
][
	url: none
	
	; ---- Helpers
	write-db: func [
		"Use write to send data to the database"
		url [url!] data
	][
		json/json-to-rebol write url data
	]
	
	read-db: func[
		"Use read to read data from the database"
		url [url!]
	][
		json/json-to-rebol read url
	]
	
	payload: func [
		"Wrap data into an object"
		data
	][
		make object! compose [data: (data)]
	]
	
	; ---- Database level api
	db-open: func [
		"Open a database"
		db-url [url!]
	][
		url: dirize db-url
		read-db url
	]
	
	db-create: func [
		"Create a new database"
		db [url! string! word!] /local parts base-url
	][
		if not url? db [db: join first split-path url db]
		write-db db [PUT [] ""]
	]
	
	db-delete: func [
		"Delete a database"
		db [url! string! word!] 
		/local parts base-url
	][
		if not url? db [db: join first split-path url db]
		write-db db [DELETE [] ""]
	]
	
	db-info: func[
		"Return Database META-information"
	][
		read-db url
	]
	
	db-changes: func [
		"Return database changes information"
		/since seq
	][
		my-url: rejoin [url "_changes" either since [join "?since=" seq][""]]
		read-db my-url
	]
	
	db-compact: func [][
		write-db url/_compact ""
	]
	
	; ------ helper functions --------
	uuid: func [
		"Get a UUID from the server" /local server-url answer
	][
		server-url: first split-path url
		answer: read-db server-url/_uuids
		answer/uuids/1
	]
	
	; -------- Server API
	server: func [
		"read arbitrary data from server" 
		path [file! string!]
		/local server-url response
	][
		server-url: first split-path url
		read-db server-url/:path
	]
	
	replicate: func [
		"Replicate databases"
		source-db
		target-db
		/continuous-replication
		/create-target-db
		/local request
	][
		request: make object! [source: source-db target: target-db]
		if continuous-replication [extend request 'continuous true]
		if create-target-db [extend request 'create-target true]
		write-db join first split-path url "_replicate" json/rebol-to-json request 
	]
	; -------- Document API -----------
	; Single Document API
	get: func [ 
		"Get a single document by id, does not consider conflicts"
		id [word! string!]
	][
		read-db url/:id
	]

	post: func [ 
		"Save a document, returns error if conflicting"
		data [object! string!]
	][
		either object? data [
			write-db url json/rebol-to-json data
		][
			write-db url data
		]
	]

	copy-doc: func [
		"Copy a document"
		id [word! string!]
		to [word! string!]
		/local parts
	][
		write-db url/:id compose/deep [COPY [Destination: (to)] ""]
	]
	

	; bulk document API
	doc: func [ 
		"Get a single document and all conflicting revisions by id" 
		id [word! string!] 
		/save
	][
		read-db join url/:id '?open_revs=all
	]
	
	save-doc: func [
		"Save a single document, possibly creating conflicts"
		data [object! string!] 
		/local template
	][
		template: json/rebol-to-json make object! [
			all_or_nothing: true
			docs: either object? data [json/rebol-to-json data][data]
		]
		data: rejoin [ 
			{^{"all_or_nothing":true,"docs":[}               ;}
			either object? data [json/rebol-to-json data][data]
			"]}"
			]
		write-db url/_bulk_docs data
	]
	
	save-bulk: func [
		"Save a block of documents, possibly creating conflicts"
		data [block!] "block of rebol objects"
		;/noconflict "do not create confliciting documents"
		/local template
	][
		template: json/rebol-to-json make object! [
			all_or_nothing: true
			docs: either object? data [json/rebol-to-json data][data]
		]
		data: rejoin [ 
			{^{"all_or_nothing":true,"docs":[}               ;}
			either object? data [json/rebol-to-json data][data]
			"]}"
			]
		write-db url/_bulk_docs data
	]
	
	; ------- Other document functions
	view: func [ 
		"query a view"
		design "design name"
		view "view name"
		/key "to get a single document by key-value"
			key-value 
		/range "to get a range of documents"
			start-value [string!] end-value [string!]
		/local my-url
	][
		assert [not all [key range] any [key range] "exactly 1 of key / range needs to be set"] 
		my-url: url/_design/:design/_view/:view
		either key [
			my-url: rejoin [my-url "?key=" mold key-value]
		][
			if range [my-url: rejoin [my-url "?startkey=" mold start-value "&endkey=" mold end-value]]
		]
		read-db my-url
	]
	
	update-doc: funct [ 
		"to update design documents, etc ..."
		id 
		json-data [object!]
		/local olddoc data
	][
		olddoc: get id
		data: json/json-to-rebol json-data
		extend data '_rev olddoc/_rev
		post data
	]

	attach: funct [ 
		"Add an attachment to document with id: id"
		id [string!] "document ID to attach to"
		attachment-name "Name the attachment"
		data [string! binary! file!] "Data to attach"
		/rev revision
		/get-rev "get revision of current document"
		/type mime-type "set mimetype if attachment (defaults to text/plain)"
		/local parts dummy
	][
		if get-rev [
			dummy: get id
			revision: dummy/_rev
			rev: true
		]
		parts: decode-url url
		default mime-type "text/plain"
		if file? data [data: read data]
		my-url: rejoin [url id "/" attachment-name either rev [join "?rev=" revision][""]]

		write-db my-url compose/deep [PUT [Content-Type: (mime-type)] (data)]
	]
]

test: func [ testcase][
	print [newline "===>" testcase]
	probe try [do testcase]
]

tests: [
	test [couchdb/db-create http://localhost:5984/hoh_test_db]
	test [couchdb/db-open http://localhost:5984/hoh_test_db]
	test [couchdb/post payload "Dies ist ein Test"]
	test [couchdb/post make object! [_id: "test" data: "Noch ein Test"]]
	test [couchdb/attach "test2" "attachment" "Test-string" ]
	test [couchdb/attach/get-rev "test2" "attachment" "Test-string 2" ]
	test [couchdb/db-delete "hoh_test_db"]
	;test [couchdb/db-open http://localhost:8200/db2]
	;test [rtj json-to-rebol to-string read http://localhost:5984/db2/3 ]
	;test [json-to-rebol to-string read http://localhost:5984/db2/3 ]
	;test [rebol-to-json json-to-rebol to-string read http://localhost:5984/db2/3 ]
	;test [x: couchdb/get "3"]
	;test [v: couchdb/get  "_design/example/_view/foo"]
	;test [couchdb/view 'example 'foo]
	;test [couchdb/view/key 'example 'foo "3"]
	;test [couchdb/view/range 'example 'foo "3" "4"]
	;test [couchdb/update-doc "_design/example" to-string read %design.json]
	;test [couchdb/attach "9" "attachment" "Test-string" ]
	;test [couchdb/attach/get-rev "13" "attachment" "Test-string" ]
	;test [x: couchdb/doc "3"]
	;test [x: couchdb/get "3"]
	;x/data: join "x" x/data
	;test [couchdb/save-doc x]
	;x/data: join "x" x/data
	;test [couchdb/save-doc x]
	;test [couchdb/copy-doc "3" "test3"]
	;test [json/rebol-to-json make object! [date: now]]
]

;do tests