commit 5bbf6ece988ed24bbdeca3cd50961f2c1080673e
parent 796285fa119251397585b148de17455e8f362c9c
Author: Tomas Hlavaty <tom@logand.com>
Date: Mon, 4 May 2015 22:18:24 +0200
sock v5 protocol added
Diffstat:
| M | cl-rw.asd | | | 3 | ++- |
| M | http.lisp | | | 25 | ++++++++++++++----------- |
| A | sock.lisp | | | 122 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
3 files changed, 138 insertions(+), 12 deletions(-)
diff --git a/cl-rw.asd b/cl-rw.asd
@@ -51,4 +51,5 @@
(:file "der")
(:file "wire")
(:file "dns")
- (:file "tls")))
+ (:file "tls")
+ (:file "sock")))
diff --git a/http.lisp b/http.lisp
@@ -115,6 +115,19 @@
(write-protocol stream protocol)
(write-crlf stream))
+(defun %client1 (stream host port path query-string headers)
+ (write-query stream :get :http-1.0 path query-string)
+ (write-headers (or headers
+ `(("Host" . ,(if port
+ (format nil "~a:~a" host port)
+ host))))
+ stream)
+ (write-crlf stream)
+ (finish-output stream)
+ (let ((r (rw:peek-reader (rw:char-reader stream))))
+ (multiple-value-bind (protocol code message) (next-status r)
+ (values protocol code message (next-headers r) (next-body r)))))
+
(defun client1 (url headers)
(destructuring-bind (&key scheme host port path query-string fragment)
(etypecase url
@@ -123,17 +136,7 @@
(declare (ignore fragment))
(assert (equal "http" scheme))
(with-open-stream (s (rw.socket:make-tcp-client-socket host (or port 80)))
- (write-query s :get :http-1.0 path query-string)
- (write-headers (or headers
- `(("Host" . ,(if port
- (format nil "~a:~a" host port)
- host))))
- s)
- (write-crlf s)
- (finish-output s)
- (let ((r (rw:peek-reader (rw:char-reader s))))
- (multiple-value-bind (protocol code message) (next-status r)
- (values protocol code message (next-headers r) (next-body r)))))))
+ (%client1 s host port path query-string headers))))
(defun client (url &key headers (redirect 5))
(do (protocol code message headers2 body)
diff --git a/sock.lisp b/sock.lisp
@@ -0,0 +1,122 @@
+;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.sock
+ (:use :cl))
+
+(in-package :rw.sock)
+
+;; https://en.wikipedia.org/wiki/SOCKS
+;; https://tools.ietf.org/html/rfc1928
+
+(rw.wire:defenum $auth (:type rw:u8)
+ (none . 0)
+ (gssapi . 1)
+ (password . 2))
+
+(rw.wire:defenum $command (:type rw:u8)
+ (connect . 1)
+ (bind . 2)
+ (udp . 3))
+
+(rw.wire:defenum $address-type (:type rw:u8)
+ (ipv4 . 1)
+ (domain . 3)
+ (ipv6 . 4))
+
+(rw.wire:defenum $status (:type rw:u8)
+ (succeeded . 0)
+ (general-failure . 1)
+ (not-allowed . 2)
+ (network-unreachable . 3)
+ (host-unreachable . 4)
+ (connection-refused . 5)
+ (ttl-expired . 6)
+ (command-not-supported . 7)
+ (address-type-not-supported . 8))
+
+(rw.wire:defstruc $hello-request ()
+ (rw:u8 version) ;; must be 5
+ ($auth methods :length rw:u8))
+
+(rw.wire:defstruc $hello-response ()
+ (rw:u8 version) ;; must be 5
+ ($auth method))
+
+(rw.wire:defstruc $connection-request ()
+ (rw:u8 version) ;; must be 5
+ ($command command)
+ (rw:u8 reserved) ;; must be 0
+ ($address-type address-type)
+ ((ecase address-type
+ (ipv4 rw.dns::$ipv4-address) ;; 4 bytes
+ (domain rw.dns::$dns-string) ;; 1byte length + data
+ (ipv6 rw.dns::$ipv6-address)) ;; 16 bytes
+ address)
+ (rw:u16be port))
+
+(rw.wire:defstruc $connection-response ()
+ (rw:u8 version) ;; must be 5
+ ($status status)
+ (rw:u8 reserved) ;; must be 0
+ ($address-type address-type)
+ ((ecase address-type
+ (ipv4 rw.dns::$ipv4-address) ;; 4 bytes
+ (domain rw.dns::$dns-string) ;; 1byte length + data
+ (ipv6 rw.dns::$ipv6-address)) ;; 16 bytes
+ address)
+ (rw:u16be port))
+
+(defun connect (stream host port)
+ (let ((r (rw:byte-reader stream))
+ (w (rw:byte-writer stream)))
+ (write-$hello-request
+ w
+ (make-$hello-request :version 5 :methods 'none))
+ (finish-output stream)
+ (let ((x (next-$hello-response r)))
+ (assert (eql 5 ($hello-response-version x)))
+ (assert (eql 'none ($hello-response-method x))))
+ (write-$connection-request
+ w
+ (make-$connection-request :version 5
+ :command 'connect
+ :reserved 0
+ :address-type 'domain
+ :address host
+ :port port))
+ (finish-output stream)
+ (let ((x (next-$connection-response r)))
+ (assert (eql 5 ($connection-response-version x)))
+ (assert (eql 'succeeded ($connection-response-status x)))
+ (assert (eql 0 ($connection-response-reserved x))))))
+
+#+nil
+(time
+ (with-open-stream ;; rw.socket:with-socket
+ (s (rw.socket:make-tcp-client-socket
+ "127.0.0.1"
+ #+nil
+ (rw.socket:make-ipv4-address "127.0.0.1")
+ 9050))
+ (connect s "logand.com" 80)
+ (rw.http::%client1 s "logand.com" nil "/" nil nil)))
