OpenTransportUDP.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
OpenTransportUDP.lisp (6398B)
---
1 ;;;-*-Mode: LISP; Package: CCL -*-
2 ;;
3 ;;; OpenTransportUDP.lisp
4 ;;; Copyright 2012 Chun Tian (binghe) <binghe.lisp@gmail.com>
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 loopback interface
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 address while opening a tcp stream")
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 one for the true port:
30 (multiple-value-bind (proxy result)
31 (let* ((*opentransport-class-proxies* NIL) ; makes ot-find-proxy return NIL
32 (result (:do-it)) ;; pushes onto *opentransport-class-proxies*
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-context.ref)))
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-proxies*
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 configptr 0 (%null-ptr) errP *null-ptr*)
60 #-carbon-compat (#_OTOpenEndpoint configptr 0 (%null-ptr) errP)
61 err (pref errP :osstatus))
62 (if (eql err #$kOTNoError)
63 (let* ((context (ot-make-endpoint-context endpoint nil nil)) ; no notifier, not minimal
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)) #$kOTNoError)
67 (values (ot-error err ,error-context)))))
68 (setf (ot-conn-bindreq conn)
69 #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP)
70 #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*)
71 )
72 (check-ot-error-return :alloc)
73 (setf (ot-conn-bindret conn)
74 #-carbon-compat (#_OTAlloc endpoint #$T_BIND #$T_ADDR errP)
75 #+carbon-compat (#_OTAllocInContext endpoint #$T_BIND #$T_ADDR errP *null-ptr*)
76 )
77 (check-ot-error-return :alloc)
78 (setf (ot-conn-options conn)
79 #-carbon-compat (#_OTAlloc endpoint #$T_OPTMGMT #$T_OPT errP)
80 #+carbon-compat (#_OTAllocInContext endpoint #$T_OPTMGMT #$T_OPT errP *null-ptr*)
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 :inetaddress)
93 (pref bindreq :tbind.qlen) 5) ; arbitrary qlen
94 (#_OTInitInetAddress (pref netbuf :tnetbuf.buf) port host)
95 (setf (pref context :ot-context.completed) nil)
96 (unless (= (setq err (#_OTBind endpoint bindreq bindret)) #$kOTNoError)
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)) #$kOTNoError)
108 (values (ot-error err ,error-context)))))
109 (let ((udata #-carbon-compat (#_OTAlloc endpoint #$T_UNITDATA #$T_ALL errP)
110 #+carbon-compat (#_OTAllocInContext endpoint #$T_UNITDATA #$T_ALL errP *null-ptr*)))
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 '(unsigned-byte 8))))
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