extra/mongodb/tuple/tuple.factor

   1 USING: accessors assocs classes.mixin classes.tuple
   2 classes.tuple.parser compiler.units fry kernel sequences
   3 hashtables
   4 mongodb.driver
   5 mongodb.msg mongodb.tuple.collection
   6 mongodb.tuple.persistent mongodb.tuple.state strings ;
   7 FROM: mongodb.driver => update delete find count ;
   8 FROM: mongodb.tuple.persistent => assoc>tuple ;
   9
  10 IN: mongodb.tuple
  11
  12 SYNTAX: MDBTUPLE:
  13     parse-tuple-definition
  14     mdb-check-slots
  15     define-tuple-class ;
  16
  17 : define-persistent ( class collection slot-options index -- )
  18     [ [ <mdb-tuple-collection> dupd link-collection ] when* ] 2dip
  19     [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip
  20     [ drop set-slot-map ]
  21     [ nip set-index-map ] 3bi ; inline
  22
  23 : ensure-table ( class -- )
  24     tuple-collection
  25     [ create-collection ]
  26     [ [ mdb-index-map values ] keep
  27       '[ _ name>> >>ns ensure-index ] each
  28     ] bi ;
  29
  30 : ensure-tables ( classes -- )
  31     [ ensure-table ] each ;
  32
  33 : drop-table ( class -- )
  34       tuple-collection
  35       [ [ mdb-index-map values ] keep
  36         '[ _ name>> swap name>> drop-index ] each ]
  37       [ name>> drop-collection ] bi ;
  38
  39 : recreate-table ( class -- )
  40     [ drop-table ]
  41     [ ensure-table ] bi ;
  42
  43 DEFER: tuple>query
  44
  45 <PRIVATE
  46
  47 GENERIC: id-selector ( object -- selector )
  48
  49 M: toid id-selector
  50    [ value>> ] [ key>> ] bi associate ; inline
  51
  52 M: mdb-persistent id-selector
  53    >toid id-selector ;
  54
  55 : (save-tuples) ( collection assoc -- )
  56    swap '[ [ _ ] 2dip
  57            [ id-selector ] dip
  58            <update> >upsert update ] assoc-each ; inline
  59
  60 : prepare-tuple-query ( tuple/query -- query )
  61     dup mdb-query-msg? [ tuple>query ] unless ;
  62
  63 PRIVATE>
  64
  65 : save-tuple-deep ( tuple -- )
  66     tuple>storable [ (save-tuples) ] assoc-each ;
  67
  68 : update-tuple ( tuple -- )
  69     [ tuple-collection name>> ]
  70     [ ensure-oid id-selector ]
  71     [ tuple>assoc ] tri
  72     <update> >upsert update ;
  73
  74 : save-tuple ( tuple -- )
  75     update-tuple ;
  76
  77 : insert-tuple ( tuple -- )
  78    [ tuple-collection name>> ]
  79    [ tuple>assoc ] bi
  80    save ;
  81
  82 : delete-tuple ( tuple -- )
  83    [ tuple-collection name>> ] keep
  84    id-selector <delete> delete ;
  85
  86 : delete-tuples ( seq -- )
  87     [ delete-tuple ] each ;
  88
  89 : tuple>query ( tuple -- query )
  90    [ tuple-collection name>> ] keep
  91    tuple>selector <query> ;
  92
  93 : select-tuple ( tuple/query -- tuple/f )
  94    prepare-tuple-query
  95    find-one [ assoc>tuple ] [ f ] if* ;
  96
  97 : select-tuples ( tuple/query -- cursor tuples/f )
  98    prepare-tuple-query
  99    find [ assoc>tuple ] map ;
 100
 101 : select-all-tuples ( tuple/query -- tuples )
 102    prepare-tuple-query
 103    find-all [ assoc>tuple ] map ;
 104
 105 : count-tuples ( tuple/query -- n )
 106    dup mdb-query-msg? [ tuple>query ] unless count ;