basis/couchdb/couchdb.factor

   1 ! Copyright (C) 2008, 2009 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs continuations debugger hashtables http
   4 http.client io io.encodings.string io.encodings.utf8 json.reader
   5 json.writer kernel make math math.parser namespaces sequences
   6 strings 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.
  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 : <json-post-data> ( assoc -- post-data )
  46     >json utf8 encode "application/json" <post-data> swap >>data ;
  47
  48 : couch-put ( assoc url -- assoc' )
  49     [ <json-post-data> ] dip <put-request> couch-request ;
  50
  51 : couch-post ( assoc url -- assoc' )
  52     [ <json-post-data> ] dip <post-request> couch-request ;
  53
  54 : couch-delete ( url -- assoc )
  55     <delete-request> couch-request ;
  56
  57 : response-ok ( assoc -- assoc )
  58     "ok" over delete-at* and t assert= ;
  59
  60 : response-ok* ( assoc -- )
  61     response-ok drop ;
  62
  63 ! server
  64 TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
  65
  66 CONSTANT: default-couch-host "localhost"
  67 CONSTANT: default-couch-port 5984
  68 CONSTANT: default-uuids-to-cache 100
  69
  70 : <server> ( host port -- server )
  71     V{ } clone default-uuids-to-cache server boa ;
  72
  73 : <default-server> ( -- server )
  74     default-couch-host default-couch-port <server> ;
  75
  76 : (server-url) ( server -- )
  77     "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
  78
  79 : server-url ( server -- url )
  80     [ (server-url) ] "" make ;
  81
  82 : all-dbs ( server -- dbs )
  83     server-url "_all_dbs" append couch-get ;
  84
  85 : uuids-url ( server -- url )
  86     [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
  87
  88 : uuids-get ( server -- uuids )
  89      uuids-url couch-get "uuids" of >vector ;
  90
  91 : get-uuids ( server -- server )
  92     dup uuids-get [ nip ] curry change-uuids ;
  93
  94 : ensure-uuids ( server -- server )
  95     dup uuids>> empty? [ get-uuids ] when ;
  96
  97 : next-uuid ( server -- uuid )
  98     ensure-uuids uuids>> pop ;
  99
 100 ! db
 101 TUPLE: db { server server } { name string } ;
 102 C: <db> db
 103
 104 : (db-url) ( db -- )
 105     [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
 106
 107 : db-url ( db -- url )
 108     [ (db-url) ] "" make ;
 109
 110 : create-db ( db -- )
 111     f swap db-url couch-put response-ok* ;
 112
 113 : ensure-db ( db -- )
 114     '[ _ create-db ] [ file-exists-error? ] ignore-error ;
 115
 116 : delete-db ( db -- )
 117     db-url couch-delete drop ;
 118
 119 : db-info ( db -- info )
 120     db-url couch-get ;
 121
 122 : all-docs ( db -- docs )
 123     ! TODO: queries. Maybe pass in a hashtable with options
 124     db-url "_all_docs" append couch-get ;
 125
 126 : compact-db ( db -- )
 127     f swap db-url "_compact" append couch-post response-ok* ;
 128
 129 ! documents
 130 : id> ( assoc -- id ) "_id" of ;
 131 : >id ( assoc id -- assoc ) "_id" pick set-at ;
 132 : rev> ( assoc -- rev ) "_rev" of ;
 133 : >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
 134 : attachments> ( assoc -- attachments ) "_attachments" of ;
 135 : >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
 136
 137 :: copy-key ( to from to-key from-key -- )
 138     from-key from at
 139     to-key to set-at ;
 140
 141 : copy-id ( to from -- )
 142     "_id" "id" copy-key ;
 143
 144 : copy-rev ( to from -- )
 145     "_rev" "rev" copy-key ;
 146
 147 : id-url ( id -- url )
 148     couch get db-url swap url-encode-full append ;
 149
 150 : doc-url ( assoc -- url )
 151     id> id-url ;
 152
 153 : temp-view ( view -- results )
 154     couch get db-url "_temp_view" append couch-post ;
 155
 156 : temp-view-map ( map -- results )
 157     "map" associate temp-view ;
 158
 159 : save-doc-as ( assoc id -- )
 160     dupd id-url couch-put response-ok
 161     [ copy-id ] [ copy-rev ] 2bi ;
 162
 163 : save-new-doc ( assoc -- )
 164     couch get server>> next-uuid save-doc-as ;
 165
 166 : save-doc ( assoc -- )
 167     dup id> [ save-doc-as ] [ save-new-doc ] if* ;
 168
 169 : load-doc ( id -- assoc )
 170     id-url couch-get ;
 171
 172 : delete-doc ( assoc -- deletion-revision )
 173     [
 174         [ doc-url % ]
 175         [ "?rev=" % "_rev" of % ] bi
 176     ] "" make couch-delete response-ok "rev" of ;
 177
 178 : remove-keys ( assoc keys -- )
 179     swap [ delete-at ] curry each ;
 180
 181 : remove-couch-info ( assoc -- )
 182     { "_id" "_rev" "_attachments" } remove-keys ;
 183
 184 ! : construct-attachment ( content-type data -- assoc )
 185 !     H{ } clone "name" pick set-at "content-type" pick set-at ;
 186 !
 187 ! : add-attachment ( assoc name attachment -- )
 188 !     pick attachments> [ H{ } clone ] unless*
 189 !
 190 ! : attach ( assoc name content-type data -- )
 191 !     construct-attachment H{ } clone
 192
 193 ! TODO:
 194 ! - startkey, limit, descending, etc.
 195 ! - loading specific revisions
 196 ! - views
 197 ! - attachments
 198 ! - bulk insert/update
 199 ! - ...?