extra/couchdb/couchdb.factor

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