extra/couchdb/couchdb.factor

   1 ! Copyright (C) 2008, 2009 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs continuations debugger hashtables http
   4 http.client io io.encodings.string io.encodings.utf8 json.reader
   5 json.writer kernel locals make math math.parser namespaces sequences
   6 strings urls urls.encoding vectors ;
   7 IN: couchdb
   8
   9 ! NOTE: This code only works with the latest couchdb (0.9.*), because old
  10 ! versions didn't provide the /_uuids feature which this code relies on when
  11 ! creating new documents.
  12
  13 SYMBOL: couch
  14 : with-couch ( db quot -- )
  15     couch swap with-variable ; inline
  16
  17 ! errors
  18 TUPLE: couchdb-error { data assoc } ;
  19 C: <couchdb-error> couchdb-error
  20
  21 M: couchdb-error error. ( error -- )
  22     "CouchDB Error: " write data>>
  23     "error" over at [ print ] when*
  24     "reason" of [ print ] when* ;
  25
  26 PREDICATE: file-exists-error < couchdb-error
  27     data>> "error" of "file_exists" = ;
  28
  29 ! http tools
  30 : couch-http-request ( request -- data )
  31     [ http-request ] [
  32         dup download-failed? [
  33             response>> body>> json> <couchdb-error> throw
  34         ] [
  35             rethrow
  36         ] if
  37     ] recover nip ;
  38
  39 : couch-request ( request -- assoc )
  40     couch-http-request json> ;
  41
  42 : couch-get ( url -- assoc )
  43     <get-request> couch-request ;
  44
  45 : couch-put ( post-data url -- assoc )
  46     <put-request> couch-request ;
  47
  48 : couch-post ( post-data url -- assoc )
  49     <post-request> couch-request ;
  50
  51 : couch-delete ( url -- assoc )
  52     <delete-request> couch-request ;
  53
  54 : response-ok ( assoc -- assoc )
  55     "ok" over delete-at* and t assert= ;
  56
  57 : response-ok* ( assoc -- )
  58     response-ok drop ;
  59
  60 ! server
  61 TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
  62
  63 CONSTANT: default-couch-host "localhost"
  64 CONSTANT: default-couch-port 5984
  65 CONSTANT: default-uuids-to-cache 100
  66
  67 : <server> ( host port -- server )
  68     V{ } clone default-uuids-to-cache server boa ;
  69
  70 : <default-server> ( -- server )
  71     default-couch-host default-couch-port <server> ;
  72
  73 : (server-url) ( server -- )
  74     "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
  75
  76 : server-url ( server -- url )
  77     [ (server-url) ] "" make ;
  78
  79 : all-dbs ( server -- dbs )
  80     server-url "_all_dbs" append couch-get ;
  81
  82 : uuids-url ( server -- url )
  83     [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
  84
  85 : uuids-get ( server -- uuids )
  86      uuids-url couch-get "uuids" of >vector ;
  87
  88 : get-uuids ( server -- server )
  89     dup uuids-get [ nip ] curry change-uuids ;
  90
  91 : ensure-uuids ( server -- server )
  92     dup uuids>> empty? [ get-uuids ] when ;
  93
  94 : next-uuid ( server -- uuid )
  95     ensure-uuids uuids>> pop ;
  96
  97 ! db
  98 TUPLE: db { server server } { name string } ;
  99 C: <db> db
 100
 101 : (db-url) ( db -- )
 102     [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
 103
 104 : db-url ( db -- url )
 105     [ (db-url) ] "" make ;
 106
 107 : create-db ( db -- )
 108     f swap db-url couch-put response-ok* ;
 109
 110 : ensure-db ( db -- )
 111     [ create-db ] [
 112         dup file-exists-error? [ 2drop ] [ rethrow ] if
 113     ] recover ;
 114
 115 : delete-db ( db -- )
 116     db-url couch-delete drop ;
 117
 118 : db-info ( db -- info )
 119     db-url couch-get ;
 120
 121 : compact-db ( db -- )
 122     f swap db-url "_compact" append couch-post response-ok* ;
 123
 124 : all-docs ( db -- docs )
 125     ! TODO: queries. Maybe pass in a hashtable with options
 126     db-url "_all_docs" append couch-get ;
 127
 128 : <json-post-data> ( assoc -- post-data )
 129     >json utf8 encode "application/json" <post-data> swap >>data ;
 130
 131 ! documents
 132 : id> ( assoc -- id ) "_id" of ;
 133 : >id ( assoc id -- assoc ) "_id" pick set-at ;
 134 : rev> ( assoc -- rev ) "_rev" of ;
 135 : >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
 136 : attachments> ( assoc -- attachments ) "_attachments" of ;
 137 : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
 138
 139 :: copy-key ( to from to-key from-key -- )
 140     from-key from at
 141     to-key to set-at ;
 142
 143 : copy-id ( to from -- )
 144     "_id" "id" copy-key ;
 145
 146 : copy-rev ( to from -- )
 147     "_rev" "rev" copy-key ;
 148
 149 : id-url ( id -- url )
 150     couch get db-url swap url-encode-full append ;
 151
 152 : doc-url ( assoc -- url )
 153     id> id-url ;
 154
 155 : temp-view ( view -- results )
 156     <json-post-data> couch get db-url "_temp_view" append couch-post ;
 157
 158 : temp-view-map ( map -- results )
 159     "map" associate temp-view ;
 160
 161 : save-doc-as ( assoc id -- )
 162     [ dup <json-post-data> ] dip id-url couch-put response-ok
 163     [ copy-id ] [ copy-rev ] 2bi ;
 164
 165 : save-new-doc ( assoc -- )
 166     couch get server>> next-uuid save-doc-as ;
 167
 168 : save-doc ( assoc -- )
 169     dup id> [ save-doc-as ] [ save-new-doc ] if* ;
 170
 171 : load-doc ( id -- assoc )
 172     id-url couch-get ;
 173
 174 : delete-doc ( assoc -- deletion-revision )
 175     [
 176         [ doc-url % ]
 177         [ "?rev=" % "_rev" of % ] bi
 178     ] "" make couch-delete response-ok "rev" of ;
 179
 180 : remove-keys ( assoc keys -- )
 181     swap [ delete-at ] curry each ;
 182
 183 : remove-couch-info ( assoc -- )
 184     { "_id" "_rev" "_attachments" } remove-keys ;
 185
 186 ! : construct-attachment ( content-type data -- assoc )
 187 !     H{ } clone "name" pick set-at "content-type" pick set-at ;
 188 !
 189 ! : add-attachment ( assoc name attachment -- )
 190 !     pick attachments> [ H{ } clone ] unless*
 191 !
 192 ! : attach ( assoc name content-type data -- )
 193 !     construct-attachment H{ } clone
 194
 195 ! TODO:
 196 ! - startkey, limit, descending, etc.
 197 ! - loading specific revisions
 198 ! - views
 199 ! - attachments
 200 ! - bulk insert/update
 201 ! - ...?