From 42dfe4ce44f5c797c313728d207fb3ce4401b5fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 Jan 2009 19:07:44 -0600 Subject: [PATCH 1/3] Add $or element to help, update help docs a bit --- basis/help/handbook/handbook.factor | 3 ++- basis/help/help-docs.factor | 9 ++++++++- basis/help/markup/markup.factor | 28 +++++++++++++++++----------- 3 files changed, 27 insertions(+), 13 deletions(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index c67a378796..39b5a13e30 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -162,7 +162,8 @@ ARTICLE: "encodings-introduction" "An introduction to encodings" { $code "\"file.txt\" utf16 file-contents" } "Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text." $nl -"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ; +"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." +{ $see-also "stream-elements" } ; ARTICLE: "io" "Input and output" { $heading "Streams" } diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index a699747048..6b77f656c0 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -36,6 +36,7 @@ ARTICLE: "block-elements" "Block elements" "Elements used in " { $link $values } " forms:" { $subsection $instance } { $subsection $maybe } +{ $subsection $or } { $subsection $quotation } "Boilerplate paragraphs:" { $subsection $low-level-note } @@ -88,6 +89,12 @@ $nl { "an array of markup elements," } { "or an array of the form " { $snippet "{ $directive content... }" } ", where " { $snippet "$directive" } " is a markup word whose name starts with " { $snippet "$" } ", and " { $snippet "content..." } " is a series of markup elements" } } +"Here is a more formal schema for the help markup language:" +{ $code +" ::== | | " +" ::== { * }" +" ::== { }" +} { $subsection "element-types" } { $subsection "printing-elements" } "Related words can be cross-referenced:" @@ -119,7 +126,7 @@ ARTICLE: "help" "Help system" "The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words." { $subsection "browsing-help" } { $subsection "writing-help" } -{ $vocab-subsection "Help lint tool" "help.lint" } +{ $subsection "help.lint" } { $subsection "help-impl" } ; IN: help diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index bf933cd9f1..68dd66349e 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -1,19 +1,12 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots -vocabs help.stylesheet help.topics vocabs.loader quotations ; +vocabs help.stylesheet help.topics vocabs.loader quotations +combinators ; IN: help.markup -! Simple markup language. - -! ::== | | -! ::== { * } -! ::== { } - -! Element types are words whose name begins with $. - PREDICATE: simple-element < array [ t ] [ first word? not ] if-empty ; @@ -250,8 +243,21 @@ M: f ($instance) : $instance ( element -- ) first ($instance) ; +: $or ( element -- ) + dup length { + { 1 [ first ($instance) ] } + { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi ] } + [ + drop + unclip-last + [ [ ($instance) ", " print-element ] each ] + [ "or " print-element ($instance) ] + bi* + ] + } case ; + : $maybe ( element -- ) - $instance " or " print-element { f } $instance ; + f suffix $or ; : $quotation ( element -- ) { "a " { $link quotation } " with stack effect " } print-element From c7c37f5f5c812cb90d214a8946db880189b14962 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 Jan 2009 19:08:20 -0600 Subject: [PATCH 2/3] Update I/O docs to talk about elements instead of characters, and add each-block combinator which generalizes contents just like each-line generalizes lines --- basis/io/directories/directories-docs.factor | 3 +- core/io/encodings/encodings-docs.factor | 13 ++- core/io/io-docs.factor | 105 +++++++++++-------- core/io/io.factor | 61 ++++++----- 4 files changed, 108 insertions(+), 74 deletions(-) diff --git a/basis/io/directories/directories-docs.factor b/basis/io/directories/directories-docs.factor index 427472db0f..1b4028c813 100644 --- a/basis/io/directories/directories-docs.factor +++ b/basis/io/directories/directories-docs.factor @@ -166,6 +166,7 @@ ARTICLE: "io.directories" "Directory manipulation" { $subsection "current-directory" } { $subsection "io.directories.listing" } { $subsection "io.directories.create" } -{ $subsection "delete-move-copy" } ; +{ $subsection "delete-move-copy" } +{ $subsection "io.directories.hierarchy" } ; ABOUT: "io.directories" diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor index b893e7f717..ed39e74878 100644 --- a/core/io/encodings/encodings-docs.factor +++ b/core/io/encodings/encodings-docs.factor @@ -74,7 +74,7 @@ HELP: replacement-char { $description "A code point that replaces input that could not be decoded. The presence of this character in the decoded data usually signifies an error." } ; ARTICLE: "encodings-descriptors" "Encoding descriptors" -"An encoding descriptor is something which can be used for input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" +"An encoding descriptor is something which can be used with binary input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" { $subsection "io.encodings.binary" } { $subsection "io.encodings.utf8" } { $subsection "io.encodings.utf16" } @@ -99,7 +99,13 @@ ARTICLE: "encodings-constructors" "Manually constructing an encoded stream" { $subsection } ; ARTICLE: "io.encodings" "I/O encodings" -"The " { $vocab-link "io.encodings" } " vocabulary provides utilities for encoding and decoding bytes that represent text. Both strings and streams may be encoded." +"The " { $vocab-link "io.encodings" } " vocabulary provides utilities for encoding and decoding bytes that represent text. Encodings can be used in the following situations:" +{ $list + "With binary input streams, to convert bytes to characters" + "With binary output streams, to convert characters to bytes" + "With byte arrays, to convert bytes to characters" + "With strings, to convert characters to bytes" +} { $subsection "encodings-descriptors" } { $subsection "encodings-constructors" } { $subsection "io.encodings.string" } @@ -113,6 +119,7 @@ ARTICLE: "io.encodings" "I/O encodings" { $subsection re-decode } "Combinators to change the encoding:" { $subsection with-encoded-output } -{ $subsection with-decoded-input } ; +{ $subsection with-decoded-input } +{ $see-also "encodings-introduction" "stream-elements" } ; ABOUT: "io.encodings" diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index a77031fdd0..d7534ddb50 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax quotations hashtables kernel -classes strings continuations destructors math ; +classes strings continuations destructors math byte-arrays ; IN: io HELP: stream-readln @@ -9,38 +9,38 @@ HELP: stream-readln $io-error ; HELP: stream-read1 -{ $values { "stream" "an input stream" } { "ch/f" "a character or " { $link f } } } -{ $contract "Reads a character of input from the stream. Outputs " { $link f } " on stream exhaustion." } +{ $values { "stream" "an input stream" } { "elt" "an element or " { $link f } } } +{ $contract "Reads an element from the stream. Outputs " { $link f } " on stream exhaustion." } { $notes "Most code only works on one stream at a time and should instead use " { $link read1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read -{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } } -{ $contract "Reads " { $snippet "n" } " characters of input from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $values { "n" "a non-negative integer" } { "stream" "an input stream" } { "seq" { $or byte-array string f } } } +{ $contract "Reads " { $snippet "n" } " elements from the stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } { $notes "Most code only works on one stream at a time and should instead use " { $link read } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-until -{ $values { "seps" string } { "stream" "an input stream" } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } -{ $contract "Reads characters from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } +{ $values { "seps" string } { "stream" "an input stream" } { "seq" { $or byte-array string f } } { "sep/f" "a character or " { $link f } } } +{ $contract "Reads elements from the stream, until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } { $notes "Most code only works on one stream at a time and should instead use " { $link read-until } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-read-partial { $values - { "n" integer } { "stream" "an input stream" } - { "str/f" "a string or " { $link f } } } -{ $description "Reads at most " { $snippet "n" } " characters from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; + { "n" "a non-negative integer" } { "stream" "an input stream" } + { "seq" { $or byte-array string f } } } +{ $description "Reads at most " { $snippet "n" } " elements from a stream and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; HELP: stream-write1 -{ $values { "ch" "a character" } { "stream" "an output stream" } } -{ $contract "Writes a character of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $values { "elt" "an element" } { "stream" "an output stream" } } +{ $contract "Writes an element to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } { $notes "Most code only works on one stream at a time and should instead use " { $link write1 } "; see " { $link "stdio" } "." } $io-error ; HELP: stream-write -{ $values { "str" string } { "stream" "an output stream" } } -{ $contract "Writes a string of output to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } +{ $values { "seq" "a byte array or string" } { "stream" "an output stream" } } +{ $contract "Writes a sequence of elements to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output." } { $notes "Most code only works on one stream at a time and should instead use " { $link write } "; see " { $link "stdio" } "." } $io-error ; @@ -57,7 +57,6 @@ HELP: stream-nl { $notes "Most code only works on one stream at a time and should instead use " { $link nl } "; see " { $link "stdio" } "." } $io-error ; - HELP: stream-print { $values { "str" string } { "stream" "an output stream" } } { $description "Writes a newline-terminated string." } @@ -84,34 +83,32 @@ HELP: readln $io-error ; HELP: read1 -{ $values { "ch/f" "a character or " { $link f } } } -{ $description "Reads a character of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." } +{ $values { "elt" "an element or " { $link f } } } +{ $description "Reads an element from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." } $io-error ; HELP: read -{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } } -{ $description "Reads " { $snippet "n" } " characters of input from " { $link input-stream } ". Outputs a truncated string or " { $link f } " on stream exhaustion." } +{ $values { "n" "a non-negative integer" } { "seq" { $or byte-array string f } } } +{ $description "Reads " { $snippet "n" } " elements from " { $link input-stream } ". If there is no input available, outputs " { $link f } ". If there are less than " { $snippet "n" } " elements available, outputs a sequence shorter than " { $snippet "n" } " in length." } $io-error ; HELP: read-until -{ $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } -{ $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } +{ $values { "seps" string } { "seq" { $or byte-array string f } } { "sep/f" "a character or " { $link f } } } +{ $contract "Reads elements from " { $link input-stream } ". until the first occurrence of a separator, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output. In the latter case, the entire stream contents are output, along with " { $link f } "." } $io-error ; HELP: read-partial -{ $values - { "n" null } - { "str/f" null } } -{ $description "Reads at most " { $snippet "n" } " characters from " { $link input-stream } " and returns up to that many characters without blocking. If no characters are available, blocks until some are and returns them." } ; +{ $values { "n" integer } { "seq" { $or byte-array string f } } } +{ $description "Reads at most " { $snippet "n" } " elements from " { $link input-stream } " and returns them in a sequence. This word should be used instead of " { $link read } " when processing the entire element a chunk at a time, since on some stream implementations it may be slightly faster." } ; HELP: write1 -{ $values { "ch" "a character" } } -{ $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $values { "elt" "an element" } } +{ $contract "Writes an element to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: write -{ $values { "str" string } } -{ $description "Writes a string of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } +{ $values { "seq" { $or byte-array string f } } } +{ $description "Writes a sequence of elements to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } $io-error ; HELP: flush @@ -123,7 +120,7 @@ HELP: nl $io-error ; HELP: print -{ $values { "string" string } } +{ $values { "str" string } } { $description "Writes a newline-terminated string to " { $link output-stream } "." } $io-error ; @@ -170,9 +167,13 @@ HELP: each-line { $values { "quot" { $quotation "( str -- )" } } } { $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ; +HELP: each-block +{ $values { "quot" { $quotation "( block -- )" } } } +{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; + HELP: contents -{ $values { "stream" "an input stream" } { "str" string } } -{ $description "Reads the entire contents of a stream into a string." } +{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } +{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" @@ -182,20 +183,23 @@ $nl $nl "All streams must implement the " { $link dispose } " word in addition to the stream protocol." $nl -"These words are required for input streams:" +"These words are required for binary and string input streams:" { $subsection stream-read1 } { $subsection stream-read } { $subsection stream-read-until } -{ $subsection stream-readln } { $subsection stream-read-partial } -"These words are required for output streams:" +"This word is only required for string input streams:" +{ $subsection stream-readln } +"These words are required for binary and string output streams:" { $subsection stream-flush } { $subsection stream-write1 } { $subsection stream-write } +"This word is only required for string output streams:" { $subsection stream-nl } +"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "." { $see-also "io.timeouts" } ; -ARTICLE: "stdio" "Default input and output streams" +ARTICLE: "stdio-motivation" "Motivation for default streams" "Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:" { $list { "Code becomes simpler because there is no need to keep a stream around on the stack." } @@ -230,7 +234,10 @@ ARTICLE: "stdio" "Default input and output streams" "\"data.txt\" utf8 [" " readln number>string read 16 group" "] with-file-reader" -} +} ; + +ARTICLE: "stdio" "Default input and output streams" +{ $subsection "stdio-motivation" } "The default input stream is stored in a dynamically-scoped variable:" { $subsection input-stream } "Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user." @@ -239,8 +246,9 @@ $nl { $subsection read1 } { $subsection read } { $subsection read-until } -{ $subsection readln } { $subsection read-partial } +"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:" +{ $subsection readln } "A pair of combinators for rebinding the " { $link input-stream } " variable:" { $subsection with-input-stream } { $subsection with-input-stream* } @@ -252,6 +260,8 @@ $nl { $subsection flush } { $subsection write1 } { $subsection write } +"If the default output stream is a string stream (" { $link "stream-elements" } "), lines of text can be written:" +{ $subsection readln } { $subsection print } { $subsection nl } { $subsection bl } @@ -268,17 +278,26 @@ $nl "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" { $subsection stream-print } "Processing lines one by one:" -{ $subsection each-line } -"Sluring an entire stream into memory all at once:" { $subsection lines } +{ $subsection each-line } +"Processing blocks of data:" { $subsection contents } +{ $subsection each-block } "Copying the contents of one stream to another:" { $subsection stream-copy } ; +ARTICLE: "stream-elements" "Stream elements" +"There are two types of streams:" +{ $list + { { $strong "Binary streams" } " - the elements are integers between 0 and 255, inclusive; they represent bytes. Reading a sequence of elements produces a " { $link byte-array } "." } + { { $strong "String streams" } " - the elements are non-negative integers, representing Unicode code points. Reading a sequence of elements produces a " { $link string } "." } +} +"Most external streams are binary streams, and can be wrapped in string streams once a suitable encoding has been provided; see " { $link "io.encodings" } "." ; + ARTICLE: "streams" "Streams" -"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of characters. Streams also support formatted output, which may be used to present styled text in a manner independent of output medium." -$nl -"A stream can either be passed around on the stack or bound to a dynamic variable and used as an implicit " { $emphasis "default stream" } "." +"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of elements." +{ $subsection "stream-elements" } +"A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "." { $subsection "stream-protocol" } { $subsection "stdio" } { $subsection "stream-utils" } diff --git a/core/io/io.factor b/core/io/io.factor index a2f6fbb58d..55cc336ef8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,26 +4,18 @@ USING: hashtables generic kernel math namespaces make sequences continuations destructors assocs ; IN: io +GENERIC: stream-read1 ( stream -- elt ) +GENERIC: stream-read ( n stream -- seq ) +GENERIC: stream-read-until ( seps stream -- seq sep/f ) +GENERIC: stream-read-partial ( n stream -- seq ) GENERIC: stream-readln ( stream -- str/f ) -GENERIC: stream-read1 ( stream -- ch/f ) -GENERIC: stream-read ( n stream -- str/f ) -GENERIC: stream-read-until ( seps stream -- str/f sep/f ) -GENERIC: stream-read-partial ( n stream -- str/f ) -GENERIC: stream-write1 ( ch stream -- ) -GENERIC: stream-write ( str stream -- ) + +GENERIC: stream-write1 ( elt stream -- ) +GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) -: stream-print ( str stream -- ) - [ stream-write ] keep stream-nl ; - -: (stream-copy) ( in out -- ) - 64 1024 * pick stream-read-partial - [ over stream-write (stream-copy) ] [ 2drop ] if* ; - -: stream-copy ( in out -- ) - [ 2dup (stream-copy) ] [ dispose dispose ] [ ] - cleanup ; +: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; ! Default streams SYMBOL: input-stream @@ -31,13 +23,13 @@ SYMBOL: output-stream SYMBOL: error-stream : readln ( -- str/f ) input-stream get stream-readln ; -: read1 ( -- ch/f ) input-stream get stream-read1 ; -: read ( n -- str/f ) input-stream get stream-read ; -: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ; -: read-partial ( n -- str/f ) input-stream get stream-read-partial ; +: read1 ( -- elt ) input-stream get stream-read1 ; +: read ( n -- seq ) input-stream get stream-read ; +: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; +: read-partial ( n -- seq ) input-stream get stream-read-partial ; -: write1 ( ch -- ) output-stream get stream-write1 ; -: write ( str -- ) output-stream get stream-write ; +: write1 ( elt -- ) output-stream get stream-write1 ; +: write ( seq -- ) output-stream get stream-write ; : flush ( -- ) output-stream get stream-flush ; : nl ( -- ) output-stream get stream-nl ; @@ -62,17 +54,32 @@ SYMBOL: error-stream [ [ drop dispose dispose ] 3curry ] 3bi [ ] cleanup ; inline -: print ( string -- ) output-stream get stream-print ; +: print ( str -- ) output-stream get stream-print ; : bl ( -- ) " " write ; : lines ( stream -- seq ) [ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ; -: each-line ( quot -- ) - [ [ readln dup ] ] dip [ drop ] while ; inline + + +: each-line ( quot -- ) + [ readln ] each-morsel ; inline + +: contents ( stream -- seq ) [ - [ 65536 read dup ] [ ] [ drop ] produce concat f like + [ 65536 read-partial dup ] + [ ] [ drop ] produce concat f like ] with-input-stream ; + +: each-block ( quot: ( block -- ) -- ) + [ 8192 read-partial ] each-morsel ; inline + +: stream-copy ( in out -- ) + [ [ [ write ] each-block ] with-output-stream ] + curry with-input-stream ; \ No newline at end of file From f1607711236f8e60a0cbbdcfdce4b5ae3aee09a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 22 Jan 2009 19:08:38 -0600 Subject: [PATCH 3/3] Fix POST with streams to use chunked encoding, add http-put word --- basis/http/client/client.factor | 80 +++++++++++++++++++++----------- basis/http/http-tests.factor | 2 +- basis/http/server/cgi/cgi.factor | 2 +- basis/http/server/server.factor | 2 - 4 files changed, 54 insertions(+), 32 deletions(-) diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index f8106f4c83..cce9f07967 100644 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math math.parser namespaces make sequences strings splitting calendar continuations accessors vectors @@ -10,6 +10,12 @@ io.streams.duplex fry ascii urls urls.encoding present http http.parsers ; IN: http.client +ERROR: too-many-redirects ; + +CONSTANT: max-redirects 10 + +> write bl ] @@ -21,17 +27,29 @@ IN: http.client [ host>> ] [ port>> ] bi dup "http" protocol-port = [ drop ] [ ":" swap number>string 3append ] if ; +: set-post-data-headers ( header post-data -- header ) + [ + data>> dup sequence? + [ length "content-length" ] + [ drop "chunked" "transfer-encoding" ] if + pick set-at + ] [ content-type>> "content-type" pick set-at ] bi ; + +: set-host-header ( request header -- request header ) + over url>> url-host "host" pick set-at ; + +: set-cookie-header ( header cookies -- header ) + unparse-cookie "cookie" pick set-at ; + : write-request-header ( request -- request ) dup header>> >hashtable - over url>> host>> [ over url>> url-host "host" pick set-at ] when - over post-data>> [ - [ data>> length "content-length" pick set-at ] - [ content-type>> "content-type" pick set-at ] - bi - ] when* - over cookies>> [ unparse-cookie "cookie" pick set-at ] unless-empty + over url>> host>> [ set-host-header ] when + over post-data>> [ set-post-data-headers ] when* + over cookies>> [ set-cookie-header ] unless-empty write-header ; +PRIVATE> + GENERIC: >post-data ( object -- post-data ) M: f >post-data ; @@ -51,6 +69,8 @@ M: object >post-data "application/octet-stream" swap >>data ; +> [ dup params>> [ @@ -62,11 +82,18 @@ M: object >post-data [ >post-data ] change-post-data normalize-post-data ; +: write-chunk ( chunk -- ) + [ length >hex ";\r\n" append ascii encode write ] [ write ] bi ; + +: write-chunked ( stream -- ) + [ [ write-chunk ] each-block ] with-input-stream + "0;\r\n" ascii encode write ; + : write-post-data ( request -- request ) dup method>> { "POST" "PUT" } member? [ dup post-data>> data>> dup sequence? - [ write ] [ output-stream get stream-copy ] if - ] when ; + [ write ] [ write-chunked ] if + ] when ; : write-request ( request -- ) unparse-post-data @@ -95,12 +122,6 @@ M: object >post-data read-response-line read-response-header ; -: max-redirects 10 ; - -ERROR: too-many-redirects ; - - ( -- stream ) request get url>> url-addr ascii drop @@ -166,6 +182,11 @@ SYMBOL: redirects [ do-redirect ] [ nip ] if ] with-variable ; inline recursive +: ( url method -- request ) + + swap >>method + swap >url ensure-port >>url ; inline + PRIVATE> : success? ( code -- ? ) 200 299 between? ; @@ -183,9 +204,7 @@ ERROR: download-failed response ; over content-charset>> decode ; : ( url -- request ) - - "GET" >>method - swap >url ensure-port >>url ; + "GET" ; : http-get ( url -- response data ) http-request ; @@ -203,14 +222,19 @@ ERROR: download-failed response ; dup download-name download-to ; : ( post-data url -- request ) - - "POST" >>method - swap >url ensure-port >>url + "POST" swap >>post-data ; : http-post ( post-data url -- response data ) http-request ; +: ( post-data url -- request ) + "PUT" + swap >>post-data ; + +: http-put ( post-data url -- response data ) + http-request ; + USING: vocabs vocabs.loader ; "debugger" vocab [ "http.client.debugger" require ] when diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 6fa23b4b1f..6b0bdbe2c0 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -1,4 +1,4 @@ -USING: http http.server http.client tools.test multiline +USING: http http.server http.client http.client.private tools.test multiline io.streams.string io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.encodings.string kernel arrays splitting sequences assocs io.sockets db db.sqlite continuations urls diff --git a/basis/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor index 959642b706..a64fe9af3c 100644 --- a/basis/http/server/cgi/cgi.factor +++ b/basis/http/server/cgi/cgi.factor @@ -55,7 +55,7 @@ IN: http.server.cgi binary encode-output _ output-stream get swap binary [ post-request? [ request get post-data>> data>> write flush ] when - input-stream get swap (stream-copy) + '[ _ write ] each-block ] with-stream ] >>body ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c328e1d6a3..73a6b208d8 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -26,8 +26,6 @@ html.elements html.streams ; IN: http.server -\ parse-cookie DEBUG add-input-logging - : check-absolute ( url -- url ) dup path>> "/" head? [ "Bad request: URL" throw ] unless ; inline