GopherProxy

	tOpenTransportUDP.lisp - clic - Clic is an command line interactive client for …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tOpenTransportUDP.lisp (6398B)
	---
	1 ;;;--Mode: LISP; Package: CCL --
	2 ;;
	3 ;;; OpenTransportUDP.lisp
	4 ;;; Copyright 2012 Chun Tian (binghe) <[email protected]>
	5
	6 ;;; UDP extension to OpenTransport.lisp (with some TCP patches)
	7
	8 (in-package "CCL")
	9
	10 (eval-when (:compile-toplevel :load-toplevel :execute)
	11 (require :opentransport))
	12
	13 ;; MCL Issue 28: Passive TCP streams should be able to listen to the loo…
	14 ;; see http://code.google.com/p/mcl/issues/detail?id=28 for details
	15
	16 (defparameter passive-interface-address NIL
	17 "Address to use for passive connections - optionally bind to loopback …
	18
	19 (advise local-interface-ip-address
	20 (or passive-interface-address (:do-it))
	21 :when :around :name 'override-local-interface-ip-address)
	22
	23 ;; MCL Issue 29: Passive TCP connections on OS assigned ports
	24 ;; see http://code.google.com/p/mcl/issues/detail?id=29 for details
	25 (advise ot-conn-tcp-passive-connect
	26 (destructuring-bind (conn port &optional (allow-reuse t)) arglist
	27 (declare (ignore allow-reuse))
	28 (if (eql port #$kOTAnyInetAddress)
	29 ;; Avoids registering a proxy for port 0 but instead registers o…
	30 (multiple-value-bind (proxy result)
	31 (let* ((opentransport-class-proxies NIL) ; makes ot-find-p…
	32 (result (:do-it)) ;; pushes onto *opentransport-class…
	33 (proxy (prog1
	34 (pop opentransport-class-proxies)
	35 (assert (not opentransport-class-proxies))…
	36 (context (cdr proxy))
	37 (tmpconn (make-ot-conn :context context
	38 :endpoint (pref context :ot-co…
	39 (localaddress (ot-conn-tcp-get-addresses tmpconn)))
	40 (declare (dynamic-extent tmpconn))
	41 ;; replace original set in body of function
	42 (setf (ot-conn-local-address conn) localaddress)
	43 (values
	44 (cons localaddress context)
	45 result))
	46 ;; need to be outside local binding of *opentransport-class-pr…
	47 (without-interrupts
	48 (push proxy opentransport-class-proxies))
	49 result)
	50 (:do-it)))
	51 :when :around :name 'ot-conn-tcp-passive-connect-any-address)
	52
	53 (defun open-udp-socket (&key local-address local-port)
	54 (init-opentransport)
	55 (let (endpoint ; TODO: opentransport-alloc-endpoint-from-freelist
	56 (err #$kOTNoError)
	57 (configptr (ot-cloned-configuration traps::$kUDPName)))
	58 (rlet ((errP :osstatus))
	59 (setq endpoint #+carbon-compat (#_OTOpenEndpointInContext configpt…
	60 #-carbon-compat (#_OTOpenEndpoint configptr 0 (%nul…
	61 err (pref errP :osstatus))
	62 (if (eql err #$kOTNoError)
	63 (let* ((context (ot-make-endpoint-context endpoint nil nil)) ;…
	64 (conn (make-ot-conn :context context :endpoint endpoint…
	65 (macrolet ((check-ot-error-return (error-context)
	66 `(unless (eql (setq err (pref errP :osstatus)) …
	67 (values (ot-error err ,error-context)))))
	68 (setf (ot-conn-bindreq conn)
	69 #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADD…
	70 #+carbon-compat (#_OTAllocInContext endpoint #$T_BIN…
	71 )
	72 (check-ot-error-return :alloc)
	73 (setf (ot-conn-bindret conn)
	74 #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADD…
	75 #+carbon-compat (#_OTAllocInContext endpoint #$T_BIN…
	76 )
	77 (check-ot-error-return :alloc)
	78 (setf (ot-conn-options conn)
	79 #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_…
	80 #+carbon-compat (#_OTAllocInContext endpoint #$T_OPT…
	81 )
	82 (check-ot-error-return :alloc))
	83 ;; BIND to local address (for UDP server)
	84 (when local-port ; local-address
	85 (let* ((host (or local-address (local-interface-ip-address…
	86 (port (tcp-service-port-number local-port))
	87 (localaddress `(:tcp ,host ,port))
	88 (bindreq (ot-conn-bindreq conn))
	89 (bindret (ot-conn-bindret conn)))
	90 (let* ((netbuf (pref bindreq :tbind.addr)))
	91 (declare (dynamic-extent netbuf))
	92 (setf (pref netbuf :tnetbuf.len) (record-length :ineta…
	93 (pref bindreq :tbind.qlen) 5) ; arbitrary …
	94 (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port h…
	95 (setf (pref context :ot-context.completed) nil)
	96 (unless (= (setq err (#_OTBind endpoint bindreq bindre…
	97 (ot-error err :bind)))
	98 (setf (ot-conn-local-address conn) localaddress)))
	99 conn)
	100 (ot-error err :create)))))
	101
	102 (defun make-TUnitData (endpoint)
	103 "create the send/recv buffer for UDP sockets"
	104 (let ((err #$kOTNoError))
	105 (rlet ((errP :osstatus))
	106 (macrolet ((check-ot-error-return (error-context)
	107 `(unless (eql (setq err (pref errP :osstatus)) #$kOTN…
	108 (values (ot-error err ,error-context)))))
	109 (let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$…
	110 #+carbon-compat (#_OTAllocInContext endpoint #$T_UN…
	111 (check-ot-error-return :alloc)
	112 udata)))))
	113
	114 (defun send-message (conn data buffer size host port &optional (offset 0…
	115 ;; prepare dest address
	116 (let ((addr (pref data :tunitdata.addr)))
	117 (declare (dynamic-extent addr))
	118 (setf (pref addr :tnetbuf.len) (record-length :inetaddress))
	119 (#_OTInitInetAddress (pref addr :tnetbuf.buf) port host))
	120 ;; prepare data buffer
	121 (let* ((udata (pref data :tunitdata.udata))
	122 (outptr (pref udata :tnetbuf.buf)))
	123 (declare (dynamic-extent udata))
	124 (%copy-ivector-to-ptr buffer offset outptr 0 size)
	125 (setf (pref udata :tnetbuf.len) size))
	126 ;; send the packet
	127 (let* ((endpoint (ot-conn-endpoint conn))
	128 (result (#_OTSndUData endpoint data)))
	129 (the fixnum result)))
	130
	131 (defun receive-message (conn data buffer length)
	132 (let* ((endpoint (ot-conn-endpoint conn))
	133 (err (#_OTRcvUData endpoint data null-ptr)))
	134 (if (eql err #$kOTNoError)
	135 (let* (;(addr (pref data :tunitdata.addr))
	136 (udata (pref data :tunitdata.udata))
	137 (inptr (pref udata :tnetbuf.buf))
	138 (read-bytes (pref udata :tnetbuf.len))
	139 (buffer (or buffer (make-array read-bytes :element-type '…
	140 (length (or length (length buffer)))
	141 (actual-size (min read-bytes length)))
	142 (%copy-ptr-to-ivector inptr 0 buffer 0 actual-size)
	143 (values buffer
	144 actual-size
	145 0 0)) ; TODO: retrieve address and port
	146 (ot-error err :receive)))) ; TODO: use OTRcvUDErr instead