Merge branch 'master' of http://factorcode.org/git/factor into experimental

db4
Alex Chapman 2008-05-02 16:06:54 +10:00
commit 18155ad17e
116 changed files with 2679 additions and 572 deletions

View File

@ -68,7 +68,7 @@ ARTICLE: "assocs-lookup" "Lookup and querying of assocs"
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? } { $subsection assoc-subset? }
{ $subsection assoc-intersect } { $subsection assoc-intersect }
{ $subsection update } { $subsection update }
{ $subsection assoc-union } { $subsection assoc-union }
@ -215,7 +215,7 @@ HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } } { $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ; { $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc? HELP: assoc-subset?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } } { $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ; { $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;

View File

@ -3,13 +3,13 @@ USING: kernel math namespaces tools.test vectors sequences
sequences.private hashtables io prettyprint assocs sequences.private hashtables io prettyprint assocs
continuations ; continuations ;
[ t ] [ H{ } dup subassoc? ] unit-test [ t ] [ H{ } dup assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ } subassoc? ] unit-test [ f ] [ H{ { 1 3 } } H{ } assoc-subset? ] unit-test
[ t ] [ H{ } H{ { 1 3 } } subassoc? ] unit-test [ t ] [ H{ } H{ { 1 3 } } assoc-subset? ] unit-test
[ t ] [ H{ { 1 3 } } H{ { 1 3 } } subassoc? ] unit-test [ t ] [ H{ { 1 3 } } H{ { 1 3 } } assoc-subset? ] unit-test
[ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } subassoc? ] unit-test [ f ] [ H{ { 1 3 } } H{ { 1 "hey" } } assoc-subset? ] unit-test
[ f ] [ H{ { 1 f } } H{ } subassoc? ] unit-test [ f ] [ H{ { 1 f } } H{ } assoc-subset? ] unit-test
[ t ] [ H{ { 1 f } } H{ { 1 f } } subassoc? ] unit-test [ t ] [ H{ { 1 f } } H{ { 1 f } } assoc-subset? ] unit-test
! Test some combinators ! Test some combinators
[ [

View File

@ -98,11 +98,11 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
: assoc-stack ( key seq -- value ) : assoc-stack ( key seq -- value )
dup length 1- swap (assoc-stack) ; dup length 1- swap (assoc-stack) ;
: subassoc? ( assoc1 assoc2 -- ? ) : assoc-subset? ( assoc1 assoc2 -- ? )
[ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ; [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;
: assoc= ( assoc1 assoc2 -- ? ) : assoc= ( assoc1 assoc2 -- ? )
2dup subassoc? >r swap subassoc? r> and ; [ assoc-subset? ] [ swap assoc-subset? ] 2bi and ;
: assoc-hashcode ( n assoc -- code ) : assoc-hashcode ( n assoc -- code )
[ [

View File

@ -305,12 +305,12 @@ M: wrapper '
[ emit ] emit-object ; [ emit ] emit-object ;
! Strings ! Strings
: emit-chars ( seq -- ) : emit-bytes ( seq -- )
bootstrap-cell <groups> bootstrap-cell <groups>
big-endian get [ [ be> ] map ] [ [ le> ] map ] if big-endian get [ [ be> ] map ] [ [ le> ] map ] if
emit-seq ; emit-seq ;
: pack-string ( string -- newstr ) : pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ; dup length bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr ) : emit-string ( string -- ptr )
@ -318,7 +318,7 @@ M: wrapper '
dup length emit-fixnum dup length emit-fixnum
f ' emit f ' emit
f ' emit f ' emit
pack-string emit-chars pad-bytes emit-bytes
] emit-object ; ] emit-object ;
M: string ' M: string '
@ -335,7 +335,11 @@ M: string '
[ 0 emit-fixnum ] emit-object [ 0 emit-fixnum ] emit-object
] bi* ; ] bi* ;
M: byte-array ' byte-array emit-dummy-array ; M: byte-array '
byte-array type-number object tag-number [
dup length emit-fixnum
pad-bytes emit-bytes
] emit-object ;
M: bit-array ' bit-array emit-dummy-array ; M: bit-array ' bit-array emit-dummy-array ;

View File

@ -59,6 +59,7 @@ num-types get f <array> builtins set
"arrays" "arrays"
"bit-arrays" "bit-arrays"
"byte-arrays" "byte-arrays"
"byte-vectors"
"classes.private" "classes.private"
"classes.tuple" "classes.tuple"
"classes.tuple.private" "classes.tuple.private"
@ -452,6 +453,22 @@ tuple
} }
} define-tuple-class } define-tuple-class
"byte-vector" "byte-vectors" create
tuple
{
{
{ "byte-array" "byte-arrays" }
"underlying"
{ "underlying" "growable" }
{ "set-underlying" "growable" }
} {
{ "array-capacity" "sequences.private" }
"fill"
{ "length" "sequences" }
{ "set-fill" "growable" }
}
} define-tuple-class
"curry" "kernel" create "curry" "kernel" create
tuple tuple
{ {

View File

@ -16,6 +16,7 @@ IN: bootstrap.syntax
"?{" "?{"
"BIN:" "BIN:"
"B{" "B{"
"BV{"
"C:" "C:"
"CHAR:" "CHAR:"
"DEFER:" "DEFER:"

View File

@ -1,20 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences USING: arrays kernel kernel.private math sequences
sequences.private growable byte-arrays prettyprint.backend sequences.private growable byte-arrays ;
parser accessors ;
IN: byte-vectors IN: byte-vectors
TUPLE: byte-vector underlying fill ;
M: byte-vector underlying underlying>> { byte-array } declare ;
M: byte-vector set-underlying (>>underlying) ;
M: byte-vector length fill>> { array-capacity } declare ;
M: byte-vector set-fill (>>fill) ;
<PRIVATE <PRIVATE
: byte-array>vector ( byte-array length -- byte-vector ) : byte-array>vector ( byte-array length -- byte-vector )
@ -43,9 +32,3 @@ M: byte-vector equal?
M: byte-array new-resizable drop <byte-vector> ; M: byte-array new-resizable drop <byte-vector> ;
INSTANCE: byte-vector growable INSTANCE: byte-vector growable
: BV{ \ } [ >byte-vector ] parse-literal ; parsing
M: byte-vector >pprint-sequence ;
M: byte-vector pprint-delims drop \ BV{ \ } ;

View File

@ -0,0 +1,51 @@
USING: help.markup help.syntax kernel math sequences quotations
math.private byte-arrays strings ;
IN: checksums
HELP: checksum
{ $class-description "The class of checksum algorithms." } ;
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
{ $examples
{ $example "USING: checksums io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
}
{ $notes "Numbers are zero-padded on the left." } ;
HELP: checksum-stream
{ $values { "stream" "an input stream" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data read from the stream." }
{ $side-effects "stream" } ;
HELP: checksum-bytes
{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data in a sequence." } ;
HELP: checksum-lines
{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data in a sequence." } ;
HELP: checksum-file
{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
{ $contract "Computes the checksum of all data in a file." } ;
ARTICLE: "checksums" "Checksums"
"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
$nl
"Checksums are instances of a class:"
{ $subsection checksum }
"Operations on checksums:"
{ $subsection checksum-bytes }
{ $subsection checksum-stream }
{ $subsection checksum-lines }
"Checksums should implement at least one of " { $link checksum-bytes } " and " { $link checksum-stream } ". Implementing " { $link checksum-lines } " is optional."
$nl
"Utilities:"
{ $subsection checksum-file }
{ $subsection hex-string }
"Checksum implementations:"
{ $subsection "checksums.crc32" }
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" } ;

View File

@ -0,0 +1,25 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: sequences math.parser io io.streams.byte-array
io.encodings.binary io.files kernel ;
IN: checksums
MIXIN: checksum
GENERIC: checksum-bytes ( bytes checksum -- value )
GENERIC: checksum-stream ( stream checksum -- value )
GENERIC: checksum-lines ( lines checksum -- value )
M: checksum checksum-bytes >r binary <byte-reader> r> checksum-stream ;
M: checksum checksum-stream >r contents r> checksum-bytes ;
M: checksum checksum-lines >r B{ CHAR: \n } join r> checksum-bytes ;
: checksum-file ( path checksum -- value )
>r binary <file-reader> r> checksum-stream ;
: hex-string ( seq -- str )
[ >hex 2 CHAR: 0 pad-left ] { } map-as concat ;

View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax math ;
IN: checksums.crc32
HELP: crc32
{ $class-description "The CRC32 checksum algorithm." } ;
ARTICLE: "checksums.crc32" "CRC32 checksum"
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
{ $subsection crc32 } ;
ABOUT: "checksums.crc32"

View File

@ -0,0 +1,6 @@
USING: checksums checksums.crc32 kernel math tools.test namespaces ;
[ B{ 0 0 0 0 } ] [ "" crc32 checksum-bytes ] unit-test
[ B{ HEX: cb HEX: f4 HEX: 39 HEX: 26 } ] [ "123456789" crc32 checksum-bytes ] unit-test

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sequences.private namespaces USING: kernel math sequences sequences.private namespaces
words io io.binary io.files io.streams.string quotations words io io.binary io.files io.streams.string quotations
definitions ; definitions checksums ;
IN: io.crc32 IN: checksums.crc32
: crc32-polynomial HEX: edb88320 ; inline : crc32-polynomial HEX: edb88320 ; inline
@ -20,10 +20,20 @@ IN: io.crc32
mask-byte crc32-table nth-unsafe >bignum mask-byte crc32-table nth-unsafe >bignum
swap -8 shift bitxor ; inline swap -8 shift bitxor ; inline
: crc32 ( seq -- n ) SINGLETON: crc32
>r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
: lines-crc32 ( seq -- n ) INSTANCE: crc32 checksum
HEX: ffffffff tuck [
[ (crc32) ] each CHAR: \n (crc32) : init-crc32 drop >r HEX: ffffffff dup r> ; inline
] reduce bitxor ;
: finish-crc32 bitxor 4 >be ; inline
M: crc32 checksum-bytes
init-crc32
[ (crc32) ] each
finish-crc32 ;
M: crc32 checksum-lines
init-crc32
[ [ (crc32) ] each CHAR: \n (crc32) ] each
finish-crc32 ;

View File

@ -1,6 +1,6 @@
USING: kernel math namespaces io tools.test sequences vectors USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words continuations debugger parser memory arrays words
kernel.private ; kernel.private accessors ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) : (callcc1-test)
@ -100,3 +100,20 @@ SYMBOL: error-counter
[ 3 ] [ always-counter get ] unit-test [ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test
] with-scope ] with-scope
TUPLE: dispose-error ;
M: dispose-error dispose 3 throw ;
TUPLE: dispose-dummy disposed? ;
M: dispose-dummy dispose t >>disposed? drop ;
T{ dispose-error } "a" set
T{ dispose-dummy } "b" set
[ f ] [ "b" get disposed?>> ] unit-test
[ { "a" "b" } [ get ] map dispose-each ] [ 3 = ] must-fail-with
[ t ] [ "b" get disposed?>> ] unit-test

View File

@ -138,6 +138,11 @@ SYMBOL: thread-error-hook
GENERIC: dispose ( object -- ) GENERIC: dispose ( object -- )
: dispose-each ( seq -- )
[
[ [ dispose ] curry [ , ] recover ] each
] { } make dup empty? [ drop ] [ peek rethrow ] if ;
: with-disposal ( object quot -- ) : with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline over [ dispose ] curry [ ] cleanup ; inline

View File

@ -1,17 +0,0 @@
USING: help.markup help.syntax math ;
IN: io.crc32
HELP: crc32
{ $values { "seq" "a sequence of bytes" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
HELP: lines-crc32
{ $values { "seq" "a sequence of strings" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
ARTICLE: "io.crc32" "CRC32 checksum calculation"
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
{ $subsection crc32 }
{ $subsection lines-crc32 } ;
ABOUT: "io.crc32"

View File

@ -1,5 +0,0 @@
USING: io.crc32 kernel math tools.test namespaces ;
[ 0 ] [ "" crc32 ] unit-test
[ HEX: cbf43926 ] [ "123456789" crc32 ] unit-test

View File

@ -11,10 +11,6 @@ namespaces assocs kernel sequences math tools.test words ;
dataflow compute-def-use drop compute-dead-literals keys dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ; [ value-literal ] map ;
: subset? [ member? ] curry all? ;
: set= 2dup subset? >r swap subset? r> and ;
[ { [ + ] } ] [ [ { [ + ] } ] [
[ [ 1 2 3 ] [ + ] over drop drop ] kill-set [ [ 1 2 3 ] [ + ] over drop drop ] kill-set
] unit-test ] unit-test

View File

@ -4,7 +4,7 @@ IN: optimizer.known-words
USING: alien arrays generic hashtables inference.dataflow USING: alien arrays generic hashtables inference.dataflow
inference.class kernel assocs math math.private kernel.private inference.class kernel assocs math math.private kernel.private
sequences words parser vectors strings sbufs io namespaces sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32 assocs quotations sequences.private io.binary
io.streams.string layouts splitting math.intervals io.streams.string layouts splitting math.intervals
math.floats.private classes.tuple classes.tuple.private classes math.floats.private classes.tuple classes.tuple.private classes
classes.algebra optimizer.def-use optimizer.backend classes.algebra optimizer.def-use optimizer.backend
@ -126,8 +126,6 @@ sequences.private combinators ;
\ >sbuf { string } "specializer" set-word-prop \ >sbuf { string } "specializer" set-word-prop
\ crc32 { string } "specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop \ split, { string string } "specializer" set-word-prop
\ memq? { array } "specializer" set-word-prop \ memq? { array } "specializer" set-word-prop

View File

@ -432,3 +432,6 @@ must-fail-with
] must-fail ] must-fail
[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with [ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test

View File

@ -421,14 +421,17 @@ ERROR: bad-number ;
SYMBOL: current-class SYMBOL: current-class
SYMBOL: current-generic SYMBOL: current-generic
: (M:) : with-method-definition ( quot -- parsed )
CREATE-METHOD
[ [
>r
[ "method-class" word-prop current-class set ] [ "method-class" word-prop current-class set ]
[ "method-generic" word-prop current-generic set ] [ "method-generic" word-prop current-generic set ]
[ ] tri [ ] tri
parse-definition r> call
] with-scope ; ] with-scope ; inline
: (M:)
CREATE-METHOD [ parse-definition ] with-method-definition ;
: scan-object ( -- object ) : scan-object ( -- object )
scan-word dup parsing? scan-word dup parsing?

View File

@ -1,10 +1,11 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays bit-arrays generic hashtables io USING: arrays byte-arrays byte-vectors bit-arrays generic
assocs kernel math namespaces sequences strings sbufs io.styles hashtables io assocs kernel math namespaces sequences strings
vectors words prettyprint.config prettyprint.sections quotations sbufs io.styles vectors words prettyprint.config
io io.files math.parser effects classes.tuple math.order prettyprint.sections quotations io io.files math.parser effects
classes.tuple.private classes float-arrays ; classes.tuple math.order classes.tuple.private classes
float-arrays ;
IN: prettyprint.backend IN: prettyprint.backend
GENERIC: pprint* ( obj -- ) GENERIC: pprint* ( obj -- )
@ -140,6 +141,7 @@ M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ; M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ; M: byte-array pprint-delims drop \ B{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ; M: bit-array pprint-delims drop \ ?{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ; M: float-array pprint-delims drop \ F{ \ } ;
M: vector pprint-delims drop \ V{ \ } ; M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ; M: hashtable pprint-delims drop \ H{ \ } ;
@ -152,6 +154,7 @@ GENERIC: >pprint-sequence ( obj -- seq )
M: object >pprint-sequence ; M: object >pprint-sequence ;
M: vector >pprint-sequence ; M: vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ; M: curry >pprint-sequence ;
M: compose >pprint-sequence ; M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ; M: hashtable >pprint-sequence >alist ;

View File

@ -2,7 +2,7 @@ USING: kernel help.markup help.syntax sequences ;
IN: sets IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences" ARTICLE: "sets" "Set-theoretic operations on sequences"
"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time." "Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. All of these operations use hashtables internally to achieve linear running time."
$nl $nl
"Remove duplicates:" "Remove duplicates:"
{ $subsection prune } { $subsection prune }
@ -12,8 +12,14 @@ $nl
{ $subsection diff } { $subsection diff }
{ $subsection intersect } { $subsection intersect }
{ $subsection union } { $subsection union }
{ $subsection subset? }
{ $subsection set= }
"A word used to implement the above:"
{ $subsection unique }
{ $see-also member? memq? contains? all? "assocs-sets" } ; { $see-also member? memq? contains? all? "assocs-sets" } ;
ABOUT: "sets"
HELP: unique HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } } { $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." } { $description "Outputs a new assoc where the keys and values are equal." }
@ -59,3 +65,11 @@ HELP: union
} ; } ;
{ diff intersect union } related-words { diff intersect union } related-words
HELP: subset?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if both sequences contain the same elements, disregrading order and duplicates." } ;

View File

@ -29,3 +29,9 @@ IN: sets
: union ( seq1 seq2 -- newseq ) : union ( seq1 seq2 -- newseq )
append prune ; append prune ;
: subset? ( seq1 seq2 -- ? )
unique [ key? ] curry all? ;
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;

View File

@ -3,8 +3,8 @@
USING: arrays definitions generic assocs kernel math namespaces USING: arrays definitions generic assocs kernel math namespaces
prettyprint sequences strings vectors words quotations inspector prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables continuations debugger io.files checksums checksums.crc32 vocabs
graphs compiler.units io.encodings.utf8 accessors ; hashtables graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files IN: source-files
SYMBOL: source-files SYMBOL: source-files
@ -15,7 +15,7 @@ checksum
uses definitions ; uses definitions ;
: record-checksum ( lines source-file -- ) : record-checksum ( lines source-file -- )
>r lines-crc32 r> set-source-file-checksum ; >r crc32 checksum-lines r> set-source-file-checksum ;
: (xref-source) ( source-file -- pathname uses ) : (xref-source) ( source-file -- pathname uses )
dup source-file-path <pathname> dup source-file-path <pathname>

View File

@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays bit-arrays byte-arrays USING: alien arrays bit-arrays byte-arrays byte-vectors
definitions generic hashtables kernel math definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard quotations io assocs splitting classes.tuple generic.standard
@ -79,6 +79,7 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax "{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax "V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax "B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax

View File

@ -1,10 +1,10 @@
USING: io.crc32 io.encodings.ascii io.files kernel math ; USING: checksums checksums.crc32 io.encodings.ascii io.files kernel math ;
IN: benchmark.crc32 IN: benchmark.crc32
: crc32-primes-list ( -- ) : crc32-primes-list ( -- )
10 [ 10 [
"extra/math/primes/list/list.factor" resource-path "resource:extra/math/primes/list/list.factor"
ascii file-contents crc32 drop crc32 checksum-file drop
] times ; ] times ;
MAIN: crc32-primes-list MAIN: crc32-primes-list

View File

@ -1,7 +1,7 @@
USING: crypto.md5 io.files kernel ; USING: checksums checksums.md5 io.files kernel ;
IN: benchmark.md5 IN: benchmark.md5
: md5-primes-list ( -- ) : md5-primes-list ( -- )
"extra/math/primes/list/list.factor" resource-path file>md5 drop ; "resource:extra/math/primes/list/list.factor" md5 checksum-file drop ;
MAIN: md5-primes-list MAIN: md5-primes-list

View File

@ -1,13 +1,13 @@
IN: benchmark.reverse-complement.tests IN: benchmark.reverse-complement.tests
USING: tools.test benchmark.reverse-complement crypto.md5 USING: tools.test benchmark.reverse-complement
checksums checksums.md5
io.files kernel ; io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [ [ "c071aa7e007a9770b2fb4304f55a17e5" ] [
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt" "resource:extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt" "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] bi@
reverse-complement reverse-complement
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt" "resource:extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
resource-path file>md5str md5 checksum-file hex-string
] unit-test ] unit-test

View File

@ -1,7 +1,7 @@
USING: crypto.sha1 io.files kernel ; USING: checksums checksums.sha1 io.files kernel ;
IN: benchmark.sha1 IN: benchmark.sha1
: sha1-primes-list ( -- ) : sha1-primes-list ( -- )
"extra/math/primes/list/list.factor" resource-path file>sha1 drop ; "resource:extra/math/primes/list/list.factor" sha1 checksum-file drop ;
MAIN: sha1-primes-list MAIN: sha1-primes-list

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: bootstrap.image.download IN: bootstrap.image.download
USING: http.client crypto.md5 splitting assocs kernel io.files USING: http.client checksums checksums.md5 splitting assocs
bootstrap.image sequences io ; kernel io.files bootstrap.image sequences io ;
: url "http://factorcode.org/images/latest/" ; : url "http://factorcode.org/images/latest/" ;
@ -12,7 +12,7 @@ bootstrap.image sequences io ;
: need-new-image? ( image -- ? ) : need-new-image? ( image -- ? )
dup exists? dup exists?
[ dup file>md5str swap download-checksums at = not ] [ [ md5 checksum-file hex-string ] [ download-checksums at ] bi = not ]
[ drop t ] if ; [ drop t ] if ;
: download-image ( arch -- ) : download-image ( arch -- )

View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload IN: bootstrap.image.upload
USING: http.client crypto.md5 splitting assocs kernel io.files
bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ;
SYMBOL: upload-images-destination SYMBOL: upload-images-destination
@ -17,7 +18,9 @@ SYMBOL: upload-images-destination
: compute-checksums ( -- ) : compute-checksums ( -- )
checksums ascii [ checksums ascii [
boot-image-names [ dup write bl file>md5str print ] each boot-image-names [
[ write bl ] [ md5 checksum-file hex-string print ] bi
] each
] with-file-writer ; ] with-file-writer ;
: upload-images ( -- ) : upload-images ( -- )

View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.md5
HELP: md5
{ $description "MD5 checksum algorithm." } ;
ARTICLE: "checksums.md5" "MD5 checksum"
"The MD5 checksum algorithm implements a one-way hash function. While it is widely used, many weaknesses are known and it should not be used in new applications (" { $url "http://www.schneier.com/blog/archives/2005/03/more_hash_funct.html" } ")."
{ $subsection md5 } ;
ABOUT: "checksums.md5"

View File

@ -0,0 +1,10 @@
USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test

View File

@ -3,8 +3,8 @@
USING: kernel io io.binary io.files io.streams.byte-array math USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols math.bitfields.lib ; io.encodings.binary symbols math.bitfields.lib checksums ;
IN: crypto.md5 IN: checksums.md5
<PRIVATE <PRIVATE
@ -166,26 +166,18 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
[ (process-md5-block) ] each [ (process-md5-block) ] each
] if ; ] if ;
: (stream>md5) ( -- ) : stream>md5 ( -- )
64 read [ process-md5-block ] keep 64 read [ process-md5-block ] keep
length 64 = [ (stream>md5) ] when ; length 64 = [ stream>md5 ] when ;
: get-md5 ( -- str ) : get-md5 ( -- str )
[ a b c d ] [ get 4 >le ] map concat >byte-array ; [ a b c d ] [ get 4 >le ] map concat >byte-array ;
PRIVATE> PRIVATE>
: stream>md5 ( stream -- byte-array ) SINGLETON: md5
[ initialize-md5 (stream>md5) get-md5 ] with-stream ;
: byte-array>md5 ( byte-array -- checksum ) INSTANCE: md5 checksum
binary <byte-reader> stream>md5 ;
: byte-array>md5str ( byte-array -- md5-string ) M: md5 checksum-stream ( stream -- byte-array )
byte-array>md5 hex-string ; drop [ initialize-md5 stream>md5 get-md5 ] with-stream ;
: file>md5 ( path -- byte-array )
binary <file-reader> stream>md5 ;
: file>md5str ( path -- md5-string )
file>md5 hex-string ;

View File

@ -0,0 +1,8 @@
USING: checksums ;
IN: checksums.null
SINGLETON: null
INSTANCE: null checksum
M: null checksum-bytes ;

View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.sha1
HELP: sha1
{ $description "SHA1 checksum algorithm." } ;
ARTICLE: "checksums.sha1" "SHA1 checksum"
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
{ $subsection sha1 } ;
ABOUT: "checksums.sha1"

View File

@ -1,14 +1,14 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" byte-array>sha1str ] unit-test [ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" byte-array>sha1str ] unit-test [ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time... ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
10 swap <array> concat byte-array>sha1str ] unit-test 10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
[ [
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
] [ ] [
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
byte-array>sha1-interleave sha1-interleave
] unit-test ] unit-test

View File

@ -1,8 +1,8 @@
USING: arrays combinators crypto.common kernel io USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors strings sequences namespaces math parser sequences vectors
io.binary hashtables symbols math.bitfields.lib ; io.binary hashtables symbols math.bitfields.lib checksums ;
IN: crypto.sha1 IN: checksums.sha1
! Implemented according to RFC 3174. ! Implemented according to RFC 3174.
@ -99,30 +99,22 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
[ (process-sha1-block) ] each [ (process-sha1-block) ] each
] if ; ] if ;
: (stream>sha1) ( -- ) : stream>sha1 ( -- )
64 read [ process-sha1-block ] keep 64 read [ process-sha1-block ] keep
length 64 = [ (stream>sha1) ] when ; length 64 = [ stream>sha1 ] when ;
: get-sha1 ( -- str ) : get-sha1 ( -- str )
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
: stream>sha1 ( stream -- sha1 ) SINGLETON: sha1
[ initialize-sha1 (stream>sha1) get-sha1 ] with-stream ;
: byte-array>sha1 ( string -- sha1 ) INSTANCE: sha1 checksum
binary <byte-reader> stream>sha1 ;
: byte-array>sha1str ( string -- str ) M: sha1 checksum-stream ( stream -- sha1 )
byte-array>sha1 hex-string ; drop [ initialize-sha1 stream>sha1 get-sha1 ] with-stream ;
: byte-array>sha1-bignum ( string -- n ) : sha1-interleave ( string -- seq )
byte-array>sha1 be> ;
: file>sha1 ( file -- sha1 )
binary <file-reader> stream>sha1 ;
: byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim [ zero? ] left-trim
dup length odd? [ rest ] when dup length odd? [ rest ] when
seq>2seq [ byte-array>sha1 ] bi@ seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ; 2seq>seq ;

View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax ;
IN: checksums.sha2
HELP: sha-256
{ $description "SHA-256 checksum algorithm." } ;
ARTICLE: "checksums.sha2" "SHA2 checksum"
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
{ $subsection sha-256 } ;
ABOUT: "checksums.sha2"

View File

@ -1,7 +1,7 @@
USING: arrays kernel math namespaces sequences tools.test crypto.sha2 ; USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" byte-array>sha-256-string ] unit-test [ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" byte-array>sha-256-string ] unit-test [ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" byte-array>sha-256-string ] unit-test [ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" byte-array>sha-256-string ] unit-test [ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" byte-array>sha-256-string ] unit-test [ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" byte-array>sha-256-string ] unit-test [ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test

View File

@ -1,6 +1,6 @@
USING: crypto.common kernel splitting math sequences namespaces USING: crypto.common kernel splitting math sequences namespaces
io.binary symbols math.bitfields.lib ; io.binary symbols math.bitfields.lib checksums ;
IN: crypto.sha2 IN: checksums.sha2
<PRIVATE <PRIVATE
@ -118,14 +118,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
PRIVATE> PRIVATE>
: byte-array>sha-256 ( string -- string ) SINGLETON: sha-256
[
INSTANCE: sha-256 checksum
M: sha-256 checksum-bytes
drop [
K-256 K set K-256 K set
initial-H-256 H set initial-H-256 H set
4 word-size set 4 word-size set
64 block-size set 64 block-size set
byte-array>sha2 byte-array>sha2
] with-scope ; ] with-scope ;
: byte-array>sha-256-string ( string -- hexstring )
byte-array>sha-256 hex-string ;

View File

@ -1,13 +0,0 @@
USING: help.markup help.syntax kernel math sequences quotations
math.private ;
IN: crypto.common
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
{ $examples
{ $example "USING: crypto.common io ;" "B{ 1 2 3 4 } hex-string print" "01020304" }
}
{ $notes "Numbers are zero-padded on the left." } ;

View File

@ -1,5 +1,6 @@
USING: arrays kernel io io.binary sbufs splitting strings sequences USING: arrays kernel io io.binary sbufs splitting strings sequences
namespaces math math.parser parser hints math.bitfields.lib ; namespaces math math.parser parser hints math.bitfields.lib
assocs ;
IN: crypto.common IN: crypto.common
: w+ ( int int -- int ) + 32 bits ; inline : w+ ( int int -- int ) + 32 bits ; inline
@ -39,9 +40,6 @@ SYMBOL: big-endian?
: update-old-new ( old new -- ) : update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
: hex-string ( seq -- str )
[ [ >hex 2 48 pad-left % ] each ] "" make ;
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; : slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
: seq>2seq ( seq -- seq1 seq2 ) : seq>2seq ( seq -- seq1 seq2 )
@ -50,7 +48,7 @@ SYMBOL: big-endian?
: 2seq>seq ( seq1 seq2 -- seq ) : 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh } #! { aceg } { bdfh } -> { abcdefgh }
[ 2array flip concat ] keep like ; [ zip concat ] keep like ;
: mod-nth ( n seq -- elt ) : mod-nth ( n seq -- elt )
#! 5 "abcd" -> b #! 5 "abcd" -> b

View File

@ -1,18 +1,19 @@
USING: arrays combinators crypto.common crypto.md5 crypto.sha1 USING: arrays combinators crypto.common checksums checksums.md5
crypto.md5.private io io.binary io.files io.streams.byte-array checksums.sha1 checksums.md5.private io io.binary io.files
kernel math math.vectors memoize sequences io.encodings.binary ; io.streams.byte-array kernel math math.vectors memoize sequences
io.encodings.binary ;
IN: crypto.hmac IN: crypto.hmac
: sha1-hmac ( Ko Ki -- hmac ) : sha1-hmac ( Ko Ki -- hmac )
initialize-sha1 process-sha1-block initialize-sha1 process-sha1-block
(stream>sha1) get-sha1 stream>sha1 get-sha1
initialize-sha1 initialize-sha1
>r process-sha1-block r> >r process-sha1-block r>
process-sha1-block get-sha1 ; process-sha1-block get-sha1 ;
: md5-hmac ( Ko Ki -- hmac ) : md5-hmac ( Ko Ki -- hmac )
initialize-md5 process-md5-block initialize-md5 process-md5-block
(stream>md5) get-md5 stream>md5 get-md5
initialize-md5 initialize-md5
>r process-md5-block r> >r process-md5-block r>
process-md5-block get-md5 ; process-md5-block get-md5 ;

View File

@ -1,18 +0,0 @@
USING: help.markup help.syntax kernel math sequences quotations
crypto.common byte-arrays ;
IN: crypto.md5
HELP: stream>md5
{ $values { "stream" "a stream" } { "byte-array" "md5 hash" } }
{ $description "Take the MD5 hash until end of stream." }
{ $notes "Used to implement " { $link byte-array>md5 } " and " { $link file>md5 } ". Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: byte-array>md5
{ $values { "byte-array" byte-array } { "checksum" "an md5 hash" } }
{ $description "Outputs the MD5 hash of a byte array." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;
HELP: file>md5
{ $values { "path" "a path" } { "byte-array" "byte-array md5 hash" } }
{ $description "Outputs the MD5 hash of a file." }
{ $notes "Call " { $link hex-string } " to convert to the canonical string representation." } ;

View File

@ -1,10 +0,0 @@
USING: kernel math namespaces crypto.md5 tools.test byte-arrays ;
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array byte-array>md5str ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array byte-array>md5str ] unit-test
[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" >byte-array byte-array>md5str ] unit-test
[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" >byte-array byte-array>md5str ] unit-test
[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" >byte-array byte-array>md5str ] unit-test
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array byte-array>md5str ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array byte-array>md5str ] unit-test

View File

@ -12,3 +12,10 @@ HELP: csv-row
{ "row" "an array of fields" } } { "row" "an array of fields" } }
{ $description "parses a row from a csv stream" { $description "parses a row from a csv stream"
} ; } ;
HELP: with-delimiter
{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
{ "quot" "a quotation" } }
{ $description "Sets the field delimiter for csv or csv-row words "
} ;

View File

@ -47,7 +47,6 @@ IN: csv.tests
<string-reader> csv ] named-unit-test <string-reader> csv ] named-unit-test
! !!!!!!!! other tests ! !!!!!!!! other tests
[ { { "Phil Dawes" } } ] [ { { "Phil Dawes" } } ]
@ -59,3 +58,13 @@ IN: csv.tests
"trims leading and trailing whitespace - n.b. this isn't really conformant, but lots of csv seems to assume this" "trims leading and trailing whitespace - n.b. this isn't really conformant, but lots of csv seems to assume this"
[ { { "foo yeah" "bah" "baz" } } ] [ { { "foo yeah" "bah" "baz" } } ]
[ " foo yeah , bah ,baz\n" <string-reader> csv ] named-unit-test [ " foo yeah , bah ,baz\n" <string-reader> csv ] named-unit-test
"allows setting of delimiting character"
[ { { "foo" "bah" "baz" } } ]
[ "foo\tbah\tbaz\n" <string-reader> CHAR: \t [ csv ] with-delimiter ] named-unit-test
"Quoted field followed immediately by newline"
[ { { "foo" "bar" }
{ "1" "2" } } ]
[ "foo,\"bar\"\n1,2" <string-reader> csv ] named-unit-test

View File

@ -4,44 +4,47 @@
! Simple CSV Parser ! Simple CSV Parser
! Phil Dawes phil@phildawes.net ! Phil Dawes phil@phildawes.net
USING: kernel sequences io namespaces combinators USING: kernel sequences io namespaces combinators unicode.categories vars ;
unicode.categories ;
IN: csv IN: csv
DEFER: quoted-field DEFER: quoted-field
: not-quoted-field ( -- endchar ) VAR: delimiter
",\"\n" read-until ! "
dup
{ { CHAR: " [ drop drop quoted-field ] } ! "
{ CHAR: , [ swap % ] }
{ CHAR: \n [ swap % ] }
{ f [ swap % ] } ! eof
} case ;
: maybe-escaped-quote ( -- endchar )
read1
dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ CHAR: \s [ drop not-quoted-field ] }
{ CHAR: \t [ drop not-quoted-field ] }
[ drop ]
} case ;
! trims whitespace from either end of string ! trims whitespace from either end of string
: trim-whitespace ( str -- str ) : trim-whitespace ( str -- str )
[ blank? ] trim ; inline [ blank? ] trim ; inline
: skip-to-field-end ( -- endchar )
"\n" delimiter> suffix read-until nip ; inline
: not-quoted-field ( -- endchar )
"\"\n" delimiter> suffix read-until ! "
dup
{ { CHAR: " [ drop drop quoted-field ] } ! "
{ delimiter> [ swap trim-whitespace % ] }
{ CHAR: \n [ swap trim-whitespace % ] }
{ f [ swap trim-whitespace % ] } ! eof
} case ;
: maybe-escaped-quote ( -- endchar )
read1 dup
{ { CHAR: " [ , quoted-field ] } ! " is an escaped quote
{ delimiter> [ ] } ! end of quoted field
{ CHAR: \n [ ] }
[ 2drop skip-to-field-end ] ! end of quoted field + padding
} case ;
: quoted-field ( -- endchar ) : quoted-field ( -- endchar )
"\"" read-until ! " "\"" read-until ! "
drop % maybe-escaped-quote ; drop % maybe-escaped-quote ;
: field ( -- sep string ) : field ( -- sep string )
[ not-quoted-field ] "" make trim-whitespace ; [ not-quoted-field ] "" make ; ! trim-whitespace
: (row) ( -- sep ) : (row) ( -- sep )
field , field ,
dup CHAR: , = [ drop (row) ] when ; dup delimiter> = [ drop (row) ] when ;
: row ( -- eof? array[string] ) : row ( -- eof? array[string] )
[ (row) ] { } make ; [ (row) ] { } make ;
@ -53,8 +56,16 @@ DEFER: quoted-field
row append-if-row-not-empty row append-if-row-not-empty
[ (csv) ] when ; [ (csv) ] when ;
: init-vars ( -- )
delimiter> [ CHAR: , >delimiter ] unless ; inline
: csv-row ( stream -- row ) : csv-row ( stream -- row )
init-vars
[ row nip ] with-stream ; [ row nip ] with-stream ;
: csv ( stream -- rows ) : csv ( stream -- rows )
init-vars
[ [ (csv) ] { } make ] with-stream ; [ [ (csv) ] { } make ] with-stream ;
: with-delimiter ( char quot -- )
delimiter swap with-variable ; inline

View File

@ -24,30 +24,17 @@ HELP: CONSULT:
{ define-consult POSTPONE: CONSULT: } related-words { define-consult POSTPONE: CONSULT: } related-words
HELP: define-mimic
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." }
{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ;
HELP: MIMIC:
{ $syntax "MIMIC: group mimicker mimicked" }
{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } }
{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ;
HELP: group-words HELP: group-words
{ $values { "group" "a group" } { "words" "an array of words" } } { $values { "group" "a group" } { "words" "an array of words" } }
{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ; { $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ;
ARTICLE: { "delegate" "intro" } "Delegation module" ARTICLE: { "delegate" "intro" } "Delegation module"
"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use" "This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use"
{ $subsection POSTPONE: PROTOCOL: } { $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol } { $subsection define-protocol }
"One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are" "One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are"
{ $subsection POSTPONE: CONSULT: } { $subsection POSTPONE: CONSULT: }
{ $subsection define-consult } { $subsection define-consult } ;
"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are"
{ $subsection POSTPONE: MIMIC: }
{ $subsection define-mimic } ;
IN: delegate IN: delegate
ABOUT: { "delegate" "intro" } ABOUT: { "delegate" "intro" }

View File

@ -2,11 +2,6 @@ USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string ; compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests IN: delegate.tests
DEFER: example
[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
[ 2 ] [ \ example "prop" word-prop ] unit-test
TUPLE: hello this that ; TUPLE: hello this that ;
C: <hello> hello C: <hello> hello
@ -30,21 +25,19 @@ GENERIC: bing ( c -- d )
PROTOCOL: bee bing ; PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ; CONSULT: hello goodbye goodbye-those ;
M: hello bing hello-test ; M: hello bing hello-test ;
MIMIC: bee goodbye hello
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test [ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test [ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test [ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test [ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test [ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ V{ goodbye } ] [ baz protocol-users ] unit-test [ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
! [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test ! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test ! [ f ] [ goodbye baz method ] unit-test

View File

@ -1,9 +1,44 @@
! Copyright (C) 2007 Daniel Ehrenberg ! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays USING: parser generic kernel classes words slots assocs sequences arrays
vectors definitions prettyprint combinators.lib math sets ; vectors definitions prettyprint combinators.lib math hashtables sets ;
IN: delegate IN: delegate
: protocol-words ( protocol -- words )
\ protocol-words word-prop ;
: protocol-consult ( protocol -- consulters )
\ protocol-consult word-prop ;
GENERIC: group-words ( group -- words )
M: tuple-class group-words
"slot-names" word-prop [
[ reader-word ] [ writer-word ] bi
2array [ 0 2array ] map
] map concat ;
! Consultation
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
rot word-props swap change-at ; inline
: register-protocol ( group class quot -- )
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
: define-consult ( group class quot -- )
[ register-protocol ] [
rot group-words -rot
[ consult-method ] 2curry each
] 3bi ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
! Protocols ! Protocols
: cross-2each ( seq1 seq2 quot -- ) : cross-2each ( seq1 seq2 quot -- )
@ -12,36 +47,46 @@ IN: delegate
: forget-all-methods ( classes words -- ) : forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ; [ 2array forget ] cross-2each ;
: protocol-words ( protocol -- words )
"protocol-words" word-prop ;
: protocol-users ( protocol -- users ) : protocol-users ( protocol -- users )
"protocol-users" word-prop ; protocol-consult keys ;
: users-and-words ( protocol -- users words ) : lost-words ( protocol wordlist -- lost-words )
[ protocol-users ] [ protocol-words ] bi ; >r protocol-words r> diff ;
: forget-old-definitions ( protocol new-wordlist -- ) : forget-old-definitions ( protocol new-wordlist -- )
>r users-and-words r> >r [ protocol-users ] [ protocol-words ] bi r>
swap diff forget-all-methods ; swap diff forget-all-methods ;
: define-protocol ( protocol wordlist -- ) : added-words ( protocol wordlist -- added-words )
! 2dup forget-old-definitions swap protocol-words swap diff ;
{ } like "protocol-words" set-word-prop ;
: add-new-definitions ( protocol wordlist -- )
dupd added-words >r protocol-consult >alist r>
[ first2 consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[ drop H{ } clone \ protocol-consult set-word-prop ]
[ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' ) : fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ; [ dup word? [ 0 2array ] when ] map ;
: define-protocol ( protocol wordlist -- )
fill-in-depth
[ forget-old-definitions ]
[ add-new-definitions ]
[ initialize-protocol-props ] 2tri ;
: PROTOCOL: : PROTOCOL:
CREATE-WORD CREATE-WORD
dup define-symbol [ define-symbol ]
dup f "inline" set-word-prop [ f "inline" set-word-prop ]
parse-definition fill-in-depth define-protocol ; parsing [ parse-definition define-protocol ] tri ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget* M: protocol forget*
[ users-and-words forget-all-methods ] [ call-next-method ] bi ; [ f forget-old-definitions ] [ call-next-method ] bi ;
: show-words ( wordlist' -- wordlist ) : show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ; [ dup second zero? [ first ] when ] map ;
@ -52,51 +97,4 @@ M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol synopsis* word-synopsis ; ! Necessary? M: protocol synopsis* word-synopsis ; ! Necessary?
GENERIC: group-words ( group -- words ) M: protocol group-words protocol-words ;
M: protocol group-words
"protocol-words" word-prop ;
M: tuple-class group-words
"slot-names" word-prop [
[ reader-word ] [ writer-word ] bi
2array [ 0 2array ] map
] map concat ;
! Consultation
: define-consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
: change-word-prop ( word prop quot -- )
>r swap word-props r> change-at ; inline
: add ( item vector/f -- vector )
2dup member? [ nip ] [ ?push ] if ;
: use-protocol ( class group -- )
"protocol-users" [ add ] change-word-prop ;
: define-consult ( group class quot -- )
swapd >r 2dup use-protocol group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
! Mimic still needs to be updated
: mimic-method ( mimicker mimicked generic -- )
tuck method
[ [ create-method-in ] [ word-def ] bi* define ]
[ 2drop ] if* ;
: define-mimic ( group mimicker mimicked -- )
[ drop swap use-protocol ] [
rot group-words -rot
[ rot first mimic-method ] 2curry each
] 3bi ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing

View File

@ -26,14 +26,11 @@ M: destructor dispose
: add-always-destructor ( obj -- ) : add-always-destructor ( obj -- )
<destructor> always-destructors get push ; <destructor> always-destructors get push ;
: dispose-each ( seq -- )
<reversed> [ dispose ] each ;
: do-always-destructors ( -- ) : do-always-destructors ( -- )
always-destructors get dispose-each ; always-destructors get <reversed> dispose-each ;
: do-error-destructors ( -- ) : do-error-destructors ( -- )
error-destructors get dispose-each ; error-destructors get <reversed> dispose-each ;
: with-destructors ( quot -- ) : with-destructors ( quot -- )
[ [

View File

@ -63,8 +63,14 @@ MEMO: eq ( -- parser )
] with-html-stream ] with-html-stream
] with-string-writer ; ] with-string-writer ;
: check-url ( href -- href' )
CHAR: : over member? [
dup { "http://" "https://" "ftp://" } [ head? ] with contains?
[ drop "/" ] unless
] when ;
: escape-link ( href text -- href-esc text-esc ) : escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ; >r check-url escape-quoted-string r> escape-string ;
: make-link ( href text -- seq ) : make-link ( href text -- seq )
escape-link escape-link

View File

@ -204,7 +204,8 @@ ARTICLE: "io" "Input and output"
{ $heading "Other features" } { $heading "Other features" }
{ $subsection "network-streams" } { $subsection "network-streams" }
{ $subsection "io.launcher" } { $subsection "io.launcher" }
{ $subsection "io.timeouts" } ; { $subsection "io.timeouts" }
{ $subsection "checksums" } ;
ARTICLE: "tools" "Developer tools" ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" } { $subsection "tools.vocabs" }

View File

@ -143,7 +143,7 @@ SYMBOL: html
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title" "ol" "li" "form" "a" "p" "html" "head" "body" "title"
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "script" "div" "span" "select" "option" "style" "input"
] [ define-closed-html-word ] each ] [ define-closed-html-word ] each
! Define some open HTML tags ! Define some open HTML tags
@ -161,6 +161,6 @@ SYMBOL: html
"id" "onclick" "style" "valign" "accesskey" "id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel" "src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
"media" "title" "media" "title" "multiple"
] [ define-attribute-word ] each ] [ define-attribute-word ] each
] with-compilation-unit ] with-compilation-unit

View File

@ -1,6 +1,6 @@
USING: http tools.test multiline tuple-syntax USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences io.streams.string kernel arrays splitting sequences
assocs io.sockets db db.sqlite ; assocs io.sockets db db.sqlite continuations ;
IN: http.tests IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@ -24,6 +24,12 @@ IN: http.tests
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test [ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test [ "/bar" ] [ "/bar" url>path ] unit-test
[ "a=b&a=c" ] [ { { "a" { "b" "c" } } } assoc>query ] unit-test
[ H{ { "a" "b" } } ] [ "a=b" query>assoc ] unit-test
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
: lf>crlf "\n" split "\r\n" join ; : lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1 STRING: read-request-test-1
@ -93,7 +99,7 @@ Host: www.sex.com
STRING: read-response-test-1 STRING: read-response-test-1
HTTP/1.1 404 not found HTTP/1.1 404 not found
Content-Type: text/html Content-Type: text/html; charset=UTF8
blah blah
; ;
@ -103,8 +109,10 @@ blah
version: "1.1" version: "1.1"
code: 404 code: 404
message: "not found" message: "not found"
header: H{ { "content-type" "text/html" } } header: H{ { "content-type" "text/html; charset=UTF8" } }
cookies: V{ } cookies: V{ }
content-type: "text/html"
content-charset: "UTF8"
} }
] [ ] [
read-response-test-1 lf>crlf read-response-test-1 lf>crlf
@ -114,7 +122,7 @@ blah
STRING: read-response-test-1' STRING: read-response-test-1'
HTTP/1.1 404 not found HTTP/1.1 404 not found
content-type: text/html content-type: text/html; charset=UTF8
; ;
@ -140,11 +148,13 @@ accessors namespaces threads ;
: add-quit-action : add-quit-action
<action> <action>
[ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display [ stop-server [ "Goodbye" write ] <html-content> ] >>display
"quit" add-responder ; "quit" add-responder ;
: test-db "test.db" temp-file sqlite-db ; : test-db "test.db" temp-file sqlite-db ;
[ test-db drop delete-file ] ignore-errors
test-db [ test-db [
init-sessions-table init-sessions-table
] with-db ] with-db
@ -191,7 +201,7 @@ test-db [
[ ] [ [ ] [
[ [
<dispatcher> <dispatcher>
<action> <protected> <action> f <protected>
<login> <login>
<sessions> <sessions>
"" add-responder "" add-responder

View File

@ -119,21 +119,41 @@ IN: http
header-value>string check-header-string write crlf header-value>string check-header-string write crlf
] assoc-each crlf ; ] assoc-each crlf ;
: add-query-param ( value key assoc -- )
[
at [
{
{ [ dup string? ] [ swap 2array ] }
{ [ dup array? ] [ swap suffix ] }
{ [ dup not ] [ drop ] }
} cond
] when*
] 2keep set-at ;
: query>assoc ( query -- assoc ) : query>assoc ( query -- assoc )
dup [ dup [
"&" split [ "&" split H{ } clone [
"=" split1 [ dup [ url-decode ] when ] bi@ [
] H{ } map>assoc >r "=" split1 [ dup [ url-decode ] when ] bi@ swap r>
add-query-param
] curry each
] keep
] when ; ] when ;
: assoc>query ( hash -- str ) : assoc>query ( hash -- str )
[ [
[ url-encode ] {
[ dup number? [ number>string ] when url-encode ] { [ dup number? ] [ number>string ] }
bi* { [ dup string? ] [ 1array ] }
"=" swap 3append { [ dup sequence? ] [ ] }
] { } assoc>map } cond
"&" join ; ] assoc-map
[
[
>r url-encode r>
[ url-encode "=" swap 3append , ] with each
] assoc-each
] { } make "&" join ;
TUPLE: cookie name value path domain expires max-age http-only ; TUPLE: cookie name value path domain expires max-age http-only ;
@ -291,6 +311,12 @@ SYMBOL: max-post-request
: extract-cookies ( request -- request ) : extract-cookies ( request -- request )
dup "cookie" header [ parse-cookies >>cookies ] when* ; dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes )
" " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ;
: read-request ( -- request ) : read-request ( -- request )
<request> <request>
read-method read-method
@ -377,6 +403,8 @@ code
message message
header header
cookies cookies
content-type
content-charset
body ; body ;
: <response> : <response>
@ -403,7 +431,10 @@ body ;
: read-response-header : read-response-header
read-header >>header read-header >>header
dup "set-cookie" header [ parse-cookies >>cookies ] when* ; extract-cookies
dup "content-type" header [
parse-content-type [ >>content-type ] [ >>content-charset ] bi*
] when* ;
: read-response ( -- response ) : read-response ( -- response )
<response> <response>
@ -422,10 +453,15 @@ body ;
: write-response-message ( response -- response ) : write-response-message ( response -- response )
dup message>> write crlf ; dup message>> write crlf ;
: unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ]
[ content-charset>> ] bi
[ "; charset=" swap 3append ] when* ;
: write-response-header ( response -- response ) : write-response-header ( response -- response )
dup header>> clone dup header>> clone
over cookies>> f like over cookies>> f like [ unparse-cookies "set-cookie" pick set-at ] when*
[ unparse-cookies "set-cookie" pick set-at ] when* over unparse-content-type "content-type" pick set-at
write-header ; write-header ;
GENERIC: write-response-body* ( body -- ) GENERIC: write-response-body* ( body -- )
@ -453,9 +489,6 @@ M: response write-full-response ( request response -- )
dup write-response dup write-response
swap method>> "HEAD" = [ write-response-body ] unless ; swap method>> "HEAD" = [ write-response-body ] unless ;
: set-content-type ( request/response content-type -- request/response )
"content-type" set-header ;
: get-cookie ( request/response name -- cookie/f ) : get-cookie ( request/response name -- cookie/f )
>r cookies>> r> '[ , _ name>> = ] find nip ; >r cookies>> r> '[ , _ name>> = ] find nip ;
@ -466,7 +499,7 @@ M: response write-full-response ( request response -- )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ; over cookies>> push ;
TUPLE: raw-response TUPLE: raw-response
version version
code code
message message

View File

@ -1,25 +1,36 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces combinators USING: kernel sequences accessors namespaces combinators words
locals db.tuples assocs locals db.tuples arrays splitting strings qualified
http.server.templating.chloe http.server.templating.chloe
http.server.boilerplate http.server.boilerplate
http.server.auth.providers http.server.auth.providers
http.server.auth.providers.db http.server.auth.providers.db
http.server.auth.login http.server.auth.login
http.server.auth
http.server.forms http.server.forms
http.server.components.inspector http.server.components.inspector
http.server.components
http.server.validators http.server.validators
http.server.sessions http.server.sessions
http.server.actions http.server.actions
http.server.crud http.server.crud
http.server ; http.server ;
EXCLUDE: http.server.components => string? number? ;
IN: http.server.auth.admin IN: http.server.auth.admin
: admin-template ( name -- template ) : admin-template ( name -- template )
"resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ; "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
: words>strings ( seq -- seq' )
[ [ word-vocabulary ] [ drop ":" ] [ word-name ] tri 3append ] map ;
: strings>words ( seq -- seq' )
[ ":" split1 swap lookup ] map ;
: <capabilities> ( id -- component )
capabilities get words>strings <menu> ;
: <new-user-form> ( -- form ) : <new-user-form> ( -- form )
"user" <form> "user" <form>
"new-user" admin-template >>edit-template "new-user" admin-template >>edit-template
@ -27,7 +38,8 @@ IN: http.server.auth.admin
"realname" <string> add-field "realname" <string> add-field
"new-password" <password> t >>required add-field "new-password" <password> t >>required add-field
"verify-password" <password> t >>required add-field "verify-password" <password> t >>required add-field
"email" <email> add-field ; "email" <email> add-field
"capabilities" <capabilities> add-field ;
: <edit-user-form> ( -- form ) : <edit-user-form> ( -- form )
"user" <form> "user" <form>
@ -38,7 +50,8 @@ IN: http.server.auth.admin
"new-password" <password> add-field "new-password" <password> add-field
"verify-password" <password> add-field "verify-password" <password> add-field
"email" <email> add-field "email" <email> add-field
"profile" <inspector> add-field ; "profile" <inspector> add-field
"capabilities" <capabilities> add-field ;
: <user-list-form> ( -- form ) : <user-list-form> ( -- form )
"user-list" <form> "user-list" <form>
@ -77,7 +90,7 @@ IN: http.server.auth.admin
"username" value <user> "username" value <user>
"realname" value >>realname "realname" value >>realname
"email" value >>email "email" value >>email
"new-password" value >>password "new-password" value >>encoded-password
H{ } clone >>profile H{ } clone >>profile
insert-tuple insert-tuple
@ -99,6 +112,7 @@ IN: http.server.auth.admin
[ realname>> "realname" set-value ] [ realname>> "realname" set-value ]
[ email>> "email" set-value ] [ email>> "email" set-value ]
[ profile>> "profile" set-value ] [ profile>> "profile" set-value ]
[ capabilities>> words>strings "capabilities" set-value ]
} cleave } cleave
] >>init ] >>init
@ -116,9 +130,14 @@ IN: http.server.auth.admin
{ "new-password" "verify-password" } { "new-password" "verify-password" }
[ value empty? ] all? [ [ value empty? ] all? [
same-password-twice same-password-twice
"new-password" value >>password "new-password" value >>encoded-password
] unless ] unless
"capabilities" value {
{ [ dup string? ] [ 1array ] }
{ [ dup array? ] [ ] }
} cond strings>words >>capabilities
update-tuple update-tuple
next f <standard-redirect> next f <standard-redirect>
@ -139,6 +158,10 @@ IN: http.server.auth.admin
TUPLE: user-admin < dispatcher ; TUPLE: user-admin < dispatcher ;
SYMBOL: can-administer-users?
can-administer-users? define-capability
:: <user-admin> ( -- responder ) :: <user-admin> ( -- responder )
[let | ctor [ [ <user> ] ] | [let | ctor [ [ <user> ] ] |
user-admin new-dispatcher user-admin new-dispatcher
@ -148,5 +171,11 @@ TUPLE: user-admin < dispatcher ;
ctor "$user-admin" <delete-user-action> "delete" add-responder ctor "$user-admin" <delete-user-action> "delete" add-responder
<boilerplate> <boilerplate>
"admin" admin-template >>template "admin" admin-template >>template
<protected> { can-administer-users? } <protected>
] ; ] ;
: make-admin ( username -- )
<user>
select-tuple
[ can-administer-users? suffix ] change-capabilities
update-tuple ;

View File

@ -2,7 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0"> <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:style include="resource:extra/http/server/auth/admin/admin.css" /> <t:style t:include="resource:extra/http/server/auth/admin/admin.css" />
<div class="navbar"> <div class="navbar">
<t:a t:href="$user-admin">List Users</t:a> <t:a t:href="$user-admin">List Users</t:a>

View File

@ -35,6 +35,11 @@
<td><t:edit t:component="email" /></td> <td><t:edit t:component="email" /></td>
</tr> </tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
<td><t:edit t:component="capabilities" /></td>
</tr>
<tr> <tr>
<th class="field-label">Profile:</th> <th class="field-label">Profile:</th>
<td><t:view t:component="profile" /></td> <td><t:view t:component="profile" /></td>

View File

@ -32,6 +32,11 @@
<th class="field-label">E-mail:</th> <th class="field-label">E-mail:</th>
<td><t:edit t:component="email" /></td> <td><t:edit t:component="email" /></td>
</tr> </tr>
<tr>
<th class="field-label big-field-label">Capabilities:</th>
<td><t:edit t:component="capabilities" /></td>
</tr>
</table> </table>

View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs namespaces kernel USING: accessors assocs namespaces kernel sequences
http.server http.server
http.server.sessions http.server.sessions
http.server.auth.providers ; http.server.auth.providers ;
@ -33,3 +33,9 @@ M: filter-responder init-user-profile
: uchange ( quot key -- ) : uchange ( quot key -- )
profile swap change-at profile swap change-at
user-changed ; inline user-changed ; inline
SYMBOL: capabilities
V{ } clone capabilities set-global
: define-capability ( word -- ) capabilities get push-new ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting USING: accessors quotations assocs kernel splitting
base64 html.elements io combinators http.server base64 html.elements io combinators http.server
http.server.auth.providers http.server.auth.providers.null http.server.auth.providers http.server.auth.login
http sequences ; http sequences ;
IN: http.server.auth.basic IN: http.server.auth.basic

View File

@ -1,16 +1,23 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors quotations assocs kernel splitting USING: accessors quotations assocs kernel splitting
base64 io combinators sequences io.files namespaces hashtables combinators sequences namespaces hashtables sets
fry io.sockets arrays threads locals qualified continuations fry arrays threads locals qualified random
io
io.sockets
io.encodings.utf8
io.encodings.string
io.binary
continuations
destructors destructors
checksums
checksums.sha2
html.elements html.elements
http http
http.server http.server
http.server.auth http.server.auth
http.server.auth.providers http.server.auth.providers
http.server.auth.providers.null http.server.auth.providers.db
http.server.actions http.server.actions
http.server.components http.server.components
http.server.flows http.server.flows
@ -25,9 +32,24 @@ QUALIFIED: smtp
SYMBOL: login-failed? SYMBOL: login-failed?
TUPLE: login < dispatcher users ; TUPLE: login < dispatcher users checksum ;
: users login get users>> ; : users ( -- provider )
login get users>> ;
: encode-password ( string salt -- bytes )
[ utf8 encode ] [ 4 >be ] bi* append
login get checksum>> checksum-bytes ;
: >>encoded-password ( user string -- user )
32 random-bits [ encode-password ] keep
[ >>password ] [ >>salt ] bi* ; inline
: valid-login? ( password user -- ? )
[ salt>> encode-password ] [ password>> ] bi = ;
: check-login ( password username -- user/f )
users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
! Destructor ! Destructor
TUPLE: user-saver user ; TUPLE: user-saver user ;
@ -72,8 +94,7 @@ M: user-saver dispose
form validate-form form validate-form
"password" value "username" value "password" value "username" value check-login [
users check-login [
successful-login successful-login
] [ ] [
login-failed? on login-failed? on
@ -125,7 +146,7 @@ SYMBOL: user-exists?
"username" value <user> "username" value <user>
"realname" value >>realname "realname" value >>realname
"new-password" value >>password "new-password" value >>encoded-password
"email" value >>email "email" value >>email
H{ } clone >>profile H{ } clone >>profile
@ -179,10 +200,10 @@ SYMBOL: user-exists?
[ value empty? ] all? [ [ value empty? ] all? [
same-password-twice same-password-twice
"password" value uid users check-login "password" value uid check-login
[ login-failed? on validation-failed ] unless [ login-failed? on validation-failed ] unless
"new-password" value >>password "new-password" value >>encoded-password
] unless ] unless
"realname" value >>realname "realname" value >>realname
@ -314,7 +335,7 @@ SYMBOL: lost-password-from
"ticket" value "ticket" value
"username" value "username" value
users claim-ticket [ users claim-ticket [
"new-password" value >>password "new-password" value >>encoded-password
users update-user users update-user
"recover-4" login-template serve-template "recover-4" login-template serve-template
@ -334,7 +355,7 @@ SYMBOL: lost-password-from
! ! ! Authentication logic ! ! ! Authentication logic
TUPLE: protected < filter-responder ; TUPLE: protected < filter-responder capabilities ;
C: <protected> protected C: <protected> protected
@ -342,11 +363,17 @@ C: <protected> protected
begin-flow begin-flow
"$login/login" f <standard-redirect> ; "$login/login" f <standard-redirect> ;
: check-capabilities ( responder user -- ? )
[ capabilities>> ] bi@ subset? ;
M: protected call-responder* ( path responder -- response ) M: protected call-responder* ( path responder -- response )
uid dup [ uid dup [
users get-user users get-user 2dup check-capabilities [
[ logged-in-user set ] [ save-user-after ] bi [ logged-in-user set ] [ save-user-after ] bi
call-next-method call-next-method
] [
3drop show-login-page
] if
] [ ] [
3drop show-login-page 3drop show-login-page
] if ; ] if ;
@ -364,12 +391,13 @@ M: login call-responder* ( path responder -- response )
swap >>default swap >>default
<login-action> <login-boilerplate> "login" add-responder <login-action> <login-boilerplate> "login" add-responder
<logout-action> <login-boilerplate> "logout" add-responder <logout-action> <login-boilerplate> "logout" add-responder
no-users >>users ; users-in-db >>users
sha-256 >>checksum ;
! ! ! Configuration ! ! ! Configuration
: allow-edit-profile ( login -- login ) : allow-edit-profile ( login -- login )
<edit-profile-action> <protected> <login-boilerplate> <edit-profile-action> f <protected> <login-boilerplate>
"edit-profile" add-responder ; "edit-profile" add-responder ;
: allow-registration ( login -- login ) : allow-registration ( login -- login )

View File

@ -1,33 +1,35 @@
IN: http.server.auth.providers.assoc.tests IN: http.server.auth.providers.assoc.tests
USING: http.server.auth.providers USING: http.server.actions http.server.auth.providers
http.server.auth.providers.assoc tools.test http.server.auth.providers.assoc http.server.auth.login
namespaces accessors kernel ; tools.test namespaces accessors kernel ;
<users-in-memory> "provider" set <action> <login>
<users-in-memory> >>users
login set
[ t ] [ [ t ] [
"slava" <user> "slava" <user>
"foobar" >>password "foobar" >>encoded-password
"slava@factorcode.org" >>email "slava@factorcode.org" >>email
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
username>> "slava" = username>> "slava" =
] unit-test ] unit-test
[ f ] [ [ f ] [
"slava" <user> "slava" <user>
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
] unit-test ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test [ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test [ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>password drop ] unit-test [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "foobar" "slava" check-login >boolean ] unit-test

View File

@ -1,10 +1,14 @@
IN: http.server.auth.providers.db.tests IN: http.server.auth.providers.db.tests
USING: http.server.auth.providers USING: http.server.actions
http.server.auth.login
http.server.auth.providers
http.server.auth.providers.db tools.test http.server.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations namespaces db db.sqlite db.tuples continuations
io.files accessors kernel ; io.files accessors kernel ;
users-in-db "provider" set <action> <login>
users-in-db >>users
login set
[ "auth-test.db" temp-file delete-file ] ignore-errors [ "auth-test.db" temp-file delete-file ] ignore-errors
@ -14,30 +18,30 @@ users-in-db "provider" set
[ t ] [ [ t ] [
"slava" <user> "slava" <user>
"foobar" >>password "foobar" >>encoded-password
"slava@factorcode.org" >>email "slava@factorcode.org" >>email
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
username>> "slava" = username>> "slava" =
] unit-test ] unit-test
[ f ] [ [ f ] [
"slava" <user> "slava" <user>
H{ } clone >>profile H{ } clone >>profile
"provider" get new-user users new-user
] unit-test ] unit-test
[ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test [ ] [ "foobar" "slava" check-login "user" set ] unit-test
[ t ] [ "user" get >boolean ] unit-test [ t ] [ "user" get >boolean ] unit-test
[ ] [ "user" get "fdasf" >>password drop ] unit-test [ ] [ "user" get "fdasf" >>encoded-password drop ] unit-test
[ ] [ "user" get "provider" get update-user ] unit-test [ ] [ "user" get users update-user ] unit-test
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test [ t ] [ "fdasf" "slava" check-login >boolean ] unit-test
[ f ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test [ f ] [ "foobar" "slava" check-login >boolean ] unit-test
] with-db ] with-db

View File

@ -9,9 +9,11 @@ user "USERS"
{ {
{ "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ } { "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
{ "realname" "REALNAME" { VARCHAR 256 } } { "realname" "REALNAME" { VARCHAR 256 } }
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ } { "password" "PASSWORD" BLOB +not-null+ }
{ "salt" "SALT" INTEGER +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } } { "email" "EMAIL" { VARCHAR 256 } }
{ "ticket" "TICKET" { VARCHAR 256 } } { "ticket" "TICKET" { VARCHAR 256 } }
{ "capabilities" "CAPABILITIES" FACTOR-BLOB }
{ "profile" "PROFILE" FACTOR-BLOB } { "profile" "PROFILE" FACTOR-BLOB }
{ "deleted" "DELETED" INTEGER +not-null+ } { "deleted" "DELETED" INTEGER +not-null+ }
} define-persistent } define-persistent

View File

@ -1,10 +1,13 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors random math.parser locals USING: kernel accessors random math.parser locals
sequences math crypto.sha2 ; sequences math ;
IN: http.server.auth.providers IN: http.server.auth.providers
TUPLE: user username realname password email ticket profile deleted changed? ; TUPLE: user
username realname
password salt
email ticket capabilities profile deleted changed? ;
: <user> ( username -- user ) : <user> ( username -- user )
user new user new
@ -17,9 +20,6 @@ GENERIC: update-user ( user provider -- )
GENERIC: new-user ( user provider -- user/f ) GENERIC: new-user ( user provider -- user/f )
: check-login ( password username provider -- user/f )
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
! Password recovery support ! Password recovery support
:: issue-ticket ( email username provider -- user/f ) :: issue-ticket ( email username provider -- user/f )

View File

@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov ! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces boxes sequences strings USING: accessors kernel namespaces boxes sequences strings
io io.streams.string arrays io io.streams.string arrays locals
html.elements html.elements
http http
http.server http.server
@ -47,7 +47,7 @@ SYMBOL: nested-template?
SYMBOL: next-template SYMBOL: next-template
: call-next-template ( -- ) : call-next-template ( -- )
next-template get write ; next-template get write-html ;
M: f call-template* drop call-next-template ; M: f call-template* drop call-next-template ;
@ -68,9 +68,10 @@ M: f call-template* drop call-next-template ;
bi* bi*
] with-scope ; inline ] with-scope ; inline
M: boilerplate call-responder* M:: boilerplate call-responder* ( path responder -- )
tuck call-next-method path responder call-next-method
dup "content-type" header "text/html" = [ dup content-type>> "text/html" = [
clone swap template>> clone [| body |
[ [ with-boilerplate ] 2curry ] curry change-body [ body responder template>> with-boilerplate ]
] [ nip ] if ; ] change-body
] when ;

View File

@ -24,7 +24,7 @@ splitting kernel hashtables continuations ;
<action> [ <action> [
[ [
"hello" print "hello" print
"text/html" <content> swap '[ , write ] >>body '[ , write ] <html-content>
] show-page ] show-page
"byebye" print "byebye" print
[ 123 ] show-final [ 123 ] show-final

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors USING: splitting kernel io sequences xmode.code2html accessors
http.server.components ; http.server.components xml.entities ;
IN: http.server.components.code IN: http.server.components.code
TUPLE: code-renderer < text-renderer mode ; TUPLE: code-renderer < text-renderer mode ;

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel io math.parser assocs classes USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors words classes.tuple arrays sequences splitting mirrors
hashtables fry combinators continuations math hashtables fry locals combinators continuations math
calendar.format html.elements calendar.format html.elements xml.entities
http.server.validators ; http.server.validators ;
IN: http.server.components IN: http.server.components
@ -18,13 +18,14 @@ TUPLE: field type ;
C: <field> field C: <field> field
M: field render-view* drop write ; M: field render-view*
drop escape-string write ;
M: field render-edit* M: field render-edit*
<input type>> =type [ =id ] [ =name ] bi =value input/> ; <input type>> =type =name =value input/> ;
: render-error ( message -- ) : render-error ( message -- )
<span "error" =class span> write </span> ; <span "error" =class span> escape-string write </span> ;
TUPLE: hidden < field ; TUPLE: hidden < field ;
@ -232,7 +233,7 @@ TUPLE: text-renderer rows cols ;
text-renderer new-text-renderer ; text-renderer new-text-renderer ;
M: text-renderer render-view* M: text-renderer render-view*
drop write ; drop escape-string write ;
M: text-renderer render-edit* M: text-renderer render-edit*
<textarea <textarea
@ -241,7 +242,7 @@ M: text-renderer render-edit*
[ =id ] [ =id ]
[ =name ] bi [ =name ] bi
textarea> textarea>
write escape-string write
</textarea> ; </textarea> ;
TUPLE: text < string ; TUPLE: text < string ;
@ -261,7 +262,7 @@ TUPLE: html-text-renderer < text-renderer ;
html-text-renderer new-text-renderer ; html-text-renderer new-text-renderer ;
M: html-text-renderer render-view* M: html-text-renderer render-view*
drop write ; drop escape-string write ;
TUPLE: html-text < text ; TUPLE: html-text < text ;
@ -286,7 +287,7 @@ GENERIC: link-href ( obj -- url )
SINGLETON: link-renderer SINGLETON: link-renderer
M: link-renderer render-view* M: link-renderer render-view*
drop <a dup link-href =href a> link-title write </a> ; drop <a dup link-href =href a> link-title escape-string write </a> ;
TUPLE: link < string ; TUPLE: link < string ;
@ -341,15 +342,19 @@ TUPLE: choice-renderer choices ;
C: <choice-renderer> choice-renderer C: <choice-renderer> choice-renderer
M: choice-renderer render-view* M: choice-renderer render-view*
drop write ; drop escape-string write ;
: render-option ( text selected? -- )
<option [ "true" =selected ] when option>
escape-string write
</option> ;
: render-options ( options selected -- )
'[ dup , member? render-option ] each ;
M: choice-renderer render-edit* M: choice-renderer render-edit*
<select swap =name select> <select swap =name select>
choices>> [ choices>> swap 1array render-options
<option [ = [ "true" =selected ] when ] keep option>
write
</option>
] with each
</select> ; </select> ;
TUPLE: choice < string ; TUPLE: choice < string ;
@ -357,3 +362,43 @@ TUPLE: choice < string ;
: <choice> ( id choices -- component ) : <choice> ( id choices -- component )
swap choice new-string swap choice new-string
swap <choice-renderer> >>renderer ; swap <choice-renderer> >>renderer ;
! Menu
TUPLE: menu-renderer choices size ;
: <menu-renderer> ( choices -- renderer )
5 menu-renderer boa ;
M:: menu-renderer render-edit* ( value id renderer -- )
<select
renderer size>> [ number>string =size ] when*
id =name
"true" =multiple
select>
renderer choices>> value render-options
</select> ;
TUPLE: menu < string ;
: <menu> ( id choices -- component )
swap menu new-string
swap <menu-renderer> >>renderer ;
! Checkboxes
TUPLE: checkbox-renderer label ;
C: <checkbox-renderer> checkbox-renderer
M: checkbox-renderer render-edit*
<input
"checkbox" =type
swap =id
swap [ "true" =selected ] when
input>
label>> escape-string write
</input> ;
TUPLE: checkbox < string ;
: <checkbox> ( id label -- component )
checkbox swap <checkbox-renderer> new-component ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences farkup accessors USING: splitting kernel io sequences farkup accessors
http.server.components ; http.server.components xml.entities ;
IN: http.server.components.farkup IN: http.server.components.farkup
TUPLE: farkup-renderer < text-renderer ; TUPLE: farkup-renderer < text-renderer ;

View File

@ -1,13 +1,13 @@
! Copyright (C) 2008 Slava Pestov ! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences inspector accessors USING: splitting kernel io sequences inspector accessors
http.server.components ; http.server.components xml.entities html ;
IN: http.server.components.inspector IN: http.server.components.inspector
SINGLETON: inspector-renderer SINGLETON: inspector-renderer
M: inspector-renderer render-view* M: inspector-renderer render-view*
drop describe ; drop [ describe ] with-html-stream ;
TUPLE: inspector < component ; TUPLE: inspector < component ;

View File

@ -0,0 +1,4 @@
IN: http.server.db.tests
USING: tools.test http.server.db ;
\ <db-persistence> must-infer

View File

@ -1,16 +1,17 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: db http.server http.server.sessions kernel accessors USING: db db.pooling http.server http.server.sessions kernel
continuations namespaces destructors ; accessors continuations namespaces destructors ;
IN: http.server.db IN: http.server.db
TUPLE: db-persistence < filter-responder db params ; TUPLE: db-persistence < filter-responder pool ;
C: <db-persistence> db-persistence : <db-persistence> ( responder db params -- responder' )
<pool> db-persistence boa ;
: connect-db ( db-persistence -- )
[ db>> ] [ params>> ] bi make-db db-open
[ db set ] [ add-always-destructor ] bi ;
M: db-persistence call-responder* M: db-persistence call-responder*
[ connect-db ] [ call-next-method ] bi ; [
pool>> [ acquire-connection ] keep
[ return-connection-later ] [ drop db set ] 2bi
]
[ call-next-method ] bi ;

View File

@ -37,9 +37,7 @@ M: form init V{ } clone >>components ;
] with-form ; ] with-form ;
: <form-response> ( form template -- response ) : <form-response> ( form template -- response )
[ components>> components set ] [ components>> components set ] [ <html-content> ] bi* ;
[ "text/html" <content> swap >>body ]
bi* ;
: view-form ( form -- response ) : view-form ( form -- response )
dup view-template>> <form-response> ; dup view-template>> <form-response> ;

View File

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar threads sequences prettyprint io.server logging calendar
html.elements accessors math.parser combinators.lib http html html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators tools.vocabs debugger continuations random combinators
destructors io.encodings.8-bit fry classes words ; destructors io.encodings.8-bit fry classes words ;
IN: http.server IN: http.server
@ -22,7 +22,10 @@ GENERIC: call-responder* ( path responder -- response )
<response> <response>
200 >>code 200 >>code
"Document follows" >>message "Document follows" >>message
swap set-content-type ; swap >>content-type ;
: <html-content> ( quot -- response )
"text/html" <content> swap >>body ;
TUPLE: trivial-responder response ; TUPLE: trivial-responder response ;
@ -38,9 +41,7 @@ M: trivial-responder call-responder* nip response>> call ;
</html> ; </html> ;
: <trivial-response> ( code message -- response ) : <trivial-response> ( code message -- response )
2dup '[ , , trivial-response-body ] 2dup '[ , , trivial-response-body ] <html-content>
"text/html" <content>
swap >>body
swap >>message swap >>message
swap >>code ; swap >>code ;

View File

@ -143,7 +143,7 @@ M: foo call-responder*
] with-destructors response set ] with-destructors response set
] unit-test ] unit-test
[ "text/plain" ] [ response get "content-type" header ] unit-test [ "text/plain" ] [ response get content-type>> ] unit-test
[ f ] [ response get cookies>> empty? ] unit-test [ f ] [ response get cookies>> empty? ] unit-test
] with-scope ] with-scope

View File

@ -1,41 +1,47 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: calendar html io io.files kernel math math.parser http USING: calendar html io io.files kernel math math.order
http.server namespaces parser sequences strings assocs math.parser http http.server namespaces parser sequences strings
hashtables debugger http.mime sorting html.elements logging assocs hashtables debugger http.mime sorting html.elements
calendar.format accessors io.encodings.binary fry ; logging calendar.format accessors io.encodings.binary fry ;
IN: http.server.static IN: http.server.static
! special maps mime types to quots with effect ( path -- ) ! special maps mime types to quots with effect ( path -- )
TUPLE: file-responder root hook special ; TUPLE: file-responder root hook special allow-listings ;
: file-http-date ( filename -- string ) : modified-since? ( filename -- ? )
file-info modified>> timestamp>http-string ; request get "if-modified-since" header dup [
[ file-info modified>> ] [ rfc822>timestamp ] bi* after?
: last-modified-matches? ( filename -- ? ) ] [
file-http-date dup [ 2drop t
request get "if-modified-since" header = ] if ;
] when ;
: <304> ( -- response ) : <304> ( -- response )
304 "Not modified" <trivial-response> ; 304 "Not modified" <trivial-response> ;
: <403> ( -- response )
403 "Forbidden" <trivial-response> ;
: <file-responder> ( root hook -- responder ) : <file-responder> ( root hook -- responder )
H{ } clone file-responder boa ; file-responder new
swap >>hook
swap >>root
H{ } clone >>special ;
: <static> ( root -- responder ) : <static> ( root -- responder )
[ [
<content> <content>
swap swap [
[ file-info size>> "content-length" set-header ] file-info
[ file-http-date "last-modified" set-header ] [ size>> "content-length" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ] [ modified>> "last-modified" set-header ] bi
tri ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ] bi
] <file-responder> ; ] <file-responder> ;
: serve-static ( filename mime-type -- response ) : serve-static ( filename mime-type -- response )
over last-modified-matches? over modified-since?
[ 2drop <304> ] [ file-responder get hook>> call ] if ; [ file-responder get hook>> call ] [ 2drop <304> ] if ;
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
file-responder get root>> right-trim-separators file-responder get root>> right-trim-separators
@ -65,8 +71,11 @@ TUPLE: file-responder root hook special ;
] simple-html-document ; ] simple-html-document ;
: list-directory ( directory -- response ) : list-directory ( directory -- response )
"text/html" <content> file-responder get allow-listings>> [
swap '[ , directory. ] >>body ; '[ , directory. ] <html-content>
] [
drop <403>
] if ;
: find-index ( filename -- path ) : find-index ( filename -- path )
"index.html" append-path dup exists? [ drop f ] unless ; "index.html" append-path dup exists? [ drop f ] unless ;

View File

@ -24,5 +24,4 @@ M: template write-response-body* call-template ;
! responder integration ! responder integration
: serve-template ( template -- response ) : serve-template ( template -- response )
"text/html" <content> '[ , call-template ] <html-content> ;
swap '[ , call-template ] >>body ;

View File

@ -0,0 +1 @@
Daniel Ehrenberg

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,12 @@
USING: help.syntax help.markup ;
IN: io.encodings.iana
HELP: name>encoding
{ $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } }
{ "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ;
HELP: encoding>name
{ $values { "encoding" "an encoding descriptor" } { "name" "an encoding name" } }
{ "Given an encoding descriptor, return the preferred IANA name." } ;
{ name>encoding encoding>name } related-words

View File

@ -0,0 +1,5 @@
USING: io.encodings.iana io.encodings.ascii tools.test ;
[ ascii ] [ "US-ASCII" name>encoding ] unit-test
[ ascii ] [ "ASCII" name>encoding ] unit-test
[ "US-ASCII" ] [ ascii encoding>name ] unit-test

View File

@ -0,0 +1,55 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings unicode.syntax.backend io.files assocs
splitting sequences io namespaces sets
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ;
IN: io.encodings.iana
<PRIVATE
VALUE: n>e-table
: e>n-table H{
{ ascii "US-ASCII" }
{ utf8 "UTF-8" }
{ utf16 "UTF-16" }
{ utf16be "UTF-16BE" }
{ utf16le "UTF-16LE" }
{ latin1 "ISO-8859-1" }
{ latin2 "ISO-8859-2" }
{ latin3 "ISO-8859-3" }
{ latin4 "ISO-8859-4" }
{ latin/cyrillic "ISO-8859-5" }
{ latin/arabic "ISO-8859-6" }
{ latin/greek "ISO-8859-7" }
{ latin/hebrew "ISO-8859-8" }
{ latin5 "ISO-8859-9" }
{ latin6 "ISO-8859-10" }
} ;
PRIVATE>
: name>encoding ( name -- encoding )
n>e-table at ;
: encoding>name ( encoding -- name )
e>n-table at ;
<PRIVATE
: parse-iana ( stream -- synonym-set )
lines { "" } split [
[ " " split ] map
[ first { "Name:" "Alias:" } member? ] filter
[ second ] map { "None" } diff
] map ;
: make-n>e ( stream -- n>e )
parse-iana [ [
dup [
e>n-table value-at
[ swap [ set ] with each ]
[ drop ] if*
] with each
] each ] H{ } make-assoc ;
PRIVATE>
"resource:extra/io/encodings/iana/character-sets"
ascii <file-reader> make-n>e \ n>e-table set-value

View File

@ -0,0 +1 @@
Tables for IANA encoding names

View File

@ -47,7 +47,7 @@ PRIVATE>
] with-variable ; inline ] with-variable ; inline
: stop-server ( -- ) : stop-server ( -- )
servers get [ dispose ] each ; servers get dispose-each ;
<PRIVATE <PRIVATE

View File

@ -230,3 +230,10 @@ DEFER: xyzzy
[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
GENERIC: next-method-test ( a -- b )
M: integer next-method-test 3 + ;
M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
[ 5 ] [ 1 next-method-test ] unit-test

View File

@ -279,7 +279,9 @@ M: wlet local-rewrite*
: (::) CREATE-WORD parse-locals-definition ; : (::) CREATE-WORD parse-locals-definition ;
: (M::) CREATE-METHOD parse-locals-definition ; : (M::)
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
PRIVATE> PRIVATE>

Some files were not shown because too many files have changed in this diff Show More