steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Faster serialization

db4
Slava Pestov 2008-03-08 03:50:03 -06:00
parent 7ad74eb320
commit 4b4f3b8ea9
4 changed files with 59 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
extra/http/server/authentication/basic/basic.factor
View File

@ -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> 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" <trivial-response>
"Basic realm=\"" rot name>> "\"" 3append
"WWW-Authenticate" set-header
[
<html> <body>
"Username or Password is invalid" write
</body> </html>
] >>body ;
M: realm call-responder ( request path realm -- response )
pick "authorization" header dupd authorization-ok?
[ responder>> call-responder ] [ 2nip <401> ] if ;

31
extra/serialize/serialize-docs.factor
View File

@ -3,33 +3,6 @@
USING: help.syntax help.markup ; USING: help.syntax help.markup ;
IN: serialize 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 HELP: serialize
{ $values { "obj" "object to serialize" } { $values { "obj" "object to serialize" }
} }
@ -37,7 +10,7 @@ HELP: serialize
{ $examples { $examples
{ $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } { $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 HELP: deserialize
{ $values { "obj" "deserialized object" } { $values { "obj" "deserialized object" }
@ -46,4 +19,4 @@ HELP: deserialize
{ $examples { $examples
{ $example "USING: serialize io.streams.string ;" "binary [ { 1 2 } serialize ] with-byte-writer\n\nbinary [ deserialize ] with-byte-reader ." "{ 1 2 }" } { $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 } ;

11
extra/serialize/serialize-tests.factor
View File

@ -77,16 +77,5 @@ C: <serialize-test> serialize-test
[ t ] [ objects [ check-serialize-2 ] all? ] unit-test [ t ] [ objects [ check-serialize-2 ] all? ] unit-test
[ t ] [ pi check-serialize-1 ] 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 [ serialize ] must-infer
[ deserialize ] must-infer [ deserialize ] must-infer

103
extra/serialize/serialize.factor
View File

@ -13,17 +13,25 @@ vectors byte-arrays bit-arrays quotations hashtables
assocs help.syntax help.markup float-arrays splitting assocs help.syntax help.markup float-arrays splitting
io.encodings.string io.encodings.utf8 combinators ; 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 SYMBOL: serialized
: add-object ( obj -- id ) TUPLE: id obj ;
C: <id> 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 #! Add an object to the sequence of already serialized
#! objects. Return the id of that object. #! objects.
serialized get [ push ] keep length 1 - ; serialized get [ assoc-size swap <id> ] keep set-at ;
: object-id ( obj -- id ) : object-id ( obj -- id )
#! Return the id of an already serialized object #! Return the id of an already serialized object
serialized get [ eq? ] with find [ drop f ] unless ; <id> serialized get at ;
! Serialize object ! Serialize object
GENERIC: (serialize) ( obj -- ) GENERIC: (serialize) ( obj -- )
@ -89,10 +97,8 @@ M: ratio (serialize) ( obj -- )
: serialize-string ( obj code -- ) : serialize-string ( obj code -- )
write1 write1
dup add-object serialize-cell dup utf8 encode dup length serialize-cell write
utf8 encode add-object ;
dup length serialize-cell
write ;
M: string (serialize) ( obj -- ) M: string (serialize) ( obj -- )
[ CHAR: s serialize-string ] serialize-shared ; [ CHAR: s serialize-string ] serialize-shared ;
@ -103,15 +109,15 @@ M: string (serialize) ( obj -- )
M: tuple (serialize) ( obj -- ) M: tuple (serialize) ( obj -- )
[ [
CHAR: T write1 CHAR: T write1
dup add-object serialize-cell dup tuple>array serialize-elements
tuple>array serialize-elements add-object
] serialize-shared ; ] serialize-shared ;
: serialize-seq ( seq code -- ) : serialize-seq ( seq code -- )
[ [
write1 write1
dup add-object serialize-cell dup serialize-elements
serialize-elements add-object
] curry serialize-shared ; ] curry serialize-shared ;
M: array (serialize) ( obj -- ) M: array (serialize) ( obj -- )
@ -120,16 +126,16 @@ M: array (serialize) ( obj -- )
M: byte-array (serialize) ( obj -- ) M: byte-array (serialize) ( obj -- )
[ [
CHAR: A write1 CHAR: A write1
dup add-object serialize-cell dup dup length serialize-cell write
dup length serialize-cell write add-object
] serialize-shared ; ] serialize-shared ;
M: bit-array (serialize) ( obj -- ) M: bit-array (serialize) ( obj -- )
[ [
CHAR: b write1 CHAR: b write1
dup add-object serialize-cell
dup length serialize-cell dup length serialize-cell
[ 1 0 ? ] B{ } map-as write dup [ 1 0 ? ] B{ } map-as write
add-object
] serialize-shared ; ] serialize-shared ;
M: quotation (serialize) ( obj -- ) M: quotation (serialize) ( obj -- )
@ -138,22 +144,25 @@ M: quotation (serialize) ( obj -- )
M: float-array (serialize) ( obj -- ) M: float-array (serialize) ( obj -- )
[ [
CHAR: f write1 CHAR: f write1
dup add-object serialize-cell
dup length serialize-cell dup length serialize-cell
[ double>bits 8 >be write ] each dup [ double>bits 8 >be write ] each
add-object
] serialize-shared ; ] serialize-shared ;
M: hashtable (serialize) ( obj -- ) M: hashtable (serialize) ( obj -- )
[ [
CHAR: h write1 CHAR: h write1
dup add-object serialize-cell dup >alist (serialize)
>alist (serialize) add-object
] serialize-shared ; ] serialize-shared ;
M: word (serialize) ( obj -- ) M: word (serialize) ( obj -- )
[
CHAR: w write1 CHAR: w write1
dup word-name (serialize) dup word-name (serialize)
word-vocabulary (serialize) ; dup word-vocabulary (serialize)
add-object
] serialize-shared ;
M: wrapper (serialize) ( obj -- ) M: wrapper (serialize) ( obj -- )
CHAR: W write1 CHAR: W write1
@ -161,8 +170,10 @@ M: wrapper (serialize) ( obj -- )
DEFER: (deserialize) ( -- obj ) DEFER: (deserialize) ( -- obj )
: intern-object ( id obj -- obj ) SYMBOL: deserialized
dup rot serialized get set-nth ;
: intern-object ( obj -- )
deserialized get push ;
: deserialize-false ( -- f ) : deserialize-false ( -- f )
f ; f ;
@ -189,22 +200,22 @@ DEFER: (deserialize) ( -- obj )
deserialize-cell read utf8 decode ; deserialize-cell read utf8 decode ;
: deserialize-string ( -- string ) : deserialize-string ( -- string )
deserialize-cell (deserialize-string) intern-object ; (deserialize-string) dup intern-object ;
: deserialize-word ( -- word ) : deserialize-word ( -- word )
(deserialize) dup (deserialize) lookup (deserialize) dup (deserialize) lookup
[ ] [ "Unknown word" throw ] ?if ; [ dup intern-object ] [ "Unknown word" throw ] ?if ;
: deserialize-wrapper ( -- wrapper ) : deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ; (deserialize) <wrapper> ;
SYMBOL: +stop+ SYMBOL: +stop+
: (deserialize-seq) : (deserialize-seq) ( -- seq )
[ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ; [ (deserialize) dup +stop+ get eq? not ] [ ] [ drop ] unfold ;
: deserialize-seq ( seq -- array ) : 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-array ( -- array )
{ } deserialize-seq ; { } deserialize-seq ;
@ -216,26 +227,25 @@ SYMBOL: +stop+
deserialize-cell read B{ } like ; deserialize-cell read B{ } like ;
: deserialize-byte-array ( -- byte-array ) : deserialize-byte-array ( -- byte-array )
deserialize-cell (deserialize-byte-array) intern-object ; (deserialize-byte-array) dup intern-object ;
: deserialize-bit-array ( -- bit-array ) : deserialize-bit-array ( -- bit-array )
deserialize-cell
(deserialize-byte-array) [ 0 > ] ?{ } map-as (deserialize-byte-array) [ 0 > ] ?{ } map-as
intern-object ; dup intern-object ;
: deserialize-float-array ( -- float-array ) : deserialize-float-array ( -- float-array )
deserialize-cell deserialize-cell deserialize-cell
8 * read 8 <groups> [ be> bits>double ] F{ } map-as 8 * read 8 <groups> [ be> bits>double ] F{ } map-as
intern-object ; dup intern-object ;
: deserialize-hashtable ( -- hashtable ) : deserialize-hashtable ( -- hashtable )
deserialize-cell (deserialize) >hashtable intern-object ; (deserialize) >hashtable dup intern-object ;
: deserialize-tuple ( -- array ) : deserialize-tuple ( -- array )
deserialize-cell (deserialize-seq) >tuple intern-object ; (deserialize-seq) >tuple dup intern-object ;
: deserialize-unknown ( -- object ) : deserialize-unknown ( -- object )
deserialize-cell serialized get nth ; deserialize-cell deserialized get nth ;
: deserialize-stop ( -- object ) : deserialize-stop ( -- object )
+stop+ get ; +stop+ get ;
@ -270,18 +280,15 @@ SYMBOL: +stop+
: (deserialize) ( -- obj ) : (deserialize) ( -- obj )
deserialize* [ "End of stream" throw ] unless ; 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 ( -- obj )
[ (deserialize) ] with-serialized ; [
V{ } clone deserialized set
gensym +stop+ set
(deserialize)
] with-scope ;
: serialize ( obj -- ) : serialize ( obj -- )
[ (serialize) ] with-serialized ; [
H{ } clone serialized set
(serialize)
] with-scope ;