http.client: support upgrading to websockets

diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor
index 4218982488d0554c757e438d1732f833ff0b0382..1f4d13b2c101b528bf86fffa355764f81ba390e6 100644 (file)
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@@ -161,13 +161,9 @@ HELP: read-response-header
 
 HELP: with-http-request
 { $values { "request" request } { "quot" { $quotation ( chunk -- ) } } { "response" response } }
-{ $description "A variant of " { $link with-http-request* } " that checks that the response was successful." } ;
+{ $description "A variant of " { $link do-http-request } " that checks that the response was successful." } ;
 
-HELP: with-http-request*
-{ $values { "request" request } { "quot" { $quotation ( chunk -- ) } } { "response" response } }
-{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ;
-
-{ http-request http-request* with-http-request with-http-request* } related-words
+{ http-request http-request* with-http-request } related-words
 
 ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
@@ -190,7 +186,6 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "The " { $link http-request } " and " { $link http-request* } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:"
 { $subsections
     with-http-request
-    with-http-request*
 } ;
 
 ARTICLE: "http.client.post-data" "HTTP client post data"

diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 1e577dad2af30ddc60561dd2a8a29de131906c88..922e151638110b5f385df8045b6815db763ddf6d 100644 (file)
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See https://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs calendar combinators
-combinators.short-circuit destructors effects environment
-hashtables http http.client.post-data http.parsers io io.crlf
-io.encodings io.encodings.ascii io.encodings.binary
+USING: accessors arrays ascii assocs calendar combinators
+combinators.short-circuit continuations destructors effects
+environment hashtables http http.client.post-data http.parsers
+io io.crlf io.encodings io.encodings.ascii io.encodings.binary
 io.encodings.iana io.encodings.string io.files io.pathnames
 io.sockets io.sockets.secure io.timeouts kernel math math.order
 math.parser mime.types namespaces present sequences splitting
@@ -109,8 +109,6 @@ ERROR: download-failed response ;
     read-response-line
     read-response-header ;
 
-DEFER: (with-http-request)
-
 SYMBOL: redirects
 
 : redirect-url ( request url -- request )
@@ -119,13 +117,12 @@ SYMBOL: redirects
 : redirect? ( response -- ? )
     code>> 300 399 between? ;
 
-:: do-redirect ( quot: ( chunk -- ) response -- response )
+:: prepare-redirect ( response -- response )
     redirects inc
     redirects get request get redirects>> < [
         request get clone
         response "location" header redirect-url
         response code>> 307 = [ "GET" >>method f >>post-data ] unless
-        quot (with-http-request)
     ] [ too-many-redirects ] if ; inline recursive
 
 : read-chunk-size ( -- n )
@@ -218,10 +215,22 @@ SYMBOL: redirects
         pick no-proxy? [ nip ] [ [ request-url ] dip derive-url ] if
     ] [ nip ] if check-proxy ;
 
-: (with-http-request) ( request quot: ( chunk -- ) -- response )
-    swap ?default-proxy
-    request [
-        <request-socket> [
+: upgrade-to-websocket? ( response -- ? )
+    {
+        [ response? ]
+        [ code>> 101 = ]
+        [ message>> >lower "switching protocols" = ]
+        [ header>> "connection" of "upgrade" = ]
+        [ header>> "upgrade" of "websocket" = ]
+    } 1&& ;
+
+SYMBOL: request-socket
+
+: do-http-request ( request quot: ( chunk -- ) -- response/stream )
+    [ ?default-proxy \ request ] dip dup '[
+        [
+            <request-socket> |dispose
+            dup request-socket set
             [
                 [ in>> ] [ out>> ] bi [ ?https-tunnel ] with-streams*
             ]
@@ -229,19 +238,25 @@ SYMBOL: redirects
                 out>>
                 [ request get write-request ]
                 with-output-stream*
-            ] [
+            ]
+            [
                 in>> [
-                    read-response dup redirect?
-                    request get redirects>> 0 > and [ t ] [
-                        [ nip response set ]
-                        [ read-response-body ]
-                        [ ]
-                        2tri f
+                    read-response
+                    dup redirect?
+                    request get redirects>> 0 > and [
+                        request-socket get dispose
+                        prepare-redirect _ do-http-request
+                    ] [
+                        dup upgrade-to-websocket?
+                        [ drop request-socket get ]
+                        [
+                            [ _ ] dip [ read-response-body ] keep
+                            request-socket get dispose
+                        ] if
                     ] if
                 ] with-input-stream*
             ] tri
-        ] with-disposal
-        [ do-redirect ] [ nip ] if
+        ] with-destructors
     ] with-variable ; inline recursive
 
 : <client-request> ( url method -- request )
@@ -251,14 +266,11 @@ SYMBOL: redirects
 
 PRIVATE>
 
-: with-http-request* ( request quot: ( chunk -- ) -- response )
-    [ (with-http-request) ] with-destructors ; inline
-
-: with-http-request ( request quot: ( chunk -- ) -- response )
-    with-http-request* check-response ; inline
+: with-http-request ( request quot: ( chunk -- ) -- response/stream )
+    do-http-request check-response ; inline
 
 : http-request* ( request -- response data )
-    BV{ } clone [ '[ _ push-all ] with-http-request* ] keep
+    BV{ } clone [ '[ _ push-all ] do-http-request ] keep
     B{ } like over content-encoding>> decode [ >>body ] keep ;
 
 : http-request ( request -- response data )

diff --git a/extra/bittorrent/bittorrent.factor b/extra/bittorrent/bittorrent.factor
index bc4222dca1d0aa3cc0411fd72750e07b4dea5152..db6566ee0ec1223701e56fc148589215fb4c858d 100644 (file)
--- a/extra/bittorrent/bittorrent.factor
+++ b/extra/bittorrent/bittorrent.factor
@@ -48,7 +48,7 @@ torrent-port [ 6881 ] initialize
 
 : http-get-bencode ( url -- obj )
     <get-request> BV{ } clone [
-        '[ _ push-all ] with-http-request* check-response drop
+        '[ _ push-all ] do-http-request check-response drop
     ] keep B{ } like bencode> ;