extra/mongodb/tuple/tuple.factor

   1 USING: accessors assocs classes.mixin classes.tuple
   2 classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
   3 mongodb.msg mongodb.tuple.collection mongodb.tuple.index
   4 mongodb.tuple.persistent mongodb.tuple.state strings ;
   5
   6 IN: mongodb.tuple
   7
   8 SYNTAX: MDBTUPLE:
   9     parse-tuple-definition
  10     mdb-check-slots
  11     define-tuple-class ;
  12
  13 : define-persistent ( class collection options -- )
  14     [ [ <mdb-tuple-collection> dupd link-collection ] when* ] dip
  15     [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
  16     ! [ dup annotate-writers ] dip
  17     set-slot-map ;
  18
  19 : ensure-table ( class -- )
  20     tuple-collection
  21     [ create-collection ]
  22     [ [ tuple-index-list ] keep
  23       '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each
  24     ] bi ;
  25
  26 : ensure-tables ( classes -- )
  27     [ ensure-table ] each ;
  28
  29 : drop-table ( class -- )
  30       tuple-collection
  31       [ [ tuple-index-list ] keep
  32         '[ _ name>> swap name>> drop-index ] each ]
  33       [ name>> drop-collection ] bi ;
  34
  35 : recreate-table ( class -- )
  36     [ drop-table ]
  37     [ ensure-table ] bi ;
  38
  39 <PRIVATE
  40
  41 GENERIC: id-selector ( object -- selector )
  42
  43 M: string id-selector ( objid -- selector )
  44    "_id" H{ } clone [ set-at ] keep ; inline
  45
  46 M: mdb-persistent id-selector ( mdb-persistent -- selector )
  47    _id>> id-selector ;
  48
  49 : (save-tuples) ( collection assoc -- )
  50    swap '[ [ _ ] 2dip
  51            [ id-selector ] dip
  52            <update> >upsert update ] assoc-each ; inline
  53 PRIVATE>
  54
  55 : save-tuple ( tuple -- )
  56    tuple>storable [ (save-tuples) ] assoc-each ;
  57
  58 : update-tuple ( tuple -- )
  59    save-tuple ;
  60
  61 : insert-tuple ( tuple -- )
  62    save-tuple ;
  63
  64 : delete-tuple ( tuple -- )
  65    dup persistent?
  66    [ [ tuple-collection name>> ] keep
  67      id-selector delete ] [ drop ] if ;
  68
  69 : tuple>query ( tuple -- query )
  70    [ tuple-collection name>> ] keep
  71    tuple>selector <query> ;
  72
  73 : select-tuple ( tuple/query -- tuple/f )
  74    dup mdb-query-msg? [ ] [ tuple>query ] if
  75    find-one [ assoc>tuple ] [ f ] if* ;
  76
  77 : select-tuples ( tuple/query -- cursor tuples/f )
  78    dup mdb-query-msg? [ ] [ tuple>query ] if
  79    find [ assoc>tuple ] map ;
  80
  81 : count-tuples ( tuple/query -- n )
  82    dup mdb-query-msg? [ tuple>query ] unless
  83    [ collection>> ] [ query>> ] bi count ;