various changes
Sascha Matzke
parent
28809b0ec0
commit
3e433f52a2
|
|
@ -1,9 +1,6 @@
|
|||
USING: vocabs.loader ;
|
||||
|
||||
IN: bson
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
SINGLETON: bson-null
|
||||
|
||||
"bson.reader" require
|
||||
"bson.writer" require
|
||||
|
|
|
|||
|
|
@ -1,31 +1,40 @@
|
|||
USING: alien.c-types ;
|
||||
USING: alien.c-types accessors kernel calendar random math.bitwise math unix ;
|
||||
|
||||
IN: bson.constants
|
||||
|
||||
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
||||
|
||||
: <oid> ( -- oid )
|
||||
oid new
|
||||
now timestamp>micros >>a
|
||||
8 random-bits 16 shift HEX: FF0000 mask
|
||||
getpid HEX: FFFF mask
|
||||
bitor >>b ;
|
||||
|
||||
: T_EOO ( -- type ) 0 ; inline
|
||||
: T_Double ( -- type ) 1 ; inline
|
||||
: T_Integer ( -- type ) 16 ; inline
|
||||
: T_Boolean ( -- type ) 8 ; inline
|
||||
: T_String ( -- type ) 2 ; inline
|
||||
: T_Object ( -- type ) 3 ; inline
|
||||
: T_Array ( -- type ) 4 ; inline
|
||||
: T_Binary ( -- type ) 5 ; inline
|
||||
: T_Undefined ( -- type ) 6 ; inline
|
||||
: T_OID ( -- type ) 7 ; inline
|
||||
: T_Date ( -- type ) 9 ; inline
|
||||
: T_NULL ( -- type ) 10 ; inline
|
||||
: T_Regexp ( -- type ) 11 ; inline
|
||||
: T_DBRef ( -- type ) 12 ; inline
|
||||
: T_Code ( -- type ) 13 ; inline
|
||||
: T_ScopedCode ( -- type ) 17 ; inline
|
||||
: T_Symbol ( -- type ) 14 ; inline
|
||||
: T_JSTypeMax ( -- type ) 16 ; inline
|
||||
: T_MaxKey ( -- type ) 127 ; inline
|
||||
|
||||
: T_Binary_Bytes ( -- subtype ) 2 ; inline
|
||||
: T_Binary_Function ( -- subtype ) 1 ; inline
|
||||
TUPLE: dbref ns oid ;
|
||||
|
||||
|
||||
CONSTANT: T_EOO 0
|
||||
CONSTANT: T_Double 1
|
||||
CONSTANT: T_Integer 16
|
||||
CONSTANT: T_Boolean 8
|
||||
CONSTANT: T_String 2
|
||||
CONSTANT: T_Object 3
|
||||
CONSTANT: T_Array 4
|
||||
CONSTANT: T_Binary 5
|
||||
CONSTANT: T_Undefined 6
|
||||
CONSTANT: T_OID 7
|
||||
CONSTANT: T_Date 9
|
||||
CONSTANT: T_NULL 10
|
||||
CONSTANT: T_Regexp 11
|
||||
CONSTANT: T_DBRef 12
|
||||
CONSTANT: T_Code 13
|
||||
CONSTANT: T_ScopedCode 17
|
||||
CONSTANT: T_Symbol 14
|
||||
CONSTANT: T_JSTypeMax 16
|
||||
CONSTANT: T_MaxKey 127
|
||||
|
||||
CONSTANT: T_Binary_Bytes 2
|
||||
CONSTANT: T_Binary_Function 1
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,21 +1,21 @@
|
|||
USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences
|
||||
splitting accessors io.streams.byte-array namespaces prettyprint
|
||||
bson.constants assocs alien.c-types alien.strings fry words
|
||||
tools.walker serialize locals byte-arrays ;
|
||||
serialize byte-arrays ;
|
||||
|
||||
IN: bson.reader
|
||||
|
||||
ERROR: size-mismatch actual declared ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: element { type integer } name ;
|
||||
TUPLE: state { size initial: -1 } { read initial: 0 } exemplar result scope element ;
|
||||
TUPLE: state
|
||||
{ size initial: -1 } { read initial: 0 } exemplar
|
||||
result scope element ;
|
||||
|
||||
:: <state> ( exemplar -- state )
|
||||
state new
|
||||
exemplar clone >>exemplar
|
||||
exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
|
||||
: <state> ( exemplar -- state )
|
||||
[ state new ] dip
|
||||
[ clone >>exemplar ] keep
|
||||
clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
|
||||
V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline
|
||||
|
||||
PREDICATE: bson-eoo < integer T_EOO = ;
|
||||
|
|
@ -101,6 +101,18 @@ M: bson-array fix-result ( assoc type -- result )
|
|||
drop
|
||||
values ;
|
||||
|
||||
GENERIC: end-element ( type -- )
|
||||
|
||||
M: bson-object end-element ( type -- )
|
||||
drop ;
|
||||
|
||||
M: bson-array end-element ( type -- )
|
||||
drop ;
|
||||
|
||||
M: object end-element ( type -- )
|
||||
drop
|
||||
pop-element drop ;
|
||||
|
||||
M: bson-eoo element-read ( type -- cont? )
|
||||
drop
|
||||
get-state scope>> [ pop ] keep swap ! vec assoc
|
||||
|
|
@ -113,9 +125,10 @@ M: bson-eoo element-read ( type -- cont? )
|
|||
M: bson-not-eoo element-read ( type -- cont? )
|
||||
[ peek-scope ] dip ! scope type
|
||||
'[ _
|
||||
read-cstring push-element [ name>> ] [ type>> ] bi
|
||||
element-data-read
|
||||
swap
|
||||
read-cstring push-element [ name>> ] [ type>> ] bi
|
||||
[ element-data-read ] keep
|
||||
end-element
|
||||
swap
|
||||
] dip
|
||||
set-at
|
||||
t ;
|
||||
|
|
@ -124,8 +137,7 @@ M: bson-oid element-data-read ( type -- object )
|
|||
drop
|
||||
read-longlong
|
||||
read-int32
|
||||
oid boa
|
||||
pop-element drop ;
|
||||
oid boa ;
|
||||
|
||||
: [scope-changer] ( state -- state quot )
|
||||
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
|
||||
|
|
@ -145,28 +157,34 @@ M: bson-array element-data-read ( type -- object )
|
|||
|
||||
M: bson-string element-data-read ( type -- object )
|
||||
drop
|
||||
read-int32 read-sized-string
|
||||
pop-element drop ;
|
||||
read-int32 read-sized-string ;
|
||||
|
||||
M: bson-integer element-data-read ( type -- object )
|
||||
drop
|
||||
read-int32
|
||||
pop-element drop ;
|
||||
read-int32 ;
|
||||
|
||||
M: bson-double element-data-read ( type -- double )
|
||||
drop
|
||||
read-double
|
||||
pop-element drop ;
|
||||
read-double ;
|
||||
|
||||
M: bson-boolean element-data-read ( type -- boolean )
|
||||
drop
|
||||
read-byte t =
|
||||
pop-element drop ;
|
||||
read-byte t = ;
|
||||
|
||||
M: bson-ref element-data-read ( type -- dbref )
|
||||
drop
|
||||
read-int32
|
||||
read-sized-string
|
||||
T_OID element-data-read
|
||||
dbref boa ;
|
||||
|
||||
M: bson-binary element-data-read ( type -- binary )
|
||||
drop
|
||||
read-int32 read-byte element-binary-read
|
||||
pop-element drop ;
|
||||
read-int32 read-byte element-binary-read ;
|
||||
|
||||
M: bson-null element-data-read ( type -- bf )
|
||||
drop
|
||||
f ;
|
||||
|
||||
M: bson-binary-bytes element-binary-read ( size type -- bytes )
|
||||
drop read ;
|
||||
|
|
@ -176,17 +194,13 @@ M: bson-binary-function element-binary-read ( size type -- quot )
|
|||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: stream>assoc ( exemplar -- assoc )
|
||||
|
||||
M: assoc stream>assoc ( exemplar -- assoc )
|
||||
: stream>assoc ( exemplar -- assoc )
|
||||
<state> dup state
|
||||
[ read-int32 >>size read-elements ] with-variable
|
||||
result>> ;
|
||||
|
||||
USING: multi-methods ;
|
||||
|
||||
GENERIC: array>assoc ( array exemplar -- assoc )
|
||||
|
||||
METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc )
|
||||
|
||||
: array>assoc ( array exemplar -- assoc )
|
||||
[ binary ] dip '[ _ stream>assoc ] with-byte-reader ;
|
||||
|
||||
: array>hashtable ( array -- assoc )
|
||||
H{ } array>assoc ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bson bson.constants accessors kernel io.streams.string
|
||||
io.encodings.binary classes byte-arrays quotations serialize
|
||||
io.encodings.utf8 strings splitting math.parser locals
|
||||
io.encodings.utf8 strings splitting math.parser
|
||||
sequences math assocs classes words make fry
|
||||
prettyprint hashtables mirrors alien.strings alien.c-types
|
||||
io.streams.byte-array io ;
|
||||
|
|
@ -19,7 +19,8 @@ GENERIC: bson-write ( obj -- )
|
|||
M: t bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
|
||||
M: oid bson-type? ( word -- type ) drop T_OID ;
|
||||
M: oid bson-type? ( word -- type ) drop T_OID ;
|
||||
M: dbref bson-type? ( dbref -- type ) drop T_DBRef ;
|
||||
M: real bson-type? ( real -- type ) drop T_Double ;
|
||||
M: word bson-type? ( word -- type ) drop T_String ;
|
||||
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
|
||||
|
|
@ -28,7 +29,6 @@ M: string bson-type? ( string -- type ) drop T_String ;
|
|||
M: integer bson-type? ( integer -- type ) drop T_Integer ;
|
||||
M: sequence bson-type? ( seq -- type ) drop T_Array ;
|
||||
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
|
||||
M: bson-null bson-type? ( null -- type ) drop T_NULL ;
|
||||
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
|
||||
|
||||
: write-byte ( byte -- ) <char> write ; inline
|
||||
|
|
@ -48,9 +48,6 @@ M: f bson-write ( f -- )
|
|||
M: t bson-write ( t -- )
|
||||
drop 1 write-byte ;
|
||||
|
||||
M: bson-null bson-write ( null -- )
|
||||
drop ;
|
||||
|
||||
M: string bson-write ( obj -- )
|
||||
utf8 string>alien
|
||||
[ length write-int32 ] keep
|
||||
|
|
@ -74,6 +71,12 @@ M: quotation bson-write ( quotation -- )
|
|||
|
||||
M: oid bson-write ( oid -- )
|
||||
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
|
||||
|
||||
M: dbref bson-write ( dbref -- )
|
||||
[ ns>> utf8 string>alien
|
||||
[ length write-int32 ] keep write
|
||||
]
|
||||
[ oid>> bson-write ] bi ;
|
||||
|
||||
M: sequence bson-write ( array -- )
|
||||
'[ _ [ [ write-type ] dip number>string write-cstring bson-write ]
|
||||
|
|
|
|||
|
|
@ -1,15 +1,49 @@
|
|||
USING: mongodb.persistent ;
|
||||
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
|
||||
math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple
|
||||
namespaces sequences splitting ;
|
||||
|
||||
IN: mongodb
|
||||
|
||||
INTERSECTION: storable mdb-persistent ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
||||
GENERIC: store ( tuple/ht -- tuple/ht )
|
||||
GENERIC: load ( example -- tuple/ht )
|
||||
: prepare-find ( example -- query )
|
||||
[ mdb-collection>> get-collection-fqn ] keep
|
||||
H{ } tuple>query <mdb-query-msg> ; inline
|
||||
|
||||
M: tuple store ( tuple -- tuple )
|
||||
[ check-persistent-tuple ] keep ;
|
||||
PRIVATE>
|
||||
|
||||
M: persistent-tuple store ( ptuple -- ptuple )
|
||||
;
|
||||
|
||||
: <mdb> ( db host port -- mdb )
|
||||
(<mdb>) ;
|
||||
|
||||
|
||||
GENERIC: store ( tuple/ht -- )
|
||||
|
||||
GENERIC: find ( example -- tuple/ht )
|
||||
|
||||
GENERIC: findOne ( exampe -- tuple/ht )
|
||||
|
||||
GENERIC: load ( object -- object )
|
||||
|
||||
|
||||
M: storable store ( tuple -- )
|
||||
prepare-store ! H { collection { ... values ... }
|
||||
[ [ <mdb-insert-msg> ] 2dip
|
||||
[ get-collection-fqn >>collection ] dip
|
||||
objects>>
|
||||
[ mdb>> master>> binary ] dip '[ _ write-request ] with-client
|
||||
] assoc-each ;
|
||||
|
||||
M: storable find ( example -- result )
|
||||
prepare-find (find)
|
||||
build-result ;
|
||||
|
||||
M: storable findOne ( example -- result )
|
||||
prepare-find (find-one)
|
||||
dup returned#>> 1 =
|
||||
[ objects>> first ]
|
||||
[ drop f ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,81 +1,129 @@
|
|||
USING: accessors classes classes.mixin classes.tuple compiler.units
|
||||
fry kernel words locals mirrors formatting assocs hashtables ;
|
||||
USING: accessors assocs classes fry kernel linked-assocs math mirrors
|
||||
namespaces sequences strings vectors words bson.constants
|
||||
continuations ;
|
||||
|
||||
IN: mongodb.persistent
|
||||
|
||||
MIXIN: persistent-tuple
|
||||
MIXIN: mdb-persistent
|
||||
|
||||
SLOT: _p_oid
|
||||
SLOT: _p_info
|
||||
SLOT: _id
|
||||
|
||||
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
||||
CONSTANT: MDB_P_SLOTS { "_id" }
|
||||
CONSTANT: MDB_OID "_id"
|
||||
|
||||
: MDB_CLASS ( -- string ) "p_class" ; inline
|
||||
: MDB_VOCAB ( -- string ) "p_vocab" ; inline
|
||||
: MDB_MT ( -- string ) "p_mt" ; inline
|
||||
: MDB_CT ( -- string ) "p_ct" ; inline
|
||||
: MDB_COL ( -- string ) "p_col" ; inline
|
||||
SYMBOL: mdb-op-seq
|
||||
|
||||
PREDICATE: pinfo-hashtable < hashtable [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ;
|
||||
GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc )
|
||||
|
||||
: P_OID ( -- name ) "_p_oid" ; inline
|
||||
: P_INFO ( -- name ) "_p_info" ; inline
|
||||
: tuple>linked-assoc ( tuple -- linked-assoc )
|
||||
<linked-hash> tuple>assoc ; inline
|
||||
|
||||
: P_SLOTS ( -- array )
|
||||
{ "_p_oid" "_p_info" } ;
|
||||
GENERIC# tuple>query 1 ( tuple examplar -- query-assoc )
|
||||
|
||||
GENERIC: mdb-collection>> ( tuple -- string )
|
||||
|
||||
GENERIC: mdb-slot-definitions>> ( tuple -- string )
|
||||
|
||||
|
||||
DEFER: assoc>tuple
|
||||
DEFER: create-mdb-command
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: P_VOCAB ( -- string )
|
||||
"mongodb.persistent" ; inline
|
||||
CONSTANT: MDB_INFO "_mdb_info"
|
||||
|
||||
:: define-persistent-tuple ( superclass name -- class )
|
||||
[let | pclass [ name P_VOCAB create ] |
|
||||
[ pclass pclass [ ] curry define ] with-compilation-unit
|
||||
[ pclass superclass P_SLOTS define-tuple-class
|
||||
pclass persistent-tuple add-mixin-instance ] with-compilation-unit
|
||||
pclass ] ;
|
||||
|
||||
:: copy-slots ( tuple 'tuple -- 'tuple )
|
||||
[let | tm1 [ tuple <mirror> ]
|
||||
tm2 [ 'tuple <mirror> ] |
|
||||
tm1 [ swap tm2 set-at ] assoc-each
|
||||
tm2 object>> ] ;
|
||||
: <dbref> ( tuple -- dbref )
|
||||
[ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline
|
||||
|
||||
: mdbinfo>tuple-class ( mdbinfo -- class )
|
||||
[ first ] keep second lookup ; inline
|
||||
|
||||
: make-tuple ( assoc -- tuple )
|
||||
[ MDB_INFO swap at mdbinfo>tuple-class new ] keep ! instance assoc
|
||||
[ dup <mirror> [ keys ] keep ] dip ! instance array mirror assoc
|
||||
'[ dup _ [ _ at assoc>tuple ] dip [ swap ] dip set-at ] each ;
|
||||
|
||||
: persistent-info ( tuple -- pinfo )
|
||||
class V{ } clone tuck
|
||||
[ [ name>> ] dip push ]
|
||||
[ [ vocabulary>> ] dip push ] 2bi ; inline
|
||||
|
||||
: id-or-f? ( key value -- key value boolean )
|
||||
over "_id" =
|
||||
[ dup f = ] dip or ; inline
|
||||
|
||||
: write-persistent-info ( mirror exemplar assoc -- )
|
||||
[ drop ] dip
|
||||
2dup [ "_id" ] 2dip [ over [ at ] dip ] dip set-at
|
||||
[ object>> persistent-info MDB_INFO ] dip set-at ;
|
||||
|
||||
: persistent-tuple? ( object -- object boolean )
|
||||
dup mdb-persistent? ; inline
|
||||
|
||||
: ensure-value-ht ( key ht -- vht )
|
||||
2dup key?
|
||||
[ at ]
|
||||
[ [ H{ } clone dup ] 2dip set-at ] if ; inline
|
||||
|
||||
: data-tuple? ( tuple -- ? )
|
||||
dup tuple? [ assoc? [ f ] [ t ] if ] [ drop f ] if ;
|
||||
|
||||
: write-tuple-fields ( mirror exemplar assoc -- )
|
||||
[ dup ] dip ! m e e a
|
||||
'[ id-or-f?
|
||||
[ 2drop ]
|
||||
[ persistent-tuple?
|
||||
[ _ keep
|
||||
[ mdb-collection>> ] keep
|
||||
[ create-mdb-command ] dip
|
||||
<dbref> ]
|
||||
[ dup data-tuple? _ [ ] if ] if
|
||||
swap _ set-at
|
||||
] if
|
||||
] assoc-each ;
|
||||
|
||||
: prepare-assoc ( tuple exemplar -- assoc mirror exemplar assoc )
|
||||
[ <mirror> ] dip dup clone swap [ tuck ] dip swap ; inline
|
||||
|
||||
: ensure-mdb-info ( tuple -- tuple )
|
||||
dup _id>> [ <oid> >>_id ] unless ; inline
|
||||
|
||||
: with-op-seq ( quot -- op-seq )
|
||||
[
|
||||
[ H{ } clone mdb-op-seq set ] dip call mdb-op-seq get
|
||||
] with-scope ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: persistent-tuple-class ( tuple -- class )
|
||||
: create-mdb-command ( assoc ns -- )
|
||||
mdb-op-seq get
|
||||
ensure-value-ht
|
||||
[ dup [ MDB_OID ] dip at ] dip
|
||||
set-at ; inline
|
||||
|
||||
M: tuple persistent-tuple-class ( tuple -- class )
|
||||
class persistent-tuple-class ;
|
||||
: prepare-store ( mdb-persistent -- op-seq )
|
||||
'[ _ [ tuple>linked-assoc ] keep mdb-collection>> create-mdb-command ]
|
||||
with-op-seq ; inline
|
||||
|
||||
M: pinfo-hashtable persistent-tuple-class ( tuple -- class )
|
||||
[ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup
|
||||
persistent-tuple-class ;
|
||||
M: mdb-persistent tuple>assoc ( tuple exemplar -- assoc )
|
||||
[ ensure-mdb-info ] dip ! tuple exemplar
|
||||
prepare-assoc
|
||||
[ write-persistent-info ]
|
||||
[ [ '[ _ tuple>assoc ] ] dip write-tuple-fields ] 3bi ;
|
||||
|
||||
M: tuple-class persistent-tuple-class ( class -- class' )
|
||||
[ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class
|
||||
[ "%s_%s" sprintf ] dip swap dup ! class new_name new_name
|
||||
P_VOCAB lookup dup ! class new_name vo/f vo/f
|
||||
[ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ;
|
||||
M: tuple tuple>assoc ( tuple exemplar -- assoc )
|
||||
[ drop persistent-info MDB_INFO ] 2keep
|
||||
prepare-assoc [ '[ _ tuple>assoc ] ] write-tuple-fields
|
||||
[ set-at ] keep ;
|
||||
|
||||
M: tuple tuple>query ( tuple examplar -- assoc )
|
||||
prepare-assoc [ '[ _ tuple>query ] ] dip write-tuple-fields ;
|
||||
|
||||
: assoc>tuple ( assoc -- tuple )
|
||||
dup assoc?
|
||||
[ [ dup MDB_INFO swap key?
|
||||
[ make-tuple ]
|
||||
[ ] if ] [ drop ] recover
|
||||
] [ ] if ; inline
|
||||
|
||||
|
||||
GENERIC: make-persistent ( tuple -- 'tuple )
|
||||
|
||||
M: tuple make-persistent ( tuple -- 'tuple )
|
||||
[let* | tuple [ ]
|
||||
tclass [ tuple class ]
|
||||
'tuple [ tclass persistent-tuple-class new ]
|
||||
pinfo [ H{ } clone ] |
|
||||
tuple 'tuple copy-slots
|
||||
oid new >>_p_oid
|
||||
tclass name>> MDB_CLASS pinfo set-at
|
||||
tclass vocabulary>> MDB_VOCAB pinfo set-at
|
||||
0 MDB_MT pinfo set-at
|
||||
0 MDB_CT pinfo set-at
|
||||
"" MDB_COL pinfo set-at
|
||||
pinfo >>_p_info
|
||||
] ;
|
||||
|
||||
M: persistent-tuple make-persistent ( tuple -- tuple )
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue