From 4b4f3b8ea98b3566a102333c2abf72e7b57a2ddf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 8 Mar 2008 03:50:03 -0600 Subject: [PATCH] Faster serialization --- .../server/authentication/basic/basic.factor | 50 -------- extra/serialize/serialize-docs.factor | 31 +---- extra/serialize/serialize-tests.factor | 11 -- extra/serialize/serialize.factor | 107 ++++++++++-------- 4 files changed, 59 insertions(+), 140 deletions(-) delete mode 100755 extra/http/server/authentication/basic/basic.factor diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor deleted file mode 100755 index b6dbed4b62..0000000000 --- a/extra/http/server/authentication/basic/basic.factor +++ /dev/null @@ -1,50 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -IN: http.server.authentication.basic -USING: accessors new-slots quotations assocs kernel splitting -base64 crypto.sha2 html.elements io combinators http.server -http sequences ; - -! 'users' is a quotation or an assoc. The quotation -! has stack effect ( sha-256-string username -- ? ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'users' is an assoc then -! it is a mapping of usernames to sha-256 hashed passwords. -TUPLE: realm responder name users ; - -C: realm - -: user-authorized? ( password username realm -- ? ) - users>> { - { [ dup callable? ] [ call ] } - { [ dup assoc? ] [ at = ] } - } cond ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split1 swap "Basic" = [ - base64> ":" split1 string>sha-256-string - spin user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: <401> ( realm -- response ) - 401 "Unauthorized" - "Basic realm=\"" rot name>> "\"" 3append - "WWW-Authenticate" set-header - [ - - "Username or Password is invalid" write - - ] >>body ; - -M: realm call-responder ( request path realm -- response ) - pick "authorization" header dupd authorization-ok? - [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/serialize/serialize-docs.factor b/extra/serialize/serialize-docs.factor index e5d4e0602e..6b2dd304f5 100755 --- a/extra/serialize/serialize-docs.factor +++ b/extra/serialize/serialize-docs.factor @@ -3,33 +3,6 @@ USING: help.syntax help.markup ; IN: serialize -HELP: (serialize) -{ $values { "obj" "object to serialize" } -} -{ $description "Serializes the object to the current output stream. Object references within the structure being serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } -} -{ $see-also deserialize (deserialize) serialize with-serialized } ; - -HELP: (deserialize) -{ $values { "obj" "deserialized object" } -} -{ $description "Deserializes an object by reading from the current input stream. Object references within the structure that was originally serialized are maintained. It must be called from within the scope of a " { $link with-serialized } " call." } -{ $examples - { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } -} -{ $see-also (serialize) deserialize serialize with-serialized } ; - -HELP: with-serialized -{ $values { "quot" "a quotation" } -} -{ $description "Creates a scope for serialization and deserialization operations. The quotation is called within this scope. The scope is used for maintaining the structure and object references of serialized objects." } -{ $examples - { $example "USING: serialize io.streams.string ;" "binary [\n [ { 1 2 } dup (serialize) (serialize) ] with-serialized\n] with-byte-writer\n\nbinary [\n [ (deserialize) (deserialize) ] with-serialized\n] with-byte-reader eq? ." "t" } -} -{ $see-also (serialize) (deserialize) serialize deserialize } ; - HELP: serialize { $values { "obj" "object to serialize" } } @@ -37,7 +10,7 @@ HELP: serialize { $examples { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also deserialize (deserialize) (serialize) with-serialized } ; +{ $see-also deserialize } ; HELP: deserialize { $values { "obj" "deserialized object" } @@ -46,4 +19,4 @@ HELP: deserialize { $examples { $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } } -{ $see-also (serialize) deserialize (deserialize) with-serialized } ; +{ $see-also serialize } ; diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index 93858c7fca..1831495924 100755 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -77,16 +77,5 @@ C: serialize-test [ t ] [ objects [ check-serialize-2 ] all? ] unit-test [ t ] [ pi check-serialize-1 ] unit-test - -[ t ] [ - { 1 2 3 } - binary [ - [ - dup (serialize) (serialize) - ] with-serialized - ] with-byte-writer - binary [ deserialize-sequence all-eq? ] with-byte-reader -] unit-test - [ serialize ] must-infer [ deserialize ] must-infer diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 32ace10842..36455bd060 100755 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -13,17 +13,25 @@ vectors byte-arrays bit-arrays quotations hashtables assocs help.syntax help.markup float-arrays splitting io.encodings.string io.encodings.utf8 combinators ; -! Variable holding a sequence of objects already serialized +! Variable holding a assoc of objects already serialized SYMBOL: serialized -: add-object ( obj -- id ) +TUPLE: id obj ; + +C: id + +M: id hashcode* id-obj hashcode* ; + +M: id equal? over id? [ [ id-obj ] 2apply eq? ] [ 2drop f ] if ; + +: add-object ( obj -- ) #! Add an object to the sequence of already serialized - #! objects. Return the id of that object. - serialized get [ push ] keep length 1 - ; + #! objects. + serialized get [ assoc-size swap ] keep set-at ; : object-id ( obj -- id ) #! Return the id of an already serialized object - serialized get [ eq? ] with find [ drop f ] unless ; + serialized get at ; ! Serialize object GENERIC: (serialize) ( obj -- ) @@ -89,10 +97,8 @@ M: ratio (serialize) ( obj -- ) : serialize-string ( obj code -- ) write1 - dup add-object serialize-cell - utf8 encode - dup length serialize-cell - write ; + dup utf8 encode dup length serialize-cell write + add-object ; M: string (serialize) ( obj -- ) [ CHAR: s serialize-string ] serialize-shared ; @@ -103,15 +109,15 @@ M: string (serialize) ( obj -- ) M: tuple (serialize) ( obj -- ) [ CHAR: T write1 - dup add-object serialize-cell - tuple>array serialize-elements + dup tuple>array serialize-elements + add-object ] serialize-shared ; : serialize-seq ( seq code -- ) [ write1 - dup add-object serialize-cell - serialize-elements + dup serialize-elements + add-object ] curry serialize-shared ; M: array (serialize) ( obj -- ) @@ -120,16 +126,16 @@ M: array (serialize) ( obj -- ) M: byte-array (serialize) ( obj -- ) [ CHAR: A write1 - dup add-object serialize-cell - dup length serialize-cell write + dup dup length serialize-cell write + add-object ] serialize-shared ; M: bit-array (serialize) ( obj -- ) [ CHAR: b write1 - dup add-object serialize-cell dup length serialize-cell - [ 1 0 ? ] B{ } map-as write + dup [ 1 0 ? ] B{ } map-as write + add-object ] serialize-shared ; M: quotation (serialize) ( obj -- ) @@ -138,22 +144,25 @@ M: quotation (serialize) ( obj -- ) M: float-array (serialize) ( obj -- ) [ CHAR: f write1 - dup add-object serialize-cell dup length serialize-cell - [ double>bits 8 >be write ] each + dup [ double>bits 8 >be write ] each + add-object ] serialize-shared ; M: hashtable (serialize) ( obj -- ) [ CHAR: h write1 - dup add-object serialize-cell - >alist (serialize) + dup >alist (serialize) + add-object ] serialize-shared ; M: word (serialize) ( obj -- ) - CHAR: w write1 - dup word-name (serialize) - word-vocabulary (serialize) ; + [ + CHAR: w write1 + dup word-name (serialize) + dup word-vocabulary (serialize) + add-object + ] serialize-shared ; M: wrapper (serialize) ( obj -- ) CHAR: W write1 @@ -161,8 +170,10 @@ M: wrapper (serialize) ( obj -- ) DEFER: (deserialize) ( -- obj ) -: intern-object ( id obj -- obj ) - dup rot serialized get set-nth ; +SYMBOL: deserialized + +: intern-object ( obj -- ) + deserialized get push ; : deserialize-false ( -- f ) f ; @@ -189,22 +200,22 @@ DEFER: (deserialize) ( -- obj ) deserialize-cell read utf8 decode ; : deserialize-string ( -- string ) - deserialize-cell (deserialize-string) intern-object ; + (deserialize-string) dup intern-object ; : deserialize-word ( -- word ) (deserialize) dup (deserialize) lookup - [ ] [ "Unknown word" throw ] ?if ; + [ dup intern-object ] [ "Unknown word" throw ] ?if ; : deserialize-wrapper ( -- wrapper ) (deserialize) ; SYMBOL: +stop+ -: (deserialize-seq) +: (deserialize-seq) ( -- seq ) [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; : deserialize-seq ( seq -- array ) - >r deserialize-cell (deserialize-seq) r> like intern-object ; + >r (deserialize-seq) r> like dup intern-object ; : deserialize-array ( -- array ) { } deserialize-seq ; @@ -216,26 +227,25 @@ SYMBOL: +stop+ deserialize-cell read B{ } like ; : deserialize-byte-array ( -- byte-array ) - deserialize-cell (deserialize-byte-array) intern-object ; + (deserialize-byte-array) dup intern-object ; : deserialize-bit-array ( -- bit-array ) - deserialize-cell (deserialize-byte-array) [ 0 > ] ?{ } map-as - intern-object ; + dup intern-object ; : deserialize-float-array ( -- float-array ) - deserialize-cell deserialize-cell + deserialize-cell 8 * read 8 [ be> bits>double ] F{ } map-as - intern-object ; + dup intern-object ; : deserialize-hashtable ( -- hashtable ) - deserialize-cell (deserialize) >hashtable intern-object ; + (deserialize) >hashtable dup intern-object ; : deserialize-tuple ( -- array ) - deserialize-cell (deserialize-seq) >tuple intern-object ; + (deserialize-seq) >tuple dup intern-object ; : deserialize-unknown ( -- object ) - deserialize-cell serialized get nth ; + deserialize-cell deserialized get nth ; : deserialize-stop ( -- object ) +stop+ get ; @@ -270,18 +280,15 @@ SYMBOL: +stop+ : (deserialize) ( -- obj ) deserialize* [ "End of stream" throw ] unless ; -: with-serialized ( quot -- ) - [ - V{ } clone serialized set - gensym +stop+ set - call - ] with-scope ; inline - -: deserialize-sequence ( -- seq ) - [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; - : deserialize ( -- obj ) - [ (deserialize) ] with-serialized ; + [ + V{ } clone deserialized set + gensym +stop+ set + (deserialize) + ] with-scope ; : serialize ( obj -- ) - [ (serialize) ] with-serialized ; \ No newline at end of file + [ + H{ } clone serialized set + (serialize) + ] with-scope ; \ No newline at end of file