108 lines
3.2 KiB
Factor
108 lines
3.2 KiB
Factor
USING: accessors assocs combinators formatting fry kernel memoize
|
|
linked-assocs mongodb.persistent mongodb.msg mongodb.connection
|
|
sequences sequences.deep io.encodings.binary mongodb.tuple
|
|
io.sockets prettyprint sets tools.walker math ;
|
|
|
|
IN: mongodb.index
|
|
|
|
: index-ns ( name -- ns )
|
|
"%s.system.indexes" sprintf ; inline
|
|
|
|
TUPLE: index name ns key ;
|
|
|
|
SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ;
|
|
|
|
<PRIVATE
|
|
|
|
: index-type ( type -- name )
|
|
{ { +fieldindex+ [ "field" ] }
|
|
{ +deepindex+ [ "deep" ] }
|
|
{ +compoundindex+ [ "compound" ] } } case ;
|
|
|
|
: index-name ( slot index-spec -- name )
|
|
[ first index-type ] keep
|
|
rest "-" join
|
|
"%s-%s-%s-Idx" sprintf ;
|
|
|
|
: build-index ( element slot -- assoc )
|
|
swap [ <linked-hash> ] 2dip
|
|
[ rest ] keep first ! assoc slot options itype
|
|
{ { +fieldindex+ [ drop [ 1 ] dip pick set-at ] }
|
|
{ +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
|
|
{ +compoundindex+ [
|
|
2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
|
|
over '[ _ [ 1 ] 2dip set-at ] each ] }
|
|
} case ;
|
|
|
|
: build-index-seq ( slot optlist ns -- index-seq )
|
|
[ V{ } clone ] 3dip ! v{} slot optl ns
|
|
[ index new ] dip ! v{} slot optl index ns
|
|
>>ns
|
|
[ pick ] dip swap ! v{} slot optl index v{}
|
|
[ swap ] 2dip ! v{} optl slot index v{ }
|
|
'[ _ _ ! element slot exemplar
|
|
clone 2over swap index-name >>name ! element slot clone
|
|
[ build-index ] dip swap >>key _ push
|
|
] each ;
|
|
|
|
: is-index-declaration? ( entry -- ? )
|
|
first
|
|
{ { +fieldindex+ [ t ] }
|
|
{ +compoundindex+ [ t ] }
|
|
{ +deepindex+ [ t ] }
|
|
[ drop f ] } case ;
|
|
|
|
: index-assoc ( seq -- assoc )
|
|
H{ } clone tuck '[ dup name>> _ set-at ] each ;
|
|
|
|
: delete-index ( name ns -- )
|
|
"Drop index %s - %s" sprintf . ;
|
|
|
|
: clean-indices ( existing defined -- )
|
|
[ index-assoc ] bi@ assoc-diff values
|
|
[ [ name>> ] [ ns>> ] bi delete-index ] each ;
|
|
|
|
PRIVATE>
|
|
|
|
USE: mongodb.query
|
|
|
|
: load-indices ( mdb-collection -- indexlist )
|
|
[ mdb>> name>> ] dip name>> "%s.%s" sprintf
|
|
"ns" H{ } clone [ set-at ] keep [ mdb>> name>> index-ns ] dip <mdb-query-msg>
|
|
'[ _ write-message read-message ]
|
|
[ mdb>> master>> binary ] dip with-client
|
|
objects>> [ [ index new ] dip
|
|
[ [ "ns" ] dip at >>ns ]
|
|
[ [ "name" ] dip at >>name ]
|
|
[ [ "key" ] dip at >>key ] tri
|
|
] map ;
|
|
|
|
: build-indices ( mdb-collection mdb -- seq )
|
|
name>>
|
|
[ [ mdb-slot-definitions>> ] keep name>> ] dip
|
|
swap "%s.%s" sprintf
|
|
[ V{ } clone ] 2dip pick
|
|
'[ _
|
|
[ [ is-index-declaration? ] filter ] dip
|
|
build-index-seq _ push
|
|
] assoc-each flatten ;
|
|
|
|
: ensure-indices ( mdb-collection -- )
|
|
[ load-indices ] keep mdb>> build-indices
|
|
[ clean-indices ] keep
|
|
V{ } clone tuck
|
|
'[ _ [ <linked-hash> tuple>query ] dip push ] each
|
|
dup length 0 >
|
|
[ [ mdb>> name>> "%s.system.indexes" sprintf ] dip
|
|
<mdb-insert-msg>
|
|
[ mdb>> master>> binary ] dip '[ _ write-message ] with-client
|
|
]
|
|
[ drop ] if ;
|
|
|
|
: show-indices ( mdb-collection -- )
|
|
load-indices . ;
|
|
|
|
: show-all-indices ( -- )
|
|
mdb>> collections>> values
|
|
V{ } clone tuck
|
|
'[ load-indices _ push ] each flatten . ; |