: http-put ( post-data url -- response data )
<put-request> http-request ;
+: <delete-request> ( url -- request )
+ "DELETE" <client-request> ;
+
+: http-delete ( url -- response data )
+ <delete-request> http-request ;
+
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when
Slava Pestov
+Alex Chapman
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
+USING: boxes help.markup help.syntax kernel math namespaces ;
IN: refs
-ARTICLE: "refs" "References to assoc entries"
-"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary."
+ARTICLE: "refs" "References"
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
{ $subsection get-ref }
{ $subsection set-ref }
+{ $subsection set-ref* }
{ $subsection delete-ref }
-"References to keys:"
+"References to objects:"
+{ $subsection obj-ref }
+{ $subsection <obj-ref> }
+"References to assoc keys:"
{ $subsection key-ref }
{ $subsection <key-ref> }
-"References to values:"
+"References to assoc values:"
{ $subsection value-ref }
{ $subsection <value-ref> }
+"References to variables:"
+{ $subsection var-ref }
+{ $subsection <var-ref> }
+{ $subsection global-var-ref }
+{ $subsection <global-var-ref> }
+"References to tuple slots:"
+{ $subsection slot-ref }
+{ $subsection <slot-ref> }
+"Using boxes as references:"
+{ $subsection "box-refs" }
"References are used by the UI inspector." ;
ABOUT: "refs"
+ARTICLE: "refs-protocol" "Reference Protocol"
+"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
+{ $subsection get-ref }
+{ $subsection set-ref }
+"References may also implement:"
+{ $subsection delete-ref } ;
+
+ARTICLE: "box-refs" "Using Boxes as References"
+"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+
HELP: ref
-{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ;
+{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
HELP: delete-ref
{ $values { "ref" ref } }
-{ $description "Deletes the association entry pointed at by this reference." } ;
+{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ;
HELP: get-ref
{ $values { "ref" ref } { "obj" object } }
-{ $description "Outputs the key or the value pointed at by this reference." } ;
+{ $description "Outputs the value pointed at by this reference." } ;
HELP: set-ref
{ $values { "obj" object } { "ref" ref } }
-{ $description "Stores a new key or value at by this reference." } ;
+{ $description "Stores a new value at this reference." } ;
+
+HELP: obj-ref
+{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link <obj-ref> } "." } ;
+
+HELP: <obj-ref>
+{ $values { "obj" object } { "obj-ref" obj-ref } }
+{ $description "Creates a reference which contains the value it references." } ;
+HELP: var-ref
+{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link <var-ref> } "." } ;
+
+HELP: <var-ref>
+{ $values { "var" object } { "var-ref" var-ref } }
+{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ;
+
+HELP: global-var-ref
+{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link <global-var-ref> } "." } ;
+
+HELP: <global-var-ref>
+{ $values { "var" object } { "global-var-ref" global-var-ref } }
+{ $description "Creates a reference to a global variable." } ;
+
+HELP: slot-ref
+{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link <slot-ref> } "." } ;
+
+HELP: <slot-ref>
+{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } }
+{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ;
+
HELP: key-ref
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
-{ get-ref set-ref delete-ref } related-words
+{ get-ref set-ref delete-ref set-ref* } related-words
+
+{ <obj-ref> <var-ref> <global-var-ref> <slot-ref> <key-ref> <value-ref> } related-words
-{ <key-ref> <value-ref> } related-words
+HELP: set-ref*
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
+
+HELP: ref-on
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to t." } ;
+
+HELP: ref-off
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to f." } ;
+
+HELP: ref-inc
+{ $values { "ref" ref } }
+{ $description "Increment the value of the ref by 1." } ;
+
+HELP: ref-dec
+{ $values { "ref" ref } }
+{ $description "Decrement the value of the ref by 1." } ;
+
+HELP: take
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Retrieve the value of the ref and then delete it, returning the value." } ;
+
+{ ref-on ref-off ref-inc ref-dec take } related-words
+{ take delete-ref } related-words
+{ on ref-on } related-words
+{ off ref-off } related-words
+{ inc ref-inc } related-words
+{ dec ref-dec } related-words
-USING: refs tools.test kernel ;
+USING: boxes kernel namespaces refs tools.test ;
+IN: refs.tests
+! assoc-refs
[ 3 ] [
H{ { "a" 3 } } "a" <value-ref> get-ref
] unit-test
set-ref
] keep
] unit-test
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! obj-refs
+[ rabbit ] [ rabbit <obj-ref> get-ref ] unit-test
+[ rabbit ] [ f <obj-ref> rabbit set-ref* get-ref ] unit-test
+[ rabbit ] [ rabbit <obj-ref> take ] unit-test
+[ rabbit f ] [ rabbit <obj-ref> [ take ] keep get-ref ] unit-test
+[ lion ] [ rabbit <obj-ref> dup [ drop lion ] change-ref get-ref ] unit-test
+
+! var-refs
+[ giraffe ] [ [ giraffe rabbit set rabbit <var-ref> get-ref ] with-scope ] unit-test
+
+[ rabbit ]
+[
+ [
+ lion rabbit set [
+ rabbit rabbit set rabbit <var-ref> get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ lion rabbit set [
+ rabbit rabbit set get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant rabbit set [
+ rabbit rabbit set
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref* get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref*
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <global-var-ref> get-ref ] unit-test
+[ giraffe ] [ rabbit <global-var-ref> giraffe set-ref* get-ref ] unit-test
+
+! Tuple refs
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+ rabbit <foo> ;
+
+: test-slot-ref ( -- slot-ref )
+ test-tuple 2 <slot-ref> ; ! hack!
+
+[ rabbit ] [ test-slot-ref get-ref ] unit-test
+[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test
+
+! Boxes as refs
+[ rabbit ] [ <box> rabbit set-ref* get-ref ] unit-test
+[ <box> rabbit set-ref* lion set-ref* ] must-fail
+[ <box> get-ref ] must-fail
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple kernel assocs accessors ;
+USING: kernel assocs accessors boxes math namespaces ;
IN: refs
-TUPLE: ref assoc key ;
+MIXIN: ref
-: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
-
-: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
+GENERIC: delete-ref ( ref -- )
+
+! works like >>slot words
+: set-ref* ( ref obj -- ref ) over set-ref ;
+
+! very similar to change, on, off, +@, inc, and dec from namespaces
+: change-ref ( ref quot -- )
+ [ [ get-ref ] keep ] dip dip set-ref ; inline
+: ref-on ( ref -- ) t swap set-ref ;
+: ref-off ( ref -- ) f swap set-ref ;
+: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ;
+: ref-inc ( ref -- ) 1 swap ref-+@ ;
+: ref-dec ( ref -- ) -1 swap ref-+@ ;
+
+: take ( ref -- obj )
+ dup get-ref swap delete-ref ;
+
+! delete-ref defaults to setting ref to f
+M: ref delete-ref ref-off ;
+
+TUPLE: obj-ref obj ;
+C: <obj-ref> obj-ref
+M: obj-ref get-ref obj>> ;
+M: obj-ref set-ref (>>obj) ;
+INSTANCE: obj-ref ref
+
+TUPLE: var-ref var ;
+C: <var-ref> var-ref
+M: var-ref get-ref var>> get ;
+M: var-ref set-ref var>> set ;
+INSTANCE: var-ref ref
+
+TUPLE: global-var-ref var ;
+C: <global-var-ref> global-var-ref
+M: global-var-ref get-ref var>> get-global ;
+M: global-var-ref set-ref var>> set-global ;
+INSTANCE: global-var-ref ref
+
+USE: slots.private
+TUPLE: slot-ref tuple slot ;
+C: <slot-ref> slot-ref
+: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-ref get-ref >slot-ref< slot ;
+M: slot-ref set-ref >slot-ref< set-slot ;
+INSTANCE: slot-ref ref
+
+M: box get-ref box> ;
+M: box set-ref >box ;
+M: box delete-ref box> drop ;
+INSTANCE: box ref
+
+TUPLE: assoc-ref assoc key ;
+
+: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
+
+M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
-TUPLE: key-ref < ref ;
+TUPLE: key-ref < assoc-ref ;
C: <key-ref> key-ref
M: key-ref get-ref key>> ;
-M: key-ref set-ref >ref< rename-at ;
+M: key-ref set-ref >assoc-ref< rename-at ;
+INSTANCE: key-ref ref
-TUPLE: value-ref < ref ;
+TUPLE: value-ref < assoc-ref ;
C: <value-ref> value-ref
-M: value-ref get-ref >ref< at ;
-M: value-ref set-ref >ref< set-at ;
+M: value-ref get-ref >assoc-ref< at ;
+M: value-ref set-ref >assoc-ref< set-at ;
+INSTANCE: value-ref ref
HELP: url-encode
{ $values { "str" string } { "encoded" string } }
-{ $description "URL-encodes a string." } ;
+{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ;
+
+HELP: url-encode-full
+{ $values { "str" string } { "encoded" string } }
+{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ;
HELP: url-quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
[ "/_-.:" member? ]
} 1|| ; foldable
+! see http://tools.ietf.org/html/rfc3986#section-2.2
+: gen-delim? ( ch -- ? )
+ ":/?#[]@" member? ; foldable
+
+: sub-delim? ( ch -- ? )
+ "!$&'()*+,;=" member? ; foldable
+
+: reserved? ( ch -- ? )
+ [ gen-delim? ] [ sub-delim? ] bi or ; foldable
+
+! see http://tools.ietf.org/html/rfc3986#section-2.3
+: unreserved? ( ch -- ? )
+ {
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "-._~" member? ]
+ } 1|| ; foldable
+
<PRIVATE
: push-utf8 ( ch -- )
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
+: url-encode-full ( str -- encoded )
+ [
+ [ dup unreserved? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
<PRIVATE
: url-decode-hex ( index str -- )
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ;
+IN: couchdb.tests
+
+! You must have a CouchDB server (currently only the version from svn will
+! work) running on localhost and listening on the default port for these tests
+! to work.
+
+<default-server> "factor-test" <db> [
+ [ ] [ couch get create-db ] unit-test
+ [ couch get create-db ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+ [ couch get delete-db ] must-fail
+ [ ] [ couch get ensure-db ] unit-test
+ [ ] [ couch get ensure-db ] unit-test
+ [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test
+ [ ] [ couch get compact-db ] unit-test
+ [ t ] [ couch get server>> next-uuid string? ] unit-test
+ [ ] [ H{
+ { "Subject" "I like Planktion" }
+ { "Tags" { "plankton" "baseball" "decisions" } }
+ { "Body"
+ "I decided today that I don't like baseball. I like plankton." }
+ { "Author" "Rusty" }
+ { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
+ } save-doc ] unit-test
+ [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test
+ [ t ] [ "id" get dup load-doc id> = ] unit-test
+ [ ] [ "id" get load-doc save-doc ] unit-test
+ [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test
+ [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
+ [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test
+ [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test
+ [ ] [ H{
+ { "_id" "_design/posts" }
+ { "language" "javascript" }
+ { "views" H{
+ { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
+ }
+ }
+ } save-doc ] unit-test
+ [ t ] [ "id" get load-doc delete-doc string? ] unit-test
+ [ "id" get load-doc ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+] with-couch
--- /dev/null
+! Copyright (C) 2008, 2009 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs continuations debugger hashtables http
+http.client io io.encodings.string io.encodings.utf8 json.reader
+json.writer kernel make math math.parser namespaces sequences strings
+urls urls.encoding vectors ;
+IN: couchdb
+
+! NOTE: This code only works with the latest couchdb (0.9.*), because old
+! versions didn't provide the /_uuids feature which this code relies on when
+! creating new documents.
+
+SYMBOL: couch
+: with-couch ( db quot -- )
+ couch swap with-variable ; inline
+
+! errors
+TUPLE: couchdb-error { data assoc } ;
+C: <couchdb-error> couchdb-error
+
+M: couchdb-error error. ( error -- )
+ "CouchDB Error: " write data>>
+ "error" over at [ print ] when*
+ "reason" swap at [ print ] when* ;
+
+PREDICATE: file-exists-error < couchdb-error
+ data>> "error" swap at "file_exists" = ;
+
+! http tools
+: couch-http-request ( request -- data )
+ [ http-request ] [
+ dup download-failed? [
+ response>> body>> json> <couchdb-error> throw
+ ] [
+ rethrow
+ ] if
+ ] recover nip ;
+
+: couch-request ( request -- assoc )
+ couch-http-request json> ;
+
+: couch-get ( url -- assoc )
+ <get-request> couch-request ;
+
+: couch-put ( post-data url -- assoc )
+ <put-request> couch-request ;
+
+: couch-post ( post-data url -- assoc )
+ <post-request> couch-request ;
+
+: couch-delete ( url -- assoc )
+ <delete-request> couch-request ;
+
+: response-ok ( assoc -- assoc )
+ "ok" over delete-at* and t assert= ;
+
+: response-ok* ( assoc -- )
+ response-ok drop ;
+
+! server
+TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
+
+: default-couch-host ( -- host ) "localhost" ; inline
+: default-couch-port ( -- port ) 5984 ; inline
+: default-uuids-to-cache ( -- n ) 100 ; inline
+
+: <server> ( host port -- server )
+ V{ } clone default-uuids-to-cache server boa ;
+
+: <default-server> ( -- server )
+ default-couch-host default-couch-port <server> ;
+
+: (server-url) ( server -- )
+ "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
+
+: server-url ( server -- url )
+ [ (server-url) ] "" make ;
+
+: all-dbs ( server -- dbs )
+ server-url "_all_dbs" append couch-get ;
+
+: uuids-url ( server -- url )
+ [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
+
+: uuids-get ( server -- uuids )
+ uuids-url couch-get "uuids" swap at >vector ;
+
+: get-uuids ( server -- server )
+ dup uuids-get [ nip ] curry change-uuids ;
+
+: ensure-uuids ( server -- server )
+ dup uuids>> empty? [ get-uuids ] when ;
+
+: next-uuid ( server -- uuid )
+ ensure-uuids uuids>> pop ;
+
+! db
+TUPLE: db { server server } { name string } ;
+C: <db> db
+
+: (db-url) ( db -- )
+ [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
+
+: db-url ( db -- url )
+ [ (db-url) ] "" make ;
+
+: create-db ( db -- )
+ f swap db-url couch-put response-ok* ;
+
+: ensure-db ( db -- )
+ [ create-db ] [
+ dup file-exists-error? [ 2drop ] [ rethrow ] if
+ ] recover ;
+
+: delete-db ( db -- )
+ db-url couch-delete drop ;
+
+: db-info ( db -- info )
+ db-url couch-get ;
+
+: compact-db ( db -- )
+ f swap db-url "_compact" append couch-post response-ok* ;
+
+: all-docs ( db -- docs )
+ ! TODO: queries. Maybe pass in a hashtable with options
+ db-url "_all_docs" append couch-get ;
+
+: <json-post-data> ( assoc -- post-data )
+ >json utf8 encode "application/json" <post-data> swap >>data ;
+
+! documents
+: id> ( assoc -- id ) "_id" swap at ;
+: >id ( assoc id -- assoc ) "_id" pick set-at ;
+: rev> ( assoc -- rev ) "_rev" swap at ;
+: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
+: attachments> ( assoc -- attachments ) "_attachments" swap at ;
+: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
+
+: copy-key ( to from to-key from-key -- )
+ rot at spin set-at ;
+
+: copy-id ( to from -- )
+ "_id" "id" copy-key ;
+
+: copy-rev ( to from -- )
+ "_rev" "rev" copy-key ;
+
+: id-url ( id -- url )
+ couch get db-url swap url-encode-full append ;
+
+: doc-url ( assoc -- url )
+ id> id-url ;
+
+: temp-view ( view -- results )
+ <json-post-data> couch get db-url "_temp_view" append couch-post ;
+
+: temp-view-map ( map -- results )
+ "map" H{ } clone [ set-at ] keep temp-view ;
+
+: save-doc-as ( assoc id -- )
+ [ dup <json-post-data> ] dip id-url couch-put response-ok
+ [ copy-id ] [ copy-rev ] 2bi ;
+
+: save-new-doc ( assoc -- )
+ couch get server>> next-uuid save-doc-as ;
+
+: save-doc ( assoc -- )
+ dup id> [ save-doc-as ] [ save-new-doc ] if* ;
+
+: load-doc ( id -- assoc )
+ id-url couch-get ;
+
+: delete-doc ( assoc -- deletion-revision )
+ [
+ [ doc-url % ]
+ [ "?rev=" % "_rev" swap at % ] bi
+ ] "" make couch-delete response-ok "rev" swap at ;
+
+: remove-keys ( assoc keys -- )
+ swap [ delete-at ] curry each ;
+
+: remove-couch-info ( assoc -- )
+ { "_id" "_rev" "_attachments" } remove-keys ;
+
+! : construct-attachment ( content-type data -- assoc )
+! H{ } clone "name" pick set-at "content-type" pick set-at ;
+!
+! : add-attachment ( assoc name attachment -- )
+! pick attachments> [ H{ } clone ] unless*
+!
+! : attach ( assoc name content-type data -- )
+! construct-attachment H{ } clone
+
+! TODO:
+! - startkey, limit, descending, etc.
+! - loading specific revisions
+! - views
+! - attachments
+! - bulk insert/update
+! - ...?
projects / factor.git / commitdiff