-
Notifications
You must be signed in to change notification settings - Fork 9
/
device-level.lisp
90 lines (79 loc) · 3.82 KB
/
device-level.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
;;; -*- Package: de.setf.amqp.implementation; -*-
(in-package :de.setf.amqp.implementation)
(:documentation "This file defines version-specific connecttion and channel operators for AMPQ version 0.8
of the `de.setf.amqp` library."
(copyright
"Copyright 2010 [james anderson](mailto:james.anderson@setf.de) All Rights Reserved"
"'de.setf.amqp' is free software: you can redistribute it and/or modify it under the terms of version 3
of the GNU Affero General Public License as published by the Free Software Foundation.
'setf.amqp' is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the
implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Affero General Public License for more details.
A copy of the GNU Affero General Public License should be included with 'de.setf.amqp' as `AMQP:agpl.txt`.
If not, see the GNU [site](http://www.gnu.org/licenses/)."))
(defmethod shared-initialize ((instance amqp-1-1-0-8-0:connection) (slots t) &key)
;; after slot-initialization, but before device-open, set frame classes
;; set iff unbound to permit reinitialization from change-class
(call-next-method)
(flet ((conditionally-set (name value)
(unless (slot-boundp instance name)
(setf (slot-value instance name) value))))
(conditionally-set 'input-frame-class '7-byte-header-input-frame)
(conditionally-set 'output-frame-class '7-byte-header-output-frame)))
(defmethod device-open ((device amqp-1-1-0-8-0:channel) #-sbcl (slot-names t) initargs)
(etypecase (device-state device)
(amqp.s:open-channel
(if (or (stream-input-handle device)
(stream-output-handle device))
(call-next-method)
(when (call-next-method)
(if (zerop (channel-number device))
device
(destructuring-bind (&key realm &allow-other-keys) initargs
(cond (realm
(assert (member realm '("/admin" "/data") :test #'string-equal) ()
"Invalid channel realm: ~s, ~s" device realm)
;; the realm comprises the realm proper + the additions arguments:
;; exclusive passive active write read
(apply #'amqp:request-request (amqp:ensure-object device 'amqp:access
:realm realm)
realm)
(command-case (device)
(amqp:request-ok ((access amqp:access) &key ticket)
(amqp:log :debug device "device-open: for realm: ~s, ~s"
realm ticket)
(setf (amqp.u:channel-ticket device) ticket)
device)))
(t
(amqp:log :debug device "device-open: no realm.")
device)))))))
(amqp.s:use-channel
(call-next-method))))
#+(or ) ; happens in generated code
(defmethod channel-respond-to-open-ok ((channel amqp-1-1-0-8-0:channel)
(connection amqp-1-1-0-8-0:connection)
&key (known-hosts nil kh-s))
(when kh-s
(setf (amqp:connection-known-hosts connection) known-hosts)))
(defmethod connection-frame-type-class-name ((connection amqp-1-1-0-8-0:connection) type-code)
(ecase type-code
(0 nil)
(1 'amqp:method)
(2 'amqp:header)
(3 'amqp:body)
(4 'amqp:oob-method)
(5 'amqp:oob-header)
(6 'amqp:oob-body)
(7 'amqp:trace)
(8 'amqp:heartbeat)))
(defmethod connection-class-name-frame-type ((connection amqp-1-1-0-8-0:connection) name)
(ecase name
((nil) 0)
(amqp:method 1)
(amqp:header 2)
(amqp:body 3)
(amqp:oob-method 4)
(amqp:oob-header 5)
(amqp:oob-body 6)
(amqp:trace 7)
(amqp:heartbeat 8)))