http.websockets: Initial commit

Need to factor out add-origin-header and handling the connections. The
http integration is a little sloppy as well.

Try this:

"demo.piesocket.com/v3/1?api_key=oCdCMcMPQpbvNjUIzqtvF1d2X2okWpDQj4AwARJuAgtjhzKxVEjQU6IdCjwm&notify_self=1"

<get-request> add-websocket-headers http-request* nip
[ in>> stream>> ] [ out>> stream>> ] bi dup .
[
    ! "hello" f 1 f send-websocket-text
    [ B default-handle-websocket ] read-websocket-loop
] with-streams

diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index b0bad5ff61ea2a61dfbed85dcb77747d1188a78b..ccdf79db0e4e41287bd2c333e5f67a5debf2b595 100644 (file)
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs calendar combinators
+USING: accessors arrays ascii assocs calendar combinators
 combinators.short-circuit destructors 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 urls
-vocabs.loader ;
+http http.client.post-data http.parsers http.websockets 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
+urls vocabs.loader ;
 IN: http.client
 
 ERROR: too-many-redirects ;
@@ -218,32 +218,40 @@ 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> [
-            [
-                [ in>> ] [ out>> ] bi
-                [ ?https-tunnel ] with-streams*
-            ]
-            [
-                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
-                    ] if
-                ] with-input-stream*
-            ] tri
-        ] with-disposal
-        [ do-redirect ] [ nip ] if
-    ] with-variable ; inline recursive
+SYMBOL: request-socket
+: (with-http-request) ( request quot: ( chunk -- ) -- response/websocket )
+    [
+        swap ?default-proxy
+        request [
+            <request-socket> |dispose
+            dup request-socket [
+                [
+                    [ in>> ] [ out>> ] bi
+                    [ ?https-tunnel ] with-streams*
+                ]
+                [
+                    out>>
+                    [ request get write-request ]
+                    with-output-stream*
+                ] [
+                    in>> [
+                        read-response {
+                            { [ dup redirect? request get redirects>> 0 > and ] [ request-socket get &dispose drop t ] }
+                            { [ dup check-websocket-upgraded? ] [ request-socket get 2array f ] }
+                            [
+                                request-socket get &dispose drop
+                                [ nip response set ]
+                                [ read-response-body ]
+                                [ ]
+                                2tri f
+                            ]
+                        } cond
+                    ] with-input-stream*
+                ] tri
+            ] with-variable
+            [ do-redirect ] [ nip ] if
+        ] with-variable
+    ] with-destructors ; inline recursive
 
 : <client-request> ( url method -- request )
     <request>
@@ -258,9 +266,14 @@ PRIVATE>
 : with-http-request ( request quot: ( chunk -- ) -- response )
     with-http-request* check-response ; inline
 
