cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit 5bbf6ece988ed24bbdeca3cd50961f2c1080673e
parent 796285fa119251397585b148de17455e8f362c9c
Author: Tomas Hlavaty <tom@logand.com>
Date:   Mon,  4 May 2015 22:18:24 +0200

sock v5 protocol added

Diffstat:
Mcl-rw.asd | 3++-
Mhttp.lisp | 25++++++++++++++-----------
Asock.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)))