redirects get max-redirects < [
request get clone
swap "location" header redirect-url
- "GET" >>method swap (with-http-request)
+ "GET" >>method swap with-http-request
] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
request get url>> url-addr ascii <client> drop
1 minutes over set-timeout ;
-: (with-http-request) ( request quot: ( chunk -- ) -- response )
+PRIVATE>
+
+: with-http-request ( request quot: ( chunk -- ) -- response )
swap
request [
<request-socket> [
: success? ( code -- ? ) 200 299 between? ;
-ERROR: download-failed response ;
+ERROR: download-failed response data ;
+
+M: download-failed error.
+ "HTTP request failed:" print nl
+ [ response>> . ] [ data>> . ] bi ;
-: check-response ( response -- response )
- dup code>> success? [ download-failed ] unless ;
+: check-response* ( response data -- response data )
+ over code>> success? [ download-failed ] unless ;
: with-http-request ( request quot -- response )
[ (with-http-request) check-response ] with-destructors ; inline
: http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make
- over content-charset>> decode ;
+ over content-charset>> decode check-response* ;
+
+: <client-request> ( url -- request )
+ <request> swap >url ensure-port >>url ;
+
+: <client-data-request> ( data url -- request )
+ <client-request> swap >>post-data ;
: <get-request> ( url -- request )
"GET" <client-request> ;
<get-request> http-request ;
: with-http-get ( url quot -- response )
- [ <get-request> ] dip with-http-request ; inline
+ [ <get-request> ] dip with-http-request check-response ; inline
+
+: <delete-request> ( url -- request )
+ <client-request> "DELETE" >>method ;
+
+: http-delete ( url -- response data )
+ <delete-request> http-request ;
+
+: <trace-request> ( url -- request )
+ <client-request> "TRACE" >>method ;
+
+: http-trace ( url -- response data )
+ <trace-request> http-request ;
: download-name ( url -- name )
present file-name "?" split1 drop "/" ?tail drop ;
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: 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
+ [ ] [ 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 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs continuations debugger hashtables http http.client io 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? [
+ data>> 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 "localhost" ;
+: default-couch-port 5984 ;
+: default-uuids-to-cache 100 ;
+
+: <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-post ( server -- uuids )
+ uuids-url f swap couch-post "uuids" swap at >vector ;
+
+: get-uuids ( server -- server )
+ dup uuids-post [ 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 "application/json" <post-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, count, descending, etc.
+! - loading specific revisions
+! - views
+! - attachments
+! - bulk insert/update
+! - ...?
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: boxes hats kernel namespaces symbols tools.test ;
+IN: hats.tests
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! caps
+[ rabbit ] [ rabbit <cap> out ] unit-test
+[ rabbit ] [ f <cap> rabbit in out ] unit-test
+[ rabbit ] [ rabbit <cap> take ] unit-test
+[ f ] [ rabbit <cap> empty-hat out ] unit-test
+[ rabbit f ] [ rabbit <cap> [ take ] keep out ] unit-test
+[ rabbit t ] [ rabbit <cap> [ take ] keep empty-hat? ] unit-test
+[ lion ] [ rabbit <cap> [ drop lion ] change-hat out ] unit-test
+
+! bowlers
+[ giraffe ] [ [ giraffe rabbit set rabbit <bowler> out ] with-scope ] unit-test
+
+[ rabbit ]
+[
+ [
+ lion rabbit set [
+ rabbit rabbit set rabbit <bowler> out
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <bowler>
+ [
+ lion rabbit set [
+ rabbit rabbit set out
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <bowler>
+ [
+ elephant rabbit set [
+ rabbit rabbit set
+ ] with-scope
+ out
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <bowler>
+ [
+ elephant in [
+ rabbit in out
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <bowler>
+ [
+ elephant in [
+ rabbit in
+ ] with-scope
+ out
+ ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <top-hat> out ] unit-test
+[ giraffe ] [ rabbit <top-hat> giraffe in out ] unit-test
+
+! Tuple hats
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+ rabbit <foo> ;
+
+: test-slot-hat ( -- slot-hat )
+ test-tuple 2 <slot-hat> ; ! hack!
+
+[ rabbit ] [ test-slot-hat out ] unit-test
+[ lion ] [ test-slot-hat lion in out ] unit-test
+
+! Boxes as hats
+[ rabbit ] [ <box> rabbit in out ] unit-test
+[ <box> rabbit in lion in ] must-fail
+[ <box> out ] must-fail
--- /dev/null
+! Copyright (C) 2008 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors boxes kernel namespaces ;
+IN: hats
+
+! Bullwinkle: Hey Rocky, watch me pull a rabbit out of my hat!
+! Rocky: But that trick never works!
+! Bullwinkle: This time for sure!
+
+! hat protocol
+MIXIN: hat
+
+GENERIC: out ( hat -- object )
+GENERIC: (in) ( object hat -- )
+
+: in ( hat object -- hat ) over (in) ; inline
+: empty-hat? ( hat -- ? ) out not ; inline
+: empty-hat ( hat -- hat ) f in ; inline
+: take ( hat -- object ) dup out f rot (in) ; inline
+: change-hat ( hat quot -- hat )
+ over >r >r out r> call r> swap in ; inline
+
+! caps (the simplest of hats)
+TUPLE: cap object ;
+C: <cap> cap
+M: cap out ( cap -- object ) object>> ;
+M: cap (in) ( object cap -- ) (>>object) ;
+INSTANCE: cap hat
+
+! bowlers (dynamic variable hats)
+TUPLE: bowler variable ;
+C: <bowler> bowler
+M: bowler out ( bowler -- object ) variable>> get ;
+M: bowler (in) ( object bowler -- ) variable>> set ;
+INSTANCE: bowler hat
+
+! Top Hats (global variable hats)
+TUPLE: top-hat variable ;
+C: <top-hat> top-hat
+M: top-hat out ( top-hat -- object ) variable>> get-global ;
+M: top-hat (in) ( object top-hat -- ) variable>> set-global ;
+INSTANCE: top-hat hat
+
+USE: slots.private
+! Slot hats
+TUPLE: slot-hat tuple slot ;
+C: <slot-hat> slot-hat
+: >slot-hat< ( slot-hat -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-hat out ( slot-hat -- object ) >slot-hat< slot ;
+M: slot-hat (in) ( object slot-hat -- ) >slot-hat< set-slot ;
+INSTANCE: slot-hat hat
+
+! Put a box on your head
+M: box out ( box -- object ) box> ;
+M: box (in) ( object box -- ) >box ;
+INSTANCE: box hat
+
--- /dev/null
+A protocol for getting and setting
projects / factor.git / commitdiff