-: http-request* ( request -- response data )
+: http-request* ( request -- response data/websocket-stream )
     BV{ } clone [ '[ _ push-all ] with-http-request* ] keep
-    B{ } like over content-encoding>> decode [ >>body ] keep ;
+    over array? [
+        drop first2
+    ] [
+        B{ } like
+        over content-encoding>> decode [ >>body ] keep
+    ] if ;
 
 : http-request ( request -- response data )
     http-request* [ check-response ] dip ;

diff --git a/basis/http/websockets/authors.txt b/basis/http/websockets/authors.txt
new file mode 100644 (file)
index 0000000..7c1b2f2
--- /dev/null
+++ b/basis/http/websockets/authors.txt
@@ -0,0 +1 @@
+Doug Coleman

diff --git a/basis/http/websockets/websockets.factor b/basis/http/websockets/websockets.factor
new file mode 100644 (file)
index 0000000..1309eda
--- /dev/null
+++ b/basis/http/websockets/websockets.factor
@@ -0,0 +1,143 @@
+! Copyright (C) 2021 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.enums alien.syntax assocs base64
+byte-arrays combinators combinators.short-circuit crypto.xor
+http http.client io io.binary io.encodings.string
+io.encodings.utf8 kernel math math.bitwise multiline namespaces
+prettyprint random sequences strings tools.hexdump ;
+IN: http.websockets
+
+! TODO: multiplexing, fragmented send
+
+CONSTANT: websocket-version "13"
+
+: random-websocket-key ( -- base64 )
+    16 random-bytes >base64 >string ;
+
+: add-websocket-headers ( request -- request )
+    "connection" over header>> delete-at
+    "Upgrade" "Connection" set-header
+    "no-cache" "Pragma" set-header
+    "no-cache" "Cache-Control" set-header
+    "websocket" "Upgrade" set-header
+    ! "http://www.websocket.org" "Origin" set-header
+    "https://www.piesocket.com" "Origin" set-header
+    websocket-version "Sec-WebSocket-Version" set-header
+    random-websocket-key "Sec-WebSocket-Key" set-header
+    "permessage-deflate; client_max_window_bits" "Sec-WebSocket-Extensions" set-header
+    "gzip, deflate" "Accept-Encoding" set-header
+    "en-US,en;q=0.9,sw-TZ;q=0.8,sw;q=0.7,es-US;q=0.6,es;q=0.5,de-DE;q=0.4,de;q=0.3,fr-FR;q=0.2,fr;q=0.1" "Accept-Language" set-header ;
+
+: add-origin-header ( request origin -- request ) "Origin" set-header ;
+
+ENUM: WEBSOCKET-OPCODE
+    { WS-CONTINUE 0 }
+    { WS-TEXT 1 }
+    { WS-BINARY 2 }
+    { WS-CONNECTION-CLOSE 8 }
+    { WS-PING 9 }
+    { WS-PONG 0xa } ;
+
+: get-read-payload-length ( -- length masked? )
+    read1 [
+        {
+            { [ dup 125 <= ] [ ] }
+            { [ dup 126 = ] [ drop 2 read be> ] }
+            { [ dup 127 = ] [ drop 8 read be> ] }
+        } cond
+    ] [
+        0x80 mask?
+    ] bi ;
+
+: get-write-payload-length ( bytes -- length-byte length-bytes/f )
+    length {
+        { [ dup 125 <= ] [ f ] }
+        { [ dup 0xffff <= ] [ [ drop 126 ] [ 2 >be ] bi ] }
+        [ [ drop 127 ] [ 8 >be ] bi ]
+    } cond ;
+
+! The final packet of a fragmented send has high bit set
+! opcode should be WS-TEXT or WS-binary
+! mask is a random 4 bytes to XOR with the data, optional
+: send-websocket-bytes ( bytes mask? opcode final? -- )
+    0b10000000 0b0 ? bitor write1
+    [
+        [
+            get-write-payload-length [ 0x80 bitor ] dip
+            [ write1 ] [ [ write ] when* ] bi*
+        ] [
+            4 random-bytes
+            [ write drop ]
+            [ xor-crypt [ write ] when* ] 2bi
+        ] bi
+    ] [
+        [ get-write-payload-length [ write1 ] [ [ write ] when* ] bi* ]
+        [ [ write ] when* ] bi
+    ] if flush ;
+
+: send-websocket-text ( bytes mask? opcode fin? -- )
+    [ utf8 encode ] 3dip send-websocket-bytes ;
+
+: read-payload ( -- payload )
+    get-read-payload-length [ [ 4 read ] dip read xor-crypt ] [ read ] if ;
+
+: send-pong ( payload -- )
+    t 0xa t send-websocket-bytes ;
+
+SYMBOL: websocket-received
+
+ERROR: unsupported-opcode n ;
+: read-websocket ( -- loop? obj opcode )
+    read1 [
+        [ 0x80 mask? drop ] [ 7 clear-bit ] bi
+        [
+            WEBSOCKET-OPCODE number>enum
+            {
+                { f [ f "disconnected" ] }
+                ! { WS-CONTINUE [ t websocket-received dup get push ] }
+                { WS-TEXT [ t read-payload ] }
+                { WS-BINARY [ t read-payload utf8 decode ] }
+                { WS-CONNECTION-CLOSE [ f read1 ] }
+                { WS-PING [ t read-payload [ send-pong ] keep ] }
+                { WS-PONG [ t read-payload ] }
+                [ unsupported-opcode ]
+            } case
+        ] keep
+    ] [
+        f f f
+    ] if* ;
+
+: read-websocket-loop ( quot -- )
+    '[
+        websocket-received V{ } clone [
+            read-websocket @
+        ] with-variable
+    ] loop ; inline
+
+
+: default-handle-websocket ( obj opcode -- )
+    WEBSOCKET-OPCODE number>enum
+    {
+        { f [ [ drop "closed with error" . ] with-global ] }
+        ! { WS-CONTINUE [  ] }
+        { WS-TEXT [ [ [ hexdump. ] with-global ] when* ] }
+        { WS-BINARY [ [ [ hexdump. ] with-global ] when* ] }
+        { WS-CONNECTION-CLOSE [ [ [ . ] when* ] with-global ] }
+        { WS-PING [ [ [ hexdump. ] with-global ] when* ] }
+        [ 2drop ]
+    } case ;
+
+: check-websocket-upgraded? ( response -- ? )
+    {
+        [ code>> 101 = ]
+        [
+            header>> {
+                [ "connection" of "upgrade" = ]
+                [ "upgrade" of "websocket" = ]
+            } 1&&
+        ]
+    } 1&& ;
+
+: start-websocket ( url -- response )
+    <get-request> add-websocket-headers http-request* drop
+    dup check-websocket-upgraded? [ ] [ ] if ;