cl-rw

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

sock.lisp (4055B)

      1 ;;; Copyright (C) 2015 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.sock
     24   (:use :cl))
     25 
     26 (in-package :rw.sock)
     27 
     28 ;; https://en.wikipedia.org/wiki/SOCKS
     29 ;; https://tools.ietf.org/html/rfc1928
     30 
     31 (rw.wire:defenum $auth (:type rw:u8)
     32   (none     . 0)
     33   (gssapi   . 1)
     34   (password . 2))
     35 
     36 (rw.wire:defenum $command (:type rw:u8)
     37   (connect . 1)
     38   (bind    . 2)
     39   (udp     . 3))
     40 
     41 (rw.wire:defenum $address-type (:type rw:u8)
     42   (ipv4   . 1)
     43   (domain . 3)
     44   (ipv6   . 4))
     45 
     46 (rw.wire:defenum $status (:type rw:u8)
     47   (succeeded                  . 0)
     48   (general-failure            . 1)
     49   (not-allowed                . 2)
     50   (network-unreachable        . 3)
     51   (host-unreachable           . 4)
     52   (connection-refused         . 5)
     53   (ttl-expired                . 6)
     54   (command-not-supported      . 7)
     55   (address-type-not-supported . 8))
     56 
     57 (rw.wire:defstruc $hello-request ()
     58   (rw:u8 version) ;; must be 5
     59   ($auth methods :length rw:u8))
     60 
     61 (rw.wire:defstruc $hello-response ()
     62   (rw:u8 version) ;; must be 5
     63   ($auth method))
     64 
     65 (rw.wire:defstruc $connection-request ()
     66   (rw:u8 version) ;; must be 5
     67   ($command command)
     68   (rw:u8 reserved) ;; must be 0
     69   ($address-type address-type)
     70   ((ecase address-type
     71      (ipv4 rw.dns::$ipv4-address)  ;; 4 bytes
     72      (domain rw.dns::$dns-string)  ;; 1byte length + data
     73      (ipv6 rw.dns::$ipv6-address)) ;; 16 bytes
     74    address)
     75   (rw:u16be port))
     76 
     77 (rw.wire:defstruc $connection-response ()
     78   (rw:u8 version) ;; must be 5
     79   ($status status)
     80   (rw:u8 reserved) ;; must be 0
     81   ($address-type address-type)
     82   ((ecase address-type
     83      (ipv4 rw.dns::$ipv4-address)  ;; 4 bytes
     84      (domain rw.dns::$dns-string)  ;; 1byte length + data
     85      (ipv6 rw.dns::$ipv6-address)) ;; 16 bytes
     86    address)
     87   (rw:u16be port))
     88 
     89 (defun connect (stream host port)
     90   (let ((r (rw:byte-reader stream))
     91         (w (rw:byte-writer stream)))
     92     (write-$hello-request
     93      w
     94      (make-$hello-request :version 5 :methods 'none))
     95     (finish-output stream)
     96     (let ((x (next-$hello-response r)))
     97       (assert (eql 5 ($hello-response-version x)))
     98       (assert (eql 'none ($hello-response-method x))))
     99     (write-$connection-request
    100      w
    101      (make-$connection-request :version 5
    102                                :command 'connect
    103                                :reserved 0
    104                                :address-type 'domain
    105                                :address host
    106                                :port port))
    107     (finish-output stream)
    108     (let ((x (next-$connection-response r)))
    109       (assert (eql 5 ($connection-response-version x)))
    110       (assert (eql 'succeeded ($connection-response-status x)))
    111       (assert (eql 0 ($connection-response-reserved x))))))
    112 
    113 #+nil
    114 (time
    115  (with-open-stream ;; rw.socket:with-socket
    116      (s (rw.socket:make-tcp-client-socket
    117          "127.0.0.1"
    118          #+nil
    119          (rw.socket:make-ipv4-address "127.0.0.1")
    120          9050))
    121    (connect s "logand.com" 80)
    122    (rw.http::%client1 s "logand.com" nil "/" nil nil)))