diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index a5c82cee93..c67a378796 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -181,7 +181,6 @@ ARTICLE: "io" "Input and output" { $subsection "io.streams.plain" } { $subsection "io.streams.string" } { $subsection "io.streams.byte-array" } -{ $subsection "io.streams.limited" } { $heading "Utilities" } { $subsection "stream-binary" } { $subsection "io.styles" } diff --git a/basis/http/http.factor b/basis/http/http.factor old mode 100644 new mode 100755 index 4702f88830..b29f5222db --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -213,12 +213,14 @@ body ; raw-response new "1.1" >>version ; -TUPLE: post-data raw content content-type ; +TUPLE: post-data raw content content-type form-variables uploaded-files ; -: ( raw content-type -- post-data ) +: ( form-variables uploaded-files raw content-type -- post-data ) post-data new swap >>content-type - swap >>raw ; + swap >>raw + swap >>uploaded-files + swap >>form-variables ; : parse-content-type-attributes ( string -- attributes ) " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor old mode 100644 new mode 100755 index 697dec24ce..1c516e9051 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -15,6 +15,8 @@ io.streams.limited io.servers.connection io.timeouts fry logging logging.insomniac calendar urls urls.encoding +mime.multipart +unicode.categories http http.parsers http.server.responses @@ -36,17 +38,35 @@ IN: http.server : read-request-header ( request -- request ) read-header >>header ; -: parse-post-data ( post-data -- post-data ) - [ ] [ raw>> ] [ content-type>> ] tri - "application/x-www-form-urlencoded" = [ query>assoc ] when - >>content ; +ERROR: no-boundary ; + +: parse-multipart-form-data ( string -- separator ) + ";" split1 nip + "=" split1 nip [ no-boundary ] unless* ; + +: read-multipart-data ( request -- form-variables uploaded-files ) + [ "content-type" header ] + [ "content-length" header string>number ] bi + unlimit-input + stream-eofs limit-input + binary decode-input + parse-multipart-form-data parse-multipart ; + +: read-content ( request -- bytes ) + "content-length" header string>number read ; + +: parse-content ( request content-type -- form-variables uploaded-files raw ) + { + { "multipart/form-data" [ read-multipart-data f ] } + { "application/x-www-form-urlencoded" [ read-content [ f f ] dip ] } + [ drop read-content [ f f ] dip ] + } case ; : read-post-data ( request -- request ) dup method>> "POST" = [ - [ ] - [ "content-length" header string>number read ] - [ "content-type" header ] tri - parse-post-data >>post-data + dup dup "content-type" header + [ ";" split1 drop parse-content ] keep + >>post-data ] when ; : extract-host ( request -- request ) @@ -80,7 +100,7 @@ GENERIC: write-full-response ( request response -- ) [ content-type>> "application/octet-stream" or ] [ content-charset>> encoding>name ] bi - [ "; charset=" swap 3append ] when* ; + [ "; charset=" glue ] when* ; : ensure-domain ( cookie -- cookie ) [ @@ -236,7 +256,7 @@ TUPLE: http-server < threaded-server ; M: http-server handle-client* drop [ - 64 1024 * limit-input + 64 1024 * stream-throws limit-input ?refresh-all [ read-request ] ?benchmark [ do-request ] ?benchmark diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index af65d5b9b6..90f7860672 100755 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -5,16 +5,23 @@ IN: io.streams.limited HELP: { $values - { "stream" "an input stream" } { "limit" integer } + { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" } { "stream'" "an input stream" } } -{ $description "Constructs a new " { $link limited-stream } " from an existing stream. Upon exhaustion, the stream will throw an error by default." } +{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ; + +HELP: limit +{ $values + { "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" } + { "stream'" "a stream" } +} +{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." } { $examples "Throwing an exception:" { $example "USING: continuations io io.streams.limited io.streams.string" "kernel prettyprint ;" "[" - " \"123456\" 3 " + " \"123456\" 3 stream-throws limit" " 100 swap stream-read ." "] [ ] recover ." "T{ limit-exceeded }" @@ -23,32 +30,34 @@ HELP: { $example "USING: accessors continuations io io.streams.limited" "io.streams.string kernel prettyprint ;" - "\"123456\" 3 " - "stream-eofs >>mode" + "\"123456\" 3 stream-eofs limit" "100 swap stream-read ." "\"123\"" } } ; -HELP: limit +HELP: unlimit { $values - { "stream" "a stream" } { "limit" integer } + { "stream" "an input stream" } { "stream'" "a stream" } } -{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." } ; +{ $description "Returns the underlying stream of a limited stream." } ; HELP: limited-stream { $values { "value" "a limited-stream class" } } -{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion. The default behavior is to throw an exception." } ; +{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ; HELP: limit-input { $values - { "limit" integer } + { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" } } { $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ; +HELP: unlimit-input +{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ; + HELP: stream-eofs { $values { "value" "a " { $link limited-stream } " mode singleton" } @@ -64,13 +73,15 @@ HELP: stream-throws { stream-eofs stream-throws } related-words ARTICLE: "io.streams.limited" "Limited input streams" -"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. The default behavior is to throw an error." $nl -"Wrap an existing stream in a limited stream:" -{ $subsection } +"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end." $nl "Wrap a stream in a limited stream:" { $subsection limit } "Wrap the current " { $link input-stream } " in a limited stream:" { $subsection limit-input } +"Unlimits a limited stream:" +{ $subsection unlimit } +"Unlimits the current " { $link input-stream } ":" +{ $subsection limit-input } "Make a limited stream throw an exception on exhaustion:" { $subsection stream-throws } "Make a limited stream return " { $link f } " on exhaustion:" diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index 69bd6a9cd6..c88d52be81 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -8,7 +8,7 @@ IN: io.streams.limited.tests ascii encode binary "data" set ] unit-test -[ ] [ "data" get 24 "limited" set ] unit-test +[ ] [ "data" get 24 stream-throws "limited" set ] unit-test [ CHAR: h ] [ "limited" get stream-read1 ] unit-test @@ -25,7 +25,7 @@ IN: io.streams.limited.tests ascii encode binary "data" set ] unit-test -[ ] [ "data" get 7 "limited" set ] unit-test +[ ] [ "data" get 7 stream-throws "limited" set ] unit-test [ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test @@ -34,22 +34,28 @@ IN: io.streams.limited.tests [ "he" CHAR: l ] [ B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o } ascii [ - 5 limit-input + 5 stream-throws limit-input "l" read-until ] with-input-stream ] unit-test [ CHAR: a ] -[ "a" 1 stream-read1 ] unit-test +[ "a" 1 stream-eofs stream-read1 ] unit-test [ "abc" ] [ - "abc" 3 stream-eofs >>mode + "abc" 3 stream-eofs 4 swap stream-read ] unit-test [ f ] [ - "abc" 3 stream-eofs >>mode + "abc" 3 stream-eofs 4 over stream-read drop 10 swap stream-read ] unit-test + +[ t ] +[ + "abc" 3 stream-eofs limit unlimit + "abc" = +] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index f97c46182a..71c6eb67d4 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -9,20 +9,27 @@ TUPLE: limited-stream stream count limit mode ; SINGLETONS: stream-throws stream-eofs ; -: ( stream limit -- stream' ) +: ( stream limit mode -- stream' ) limited-stream new + swap >>mode swap >>limit swap >>stream - 0 >>count - stream-throws >>mode ; + 0 >>count ; -GENERIC# limit 1 ( stream limit -- stream' ) +GENERIC# limit 2 ( stream limit mode -- stream' ) -M: decoder limit [ clone ] dip [ limit ] curry change-stream ; +M: decoder limit ( stream limit mode -- stream' ) + [ clone ] 2dip '[ _ _ limit ] change-stream ; -M: object limit ; +M: object limit ( stream limit mode -- stream' ) + ; -: limit-input ( limit -- ) input-stream [ swap limit ] change ; +: unlimit ( stream -- stream' ) + [ stream>> ] change-stream ; + +: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ; + +: unlimit-input ( -- ) input-stream [ unlimit ] change ; ERROR: limit-exceeded ; diff --git a/basis/mime/multipart/multipart-tests.factor b/basis/mime/multipart/multipart-tests.factor index 5d5f1b813a..e1bf0483bc 100644 --- a/basis/mime/multipart/multipart-tests.factor +++ b/basis/mime/multipart/multipart-tests.factor @@ -20,10 +20,11 @@ IN: mime.multipart.tests [ t ] [ mime-test-stream [ upload-separator parse-multipart ] with-input-stream - drop "\"up.txt\"" swap key? + nip "\"up.txt\"" swap key? ] unit-test [ t ] [ mime-test-stream [ upload-separator parse-multipart ] with-input-stream - nip "\"text1\"" swap key? + drop "\"text1\"" swap key? ] unit-test + diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index e7985f803d..10ddb926dd 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -33,8 +33,8 @@ ERROR: bad-header bytes ; : mime-write ( sequence -- ) >byte-array write ; -: parse-headers ( string -- sequence ) - string-lines harvest [ parse-header-line ] map ; +: parse-headers ( string -- hashtable ) + string-lines harvest [ parse-header-line ] map >hashtable ; ERROR: end-of-stream multipart ; @@ -73,11 +73,14 @@ ERROR: end-of-stream multipart ; "\r\n\r\n" dump-string dup "--\r" = [ drop ] [ - parse-headers >hashtable >>header + parse-headers >>header ] if ; +: empty-name? ( string -- ? ) + { "''" "\"\"" "" f } member? ; + : save-uploaded-file ( multipart -- ) - dup filename>> empty? [ + dup filename>> empty-name? [ drop ] [ [ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ] @@ -86,9 +89,13 @@ ERROR: end-of-stream multipart ; ] if ; : save-form-variable ( multipart -- ) - [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ] - [ name>> ] - [ form-variables>> set-at ] tri ; + dup name>> empty-name? [ + drop + ] [ + [ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ] + [ name>> ] + [ form-variables>> set-at ] tri + ] if ; : dump-mime-file ( multipart filename -- multipart ) binary [ @@ -132,19 +139,22 @@ ERROR: no-content-disposition multipart ; [ no-content-disposition ] } case ; -: read-assert= ( string -- ) - [ length read ] keep assert= ; +: assert-sequence= ( a b -- ) + 2dup sequence= [ 2drop ] [ assert ] if ; + +: read-assert-sequence= ( sequence -- ) + [ length read ] keep assert-sequence= ; : parse-beginning ( multipart -- multipart ) - "--" read-assert= + "--" read-assert-sequence= dup mime-separator>> - [ read-assert= ] + [ read-assert-sequence= ] [ separator-prefix prepend >>mime-separator ] bi ; : parse-multipart-loop ( multipart -- multipart ) read-header dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ; -: parse-multipart ( sep -- uploaded-files form-variables ) +: parse-multipart ( separator -- form-variables uploaded-files ) parse-beginning parse-multipart-loop - [ uploaded-files>> ] [ form-variables>> ] bi ; + [ form-variables>> ] [ uploaded-files>> ] bi ; diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor old mode 100644 new mode 100755 index cab5d91952..f347377d95 --- a/extra/webapps/imagebin/imagebin.factor +++ b/extra/webapps/imagebin/imagebin.factor @@ -23,11 +23,12 @@ SYMBOL: my-post-data { imagebin "upload-image" } >>template [ - request get post-data>> my-post-data set-global + + ! request get post-data>> my-post-data set-global ! image new ! "file" value ! insert-tuple - ! "uploaded-image" + "uploaded-image" ] >>submit ; : ( -- responder )