diff options
Diffstat (limited to 'm3ua.scm')
| -rw-r--r-- | m3ua.scm | 1227 |
1 files changed, 1227 insertions, 0 deletions
diff --git a/m3ua.scm b/m3ua.scm new file mode 100644 index 0000000..9044308 --- /dev/null +++ b/m3ua.scm @@ -0,0 +1,1227 @@ +;;; +;;; Copyright (C) 2004, 2005, 2006 M. Tuexen tuexen@fh-muenster.de +;;; +;;; All rights reserved. +;;; +;;; Redistribution and use in source and binary forms, with or +;;; without modification, are permitted provided that the +;;; following conditions are met: +;;; 1. Redistributions of source code must retain the above +;;; copyright notice, this list of conditions and the +;;; following disclaimer. +;;; 2. Redistributions in binary form must reproduce the +;;; above copyright notice, this list of conditions and +;;; the following disclaimer in the documentation and/or +;;; other materials provided with the distribution. +;;; 3. Neither the name of the project nor the names of +;;; its contributors may be used to endorse or promote +;;; products derived from this software without specific +;;; prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS +;;; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, +;;; BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;;; DISCLAIMED. IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS +;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +;;; IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY +;;; OF SUCH DAMAGE. + +;;; $Id: m3ua.scm,v 1.22 2012/08/28 19:56:13 tuexen Exp $ + +;;; Version 1.1.10 +;;; +;;; History of changes: +;;; 04.12.2004 m3ua-reserved-aspsm-message-type added +;;; 04.12.2004 m3ua-make-correlation-id-parameter added +;;; 04.12.2004 m3ua-make-network-appearance-parameter added +;;; 04.12.2004 m3ua-make-asp-parameter added +;;; 04.12.2004 m3ua-traffic-mode-type-broadcast added +;;; 04.12.2004 m3ua-make-asp-up-message now accepts parameters +;;; 04.12.2004 m3ua-make-asp-inactive-message now accepts parameters +;;; 04.12.2004 m3ua-make-asp-inactive-ack-message now accepts parameters +;;; 04.12.2004 m3ua-make-data-message now accepts parameters +;;; 14.12.2004 m3ua-error-message? added +;;; 18.12.2004 m3ua-make-data-message takes now ni mp and sls +;;; 19.12.2004 m3ua-notify-message? added. +;;; 19.12.2004 m3ua-run-sgp accepts a port. +;;; 19.12.2004 m3ua-data-message? added. +;;; 19.12.2004 m3ua-make-routing-context-parameter takes a list of contexts. +;;; 09.09.2005 m3ua-recv-message handles system errors +;;; 09.09.2005 m3ua-wait-for-message returns also on empty messages +;;; 09.09.2005 Use SCTP_NODELAY for all sockets +;;; 10.09.2005 Do the htonl() conversion of the PPID in the scheme code +;;; 04.10.2005 Fix syntax error in m3ua-make-asp-active-ack-message +;;; 04.10.2005 Handle the case where SCTP_NODELAY is not defined +;;; 09.10.2005 Extend m3ua-run-asp to be able to test the APS tests. +;;; 23.12.2005 Add m3ua-send-beats. +;;; 02.01.2006 Added all missing parameter constructors. +;;; 02.01.2006 Added support for RKM messages. +;;; 18.02.2006 Added support for generating REG_RSP messages and the CIC range parameter +;;; 12.03.2006 m3ua-check-common-header now optionally supports RKM messages. +;;; 13.09.2006 Remove info parameter from m3ua-make-data-message. +;;; 11.03.2007 Catch system-errors in send and recv calls. + +(define m3ua-test-result-passed 0) +(define m3ua-test-result-failed 1) +(define m3ua-test-result-unknown 2) +(define m3ua-test-result-not-applicable 253) + +;;; This is the IANA registered PPID for M3UA in host byte order +(define m3ua-ppid 3) + +;;; This is the IANA registered port for M3UA +(define m3ua-port 2905) + +;;; Constants for the message classes +(define m3ua-mgmt-message-class 0) +(define m3ua-tfer-message-class 1) +(define m3ua-ssnm-message-class 2) +(define m3ua-aspsm-message-class 3) +(define m3ua-asptm-message-class 4) +(define m3ua-rkm-message-class 9) +(define m3ua-reserved-message-class 99) + +;;; Constants for the message types +;;; MGMT messages +(define m3ua-err-message-type 0) +(define m3ua-ntfy-message-type 1) + +;;; TFER messages +(define m3ua-data-message-type 1) +(define m3ua-reserved-tfer-message-type 2) + +;;; SSNM messages +(define m3ua-duna-message-type 1) +(define m3ua-dava-message-type 2) +(define m3ua-daud-message-type 3) +(define m3ua-scon-message-type 4) +(define m3ua-dupu-message-type 5) +(define m3ua-drst-message-type 6) + +;;; ASPSM messages +(define m3ua-aspup-message-type 1) +(define m3ua-aspdn-message-type 2) +(define m3ua-beat-message-type 3) +(define m3ua-aspup-ack-message-type 4) +(define m3ua-aspdn-ack-message-type 5) +(define m3ua-beat-ack-message-type 6) +(define m3ua-reserved-aspsm-message-type 7) + +;;;ASPTM messages +(define m3ua-aspac-message-type 1) +(define m3ua-aspia-message-type 2) +(define m3ua-aspac-ack-message-type 3) +(define m3ua-aspia-ack-message-type 4) +(define m3ua-reserved-asptm-message-type 5) + +;;; RKM messages +(define m3ua-reg-req-message-type 1) +(define m3ua-reg-rsp-message-type 2) +(define m3ua-dereg-req-message-type 3) +(define m3ua-dereg-rsp-message-type 4) +(define m3ua-reserved-rkm-message-type 5) + +;;; Constant for the protocol version +(define m3ua-version 1) + +;;; Constant for reserved +(define m3ua-reserved 0) + +;;; +;;; Creator functions for messages +;;; + +(define (m3ua-make-common-header version reserved class type length) + (append (uint8->bytes version) + (uint8->bytes reserved) + (uint8->bytes class) + (uint8->bytes type) + (uint32->bytes length))) + +;;;(m3ua-make-common-header 1 2 3 4 5) +;;;(m3ua-make-common-header m3ua-version m3ua-reserved m3ua-tfer-message-class m3ua-data-message-type 16) + +(define (m3ua-increment-version l) + (if (positive? (length l)) + (cons (+ (car l) 1) (cdr l)) + (list))) +;;;(m3ua-increment-version (list 1 2 3)) +;;;(m3ua-increment-version (list)) + +;;; +;;; Creator functions for parameters +;;; + +(define m3ua-parameter-header-length 4) +(define m3ua-common-header-length 8) +(define m3ua-data-parameter-header-length 16) + +(define (m3ua-number-of-padding-bytes l) + (remainder (- 4 (remainder l 4)) 4)) +;;; (m3ua-number-of-padding-bytes 0) +;;; (m3ua-number-of-padding-bytes 1) +;;; (m3ua-number-of-padding-bytes 2) +;;; (m3ua-number-of-padding-bytes 3) + +(define (m3ua-add-padding l) + (+ l (m3ua-number-of-padding-bytes l))) +;;; (m3ua-add-padding 2) + +(define (m3ua-padding data) + (zero-bytes (m3ua-number-of-padding-bytes (length data)))) +;;;(m3ua-padding (list 1 2 3 4 5)) + +(define (m3ua-make-parameter tag value) + (append (uint16->bytes tag) + (uint16->bytes (+ (length value) m3ua-parameter-header-length)) + value + (m3ua-padding value))) + +(define (m3ua-make-random-parameter l) + (m3ua-make-parameter (random 2^16) (random-bytes l))) +;;;(m3ua-make-random-parameter 10) + +(define (m3ua-add-parameter parameter list) + (cons parameter (remove (lambda(p) (equal? (m3ua-get-parameter-tag p) + (m3ua-get-parameter-tag parameter))) + list))) +;;;(m3ua-add-parameter (m3ua-make-info-string-parameter "Hello1") (list (m3ua-make-correlation-id-parameter 34))) +;;;(m3ua-add-parameter (m3ua-make-info-string-parameter "Hello1") (list (m3ua-make-correlation-id-parameter 34) (m3ua-make-info-string-parameter "Hello"))) + +(define (m3ua-make-message class type parameters) + (append (m3ua-make-common-header m3ua-version + m3ua-reserved + class + type + (+ m3ua-common-header-length (apply + (map length parameters)))) + (apply append parameters))) + +(define m3ua-info-string-tag #x0004) +(define m3ua-routing-context-tag #x0006) +(define m3ua-diagnostic-info-tag #x0007) +(define m3ua-heartbeat-data-tag #x0009) +(define m3ua-traffic-mode-type-tag #x000b) +(define m3ua-error-code-tag #x000c) +(define m3ua-status-tag #x000d) +(define m3ua-asp-identifier-tag #x0011) +(define m3ua-affected-point-code-tag #x0012) +(define m3ua-correlation-id-tag #x0013) + +(define m3ua-network-appearance-tag #x0200) +(define m3ua-user-cause-tag #x0204) +(define m3ua-congestion-indications-tag #x0205) +(define m3ua-concerned-destination-tag #x0206) +(define m3ua-routing-key-tag #x0207) +(define m3ua-registration-result-tag #x0208) +(define m3ua-deregistration-result-tag #x0209) +(define m3ua-local-routing-key-identifier-tag #x020a) +(define m3ua-destination-point-code-tag #x020b) +(define m3ua-service-indicators-tag #x020c) +(define m3ua-originating-point-code-list-tag #x020e) +(define m3ua-circuit-range-tag #x020f) +(define m3ua-protocol-data-tag #x0210) +(define m3ua-registration-status-tag #x0212) +(define m3ua-deregistration-status-tag #x0213) + +(define (m3ua-make-info-string-parameter string) + (m3ua-make-parameter m3ua-info-string-tag (string->bytes string))) +;;; (m3ua-make-info-string-parameter "Hello") + +(define (m3ua-make-routing-context-parameter contexts) + (m3ua-make-parameter m3ua-routing-context-tag (apply append (map uint32->bytes contexts)))) +;;; (m3ua-make-routing-context-parameter (list 1024)) +;;; (m3ua-make-routing-context-parameter (list)) +;;; (m3ua-make-routing-context-parameter (list 1024 4 5 6)) + +(define (m3ua-make-diagnostic-info-parameter info) + (m3ua-make-parameter m3ua-diagnostic-info-tag info)) +;;; (m3ua-make-diagnostic-info-parameter (list 1 2 3 4 5)) + +(define (m3ua-make-heartbeat-data-parameter data) + (m3ua-make-parameter m3ua-heartbeat-data-tag data)) +;;; (m3ua-make-heartbeat-data-parameter (string->bytes "M3UA rocks")) + +(define m3ua-traffic-mode-type-override 1) +(define m3ua-traffic-mode-type-loadshare 2) +(define m3ua-traffic-mode-type-broadcast 3) +(define m3ua-traffic-mode-type-invalid 4) + +(define (m3ua-make-traffic-mode-type-parameter mode) + (m3ua-make-parameter m3ua-traffic-mode-type-tag (uint32->bytes mode))) +;;; (m3ua-make-traffic-mode-type-parameter m3ua-traffic-mode-type-override) + +(define m3ua-invalid-version-error-code #x0001) +(define m3ua-unsupported-message-class-error-code #x0003) +(define m3ua-unsupported-message-type-error-code #x0004) +(define m3ua-unsupported-traffic-mode-type-error-code #x0005) +(define m3ua-unexpected-message-error-code #x0006) +(define m3ua-protocol-error-error-code #x0007) +(define m3ua-invalid-stream-identifier-error-code #x0009) +(define m3ua-refused-management-blocking-error-code #x000d) +(define m3ua-asp-identifier-required-error-code #x000e) +(define m3ua-invalid-parameter-value-error-code #x0011) +(define m3ua-parameter-field-error-error-code #x0012) +(define m3ua-unexpected-parameter-error-code #x0013) +(define m3ua-destination-status-unknown-error-code #x0014) +(define m3ua-invalid-network-appearance-error-code #x0015) +(define m3ua-missing-parameter-error-code #x0016) +(define m3ua-invalid-routing-context-error-code #x0019) +(define m3ua-no-configure-as-for-asp-error-code #x001a) + +(define (m3ua-make-error-code-parameter code) + (m3ua-make-parameter m3ua-error-code-tag (uint32->bytes code))) +;;; (m3ua-make-error-code-parameter m3ua-protocol-error-error-code) + +(define (m3ua-get-error-code-from-parameter p) + (bytes->uint32 (m3ua-get-parameter-value p))) +;;;(m3ua-get-error-code-from-parameter (m3ua-make-error-code-parameter m3ua-protocol-error-error-code)) + +(define m3ua-as-state-change-status-type 1) +(define m3ua-other-status-type 2) + +(define m3ua-as-inactive 2) +(define m3ua-as-active 3) +(define m3ua-as-pending 4) + +(define m3ua-insufficient-resources 1) +(define m3ua-alternate-asp-active 2) +(define m3ua-asp-failure 3) + +(define (m3ua-make-status-parameter type info) + (m3ua-make-parameter m3ua-status-tag + (append (uint16->bytes type) + (uint16->bytes info)))) +;;; (m3ua-make-status-parameter 2 3) + +(define (m3ua-get-status-type-from-parameter l) + (bytes->uint16 (m3ua-get-parameter-value l))) +;;; (m3ua-get-status-type-from-parameter (m3ua-make-status-parameter 2 3)) + +(define (m3ua-get-status-info-from-parameter l) + (bytes->uint16 (list-tail (m3ua-get-parameter-value l) 2))) +;;; (m3ua-get-status-info-from-parameter (m3ua-make-status-parameter 2 3)) + +(define (m3ua-make-asp-id-parameter aid) + (m3ua-make-parameter m3ua-asp-identifier-tag (uint32->bytes aid))) +;;; (m3ua-make-asp-id-parameter 1024) + +(define (m3ua-make-affected-point-code-parameter mask-pc-pair-list) + (m3ua-make-parameter m3ua-affected-point-code-tag + (apply append (map (lambda (x) + (append (uint8->bytes (car x)) + (uint24->bytes (cadr x)))) + mask-pc-pair-list)))) +;;; (m3ua-make-affected-point-code-parameter (list (list 0 34) (list 255 89))) + +(define (m3ua-make-correlation-id-parameter id) + (m3ua-make-parameter m3ua-correlation-id-tag (uint32->bytes id))) +;;; (m3ua-make-correlation-id-parameter 1024) + +(define (m3ua-make-network-appearance-parameter na) + (m3ua-make-parameter m3ua-network-appearance-tag (uint32->bytes na))) +;;; (m3ua-make-network-appearance-parameter 1024) + +(define m3ua-unknown-cause 0) +(define m3ua-unequipped-remote-user-cause 1) +(define m3ua-inaccessible-remote-user-cause 2) + +(define m3ua-mtp-user-sccp 3) +(define m3ua-mtp-user-tup 4) +(define m3ua-mtp-user-isup 5) +(define m3ua-mtp-user-broadband-isup 9) +(define m3ua-mtp-user-satellite-isup 10) +(define m3ua-mtp-user-aal-type-2-signalling 12) +(define m3ua-mtp-user-bicc 13) +(define m3ua-mtp-user-gcp 14) + +(define (m3ua-make-user-cause-parameter user cause) + (m3ua-make-parameter m3ua-user-cause-tag (append (uint16->bytes cause) + (uint16->bytes user)))) +;;; (m3ua-make-user-cause-parameter m3ua-mtp-user-isup m3ua-unknown-cause) + +(define m3ua-no-congestion-level 0) +(define m3ua-congestion-level-1 1) +(define m3ua-congestion-level-2 2) +(define m3ua-congestion-level-3 3) + +(define (m3ua-make-congestion-indications-parameter level) + (m3ua-make-parameter m3ua-congestion-indications-tag (append (uint24->bytes 0) + (uint8->bytes level)))) +;;; (m3ua-make-congestion-indications-parameter m3ua-congestion-level-2) + +(define (m3ua-make-concerned-destination-parameter pc) + (m3ua-make-parameter m3ua-concerned-destination-tag (append (uint8->bytes 0) + (uint24->bytes pc)))) +;;; (m3ua-make-concerned-destination-parameter 45) + +(define (m3ua-make-routing-key-parameter parameterlist) + (m3ua-make-parameter m3ua-routing-key-tag (apply append parameterlist))) +;;; (m3ua-make-routing-key-parameter (list (m3ua-make-local-routing-key-identifier-parameter 12) (m3ua-make-destination-point-code-parameter 34))) + +(define (m3ua-make-registration-result-parameter parameterlist) + (m3ua-make-parameter m3ua-registration-result-tag (apply append parameterlist))) +;;; (m3ua-make-registration-result-parameter (list (m3ua-make-local-routing-key-identifier-parameter 1234) (m3ua-make-registration-status-parameter m3ua-successfully-registered-reg-status) (m3ua-make-routing-context-parameter (list 12)))) + +(define (m3ua-make-deregistration-result-parameter parameterlist) + (m3ua-make-parameter m3ua-deregistration-result-tag (apply append parameterlist))) +;;; (m3ua-make-deregistration-result-parameter (list (m3ua-make-routing-context-parameter (list 12)) (m3ua-make-deregistration-status-parameter m3ua-successfully-deregistered-dereg-status))) + +(define (m3ua-make-local-routing-key-identifier-parameter id) + (m3ua-make-parameter m3ua-local-routing-key-identifier-tag (uint32->bytes id))) +;;; (m3ua-make-local-routing-key-identifier-parameter 234) + +(define (m3ua-make-destination-point-code-parameter pc) + (m3ua-make-parameter m3ua-destination-point-code-tag (append (uint8->bytes 0) + (uint24->bytes pc)))) +;;; (m3ua-make-destination-point-code-parameter 45) + +(define (m3ua-make-circuit-range-parameter pc-cic-triple-list) + (m3ua-make-parameter m3ua-circuit-range-tag + (apply append (map (lambda (x) + (append (uint8->bytes 0) + (uint24->bytes (car x)) + (uint16->bytes (cadr x)) + (uint16->bytes (caddr x)))) + pc-cic-triple-list)))) +;;; (m3ua-make-circuit-range-parameter (list (list 1 2 3) (list 4 5 6))) + +(define (m3ua-make-service-indicators-parameter si-list) + (m3ua-make-parameter m3ua-service-indicators-tag (apply append (map uint8->bytes si-list)))) +;;; (m3ua-make-service-indicators-parameter (list 2 4)) + +(define (m3ua-make-originating-point-code-list-parameter mask-pc-pair-list) + (m3ua-make-parameter m3ua-originating-point-code-list-tag + (apply append (map (lambda (x) + (append (uint8->bytes (car x)) + (uint24->bytes (cadr x)))) + mask-pc-pair-list)))) + +;;; (m3ua-make-originating-point-code-list-parameter (list (list 0 34) (list 255 89))) + +(define (m3ua-make-data-parameter opc dpc si ni mp sls data) + (m3ua-make-parameter m3ua-protocol-data-tag + (append (uint32->bytes opc) + (uint32->bytes dpc) + (uint8->bytes si) + (uint8->bytes ni) + (uint8->bytes mp) + (uint8->bytes sls) + data))) +;;; (m3ua-make-data-parameter 3 4 3 2 1 3 (list 1 2 3)) + +(define m3ua-successfully-registered-reg-status 0) +(define m3ua-error-unknown-reg-status 1) +(define m3ua-error-invalid-dpc-reg-status 2) +(define m3ua-error-invalid-network-appearance-reg-status 3) +(define m3ua-error-invalid-routing-key-reg-status 4) +(define m3ua-error-permission-denied-reg-status 5) +(define m3ua-error-cannot-support-unique-routing-reg-status 6) +(define m3ua-error-routing-key-not-currently-provisioned-reg-status 7) +(define m3ua-error-insufficient-resources-reg-status 8) +(define m3ua-error-unsupported-rk-parameter-field-reg-status 9) +(define m3ua-error-unsupported-invalid-traffic-handling-mode-reg-status 10) +(define m3ua-error-routing-key-change-refused-reg-status 11) +(define m3ua-error-routing-key-already-registered-req-status 12) + +(define (m3ua-make-registration-status-parameter status) + (m3ua-make-parameter m3ua-registration-status-tag (uint32->bytes status))) +;;; (m3ua-make-registration-status-parameter 123) + +(define m3ua-successfully-deregistered-dereg-status 0) +(define m3ua-error-unknown-dereg-status 1) +(define m3ua-error-invalid-routing-context-dereg-status 2) +(define m3ua-error-permission-denied-dereg-status 3) +(define m3ua-error-not-registered-dereg-status 4) +(define m3ua-error-asp-currently-active-for-routing-context-dereg-status 5) + +(define (m3ua-make-deregistration-status-parameter status) + (m3ua-make-parameter m3ua-deregistration-status-tag (uint32->bytes status))) +;;; (m3ua-make-deregistration-status-parameter 123) + + +;;;------------------------------------------------------------------ +;;; Parameter Predicates +;;;------------------------------------------------------------------ + +(define (m3ua-error-code-parameter? l) + (= (m3ua-get-parameter-tag l) m3ua-error-code-tag)) + +(define (m3ua-status-parameter? l) + (= (m3ua-get-parameter-tag l) m3ua-status-tag)) + +(define (m3ua-routing-key-parameter? l) + (= (m3ua-get-parameter-tag l) m3ua-routing-key-tag)) + +(define (m3ua-local-routing-key-identifier-parameter? l) + (= (m3ua-get-parameter-tag l) m3ua-local-routing-key-identifier-tag)) + +(define (m3ua-routing-context-parameter? l) + (= (m3ua-get-parameter-tag l) m3ua-routing-context-tag)) + +(define (m3ua-registration-result-parameter? l) + (= (m3ua-get-parameter-tag l) m3ua-registration-result-tag)) + +;;;------------------------------------------------------------------ +;;; Message Contructors +;;;------------------------------------------------------------------ + +(define (m3ua-make-error-message code) + (m3ua-make-message m3ua-mgmt-message-class + m3ua-err-message-type + (list (m3ua-make-error-code-parameter code)))) +;;; (m3ua-make-error-message m3ua-no-configure-as-for-asp-error-code) + +(define (m3ua-make-notify-message type info) + (m3ua-make-message m3ua-mgmt-message-class + m3ua-ntfy-message-type + (list (m3ua-make-status-parameter type info)))) +;;; (m3ua-make-notify-message m3ua-as-state-change-status-type m3ua-as-inactive) + +(define (m3ua-make-beat-message data) + (m3ua-make-message m3ua-aspsm-message-class + m3ua-beat-message-type + (list (m3ua-make-heartbeat-data-parameter data)))) +;;; (m3ua-make-beat-message (string->bytes "M3UA rocks")) + +(define (m3ua-make-beat-ack-message data) + (m3ua-make-message m3ua-aspsm-message-class + m3ua-beat-ack-message-type + (list (m3ua-make-heartbeat-data-parameter data)))) +;;; (m3ua-make-beat-ack-message (string->bytes "M3UA rocks")) + +(define (m3ua-make-asp-up-message parameters) + (m3ua-make-message m3ua-aspsm-message-class + m3ua-aspup-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-asp-up-message (list)) + +(define (m3ua-make-asp-down-message) + (m3ua-make-message m3ua-aspsm-message-class + m3ua-aspdn-message-type + (list (m3ua-make-info-string-parameter "M3UA rocks")))) +;;; (m3ua-make-asp-down-message) + +(define (m3ua-make-asp-up-ack-message) + (m3ua-make-message m3ua-aspsm-message-class + m3ua-aspup-ack-message-type + (list (m3ua-make-info-string-parameter "M3UA rocks")))) +;;; (m3ua-make-asp-up-ack-message) + +(define (m3ua-make-asp-down-ack-message) + (m3ua-make-message m3ua-aspsm-message-class + m3ua-aspdn-ack-message-type + (list (m3ua-make-info-string-parameter "M3UA rocks")))) +;;; (m3ua-make-asp-down-ack-message) + +(define (m3ua-make-asp-active-message parameters) + (m3ua-make-message m3ua-asptm-message-class + m3ua-aspac-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-asp-active-message (list (m3ua-make-routing-context-parameter (list 3)))) + +(define (m3ua-make-asp-active-ack-message parameters) + (m3ua-make-message m3ua-asptm-message-class + m3ua-aspac-ack-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-asp-active-ack-message (list)) + +(define (m3ua-make-asp-inactive-message parameters) + (m3ua-make-message m3ua-asptm-message-class + m3ua-aspia-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-asp-inactive-message (list)) + +(define (m3ua-make-asp-inactive-ack-message parameters) + (m3ua-make-message m3ua-asptm-message-class + m3ua-aspia-ack-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-asp-inactive-ack-message (list)) + +(define (m3ua-make-data-message opc dpc si ni mp sls data parameters) + (m3ua-make-message m3ua-tfer-message-class + m3ua-data-message-type + (append parameters + (list (m3ua-make-data-parameter opc dpc si ni mp sls data))))) +;;; (m3ua-make-data-message 1 2 3 4 5 6 (list 1 2) (list)) +;;; FIXME: Make sure that no parameter is duplicated. + +(define (m3ua-make-duna-message parameters) + (m3ua-make-message m3ua-ssnm-message-class + m3ua-duna-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-duna-message (list)) + +(define (m3ua-make-dava-message parameters) + (m3ua-make-message m3ua-ssnm-message-class + m3ua-dava-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-dava-message (list)) + +(define (m3ua-make-daud-message parameters) + (m3ua-make-message m3ua-ssnm-message-class + m3ua-daud-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-daud-message (list)) + +(define (m3ua-make-scon-message parameters) + (m3ua-make-message m3ua-ssnm-message-class + m3ua-scon-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-scon-message (list)) + +(define (m3ua-make-dupu-message parameters) + (m3ua-make-message m3ua-ssnm-message-class + m3ua-dupu-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-dupu-message (list)) + +(define (m3ua-make-drst-message parameters) + (m3ua-make-message m3ua-ssnm-message-class + m3ua-drst-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) +;;; (m3ua-make-drst-message (list)) + +(define (m3ua-make-reg-req-message parameters) + (m3ua-make-message m3ua-rkm-message-class + m3ua-reg-req-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) + +(define (m3ua-make-reg-rsp-message parameters) + (m3ua-make-message m3ua-rkm-message-class + m3ua-reg-rsp-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) + + +(define (m3ua-make-dereg-req-message parameters) + (m3ua-make-message m3ua-rkm-message-class + m3ua-dereg-req-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) + + +(define (m3ua-make-dereg-rsp-message parameters) + (m3ua-make-message m3ua-rkm-message-class + m3ua-dereg-rsp-message-type + (m3ua-add-parameter (m3ua-make-info-string-parameter "M3UA rocks") parameters))) + +;;; +;;; General accessor functions for messages +;;; + +(define (m3ua-get-common-header l) + (list-head l m3ua-common-header-length)) +;;; (m3ua-get-common-header (m3ua-make-asp-up-message (list))) + +(define m3ua-version-offset 0) +(define m3ua-reserved-offset 1) +(define m3ua-message-class-offset 2) +(define m3ua-message-type-offset 3) +(define m3ua-message-length-offset 4) + +(define (m3ua-get-version l) + (bytes->uint8 (list-tail l m3ua-version-offset))) + +;;;(define hb (m3ua-make-beat-message (string->bytes "M3UA rocks"))) +;;;(m3ua-get-version hb) + +(define (m3ua-get-reserved l) + (bytes->uint8 (list-tail l m3ua-reserved-offset))) +;;;(m3ua-get-reserved hb) + +(define (m3ua-get-message-class l) + (bytes->uint8 (list-tail l m3ua-message-class-offset))) +;;;(m3ua-get-message-class hb) + +(define (m3ua-get-message-type l) + (bytes->uint8 (list-tail l m3ua-message-type-offset))) +;;;(m3ua-get-message-type hb) + +(define (m3ua-get-message-length l) + (bytes->uint32 (list-tail l m3ua-message-length-offset))) +;;;(m3ua-get-message-length hb) + +(define (m3ua-get-parameters-1 l) + (if (>= (length l) m3ua-parameter-header-length) + (let ((parameter-length (m3ua-add-padding (m3ua-get-parameter-length l)))) + (cons (list-head l parameter-length) + (m3ua-get-parameters-1 (list-tail l parameter-length)))) + (list))) + +(define (m3ua-get-parameters-of-message l) + (if (>= (length l) m3ua-common-header-length) + (m3ua-get-parameters-1 (list-tail l m3ua-common-header-length)) + (list))) +;;; (m3ua-get-parameters-of-message (m3ua-make-beat-message (string->bytes "M3UA rocks"))) +;;; (m3ua-get-parameters-of-message (list 2 2)) + +(define m3ua-get-parameters m3ua-get-parameters-of-message) + +(define (m3ua-get-parameters-of-parameter l) + (if (>= (length l) m3ua-common-header-length) + (m3ua-get-parameters-1 (list-tail l m3ua-parameter-header-length)) + (list))) +;;; (m3ua-get-parameters-of-parameter (m3ua-make-routing-key-parameter (list (m3ua-make-local-routing-key-identifier-parameter 3) (m3ua-make-destination-point-code-parameter 4)))) + +(define (m3ua-make-registration-result-from-routing-key key status) + (let ((local-rk-id (bytes->uint32 (list-tail (car (filter m3ua-local-routing-key-identifier-parameter? + (m3ua-get-parameters-of-parameter key))) + m3ua-parameter-header-length)))) + (if (= status m3ua-successfully-registered-reg-status) + (let ((routing-contexts (filter m3ua-routing-context-parameter? (m3ua-get-parameters-of-parameter key)))) + (if (null? routing-contexts) + (m3ua-make-registration-result-parameter (list (m3ua-make-local-routing-key-identifier-parameter local-rk-id) + (m3ua-make-registration-status-parameter status) + (m3ua-make-routing-context-parameter (list tester-rc-valid)))) + (let ((rc (bytes->uint32 (list-tail routing-contexts m3ua-parameter-header-length)))) + (m3ua-make-registration-result-parameter (list (m3ua-make-local-routing-key-identifier-parameter local-rk-id) + (m3ua-make-registration-status-parameter status) + (m3ua-make-routing-context-parameter (list rc))))))) + (m3ua-make-registration-result-parameter (list (m3ua-make-local-routing-key-identifier-parameter local-rk-id) + (m3ua-make-registration-status-parameter status) + (m3ua-make-routing-context-parameter (list 0))))))) + +;;;(m3ua-make-registration-result-from-routing-key (m3ua-make-routing-key-parameter (list (m3ua-make-local-routing-key-identifier-parameter 3) (m3ua-make-destination-point-code-parameter 4))) 0) + +(define (m3ua-make-reg-rsp-from-reg-req reg-req) + (let ((routing-keys (filter m3ua-routing-key-parameter? (m3ua-get-parameters-of-message reg-req)))) + (m3ua-make-reg-rsp-message + (cons (m3ua-make-registration-result-from-routing-key (car routing-keys) m3ua-successfully-registered-reg-status) + (map (lambda (key) (m3ua-make-registration-result-from-routing-key key m3ua-error-insufficient-resources-reg-status)) + (cdr routing-keys)))))) + +;;;(m3ua-make-reg-rsp-from-reg-req (m3ua-make-reg-req-message (list (m3ua-make-routing-key-parameter (list (m3ua-make-local-routing-key-identifier-parameter 3) (m3ua-make-destination-point-code-parameter 4)))))) + + +(define (m3ua-make-dereg-rsp-from-dereg-req dereg-req) + (let ((rc (bytes->uint32 (list-tail (car (filter m3ua-routing-context-parameter? (m3ua-get-parameters-of-message dereg-req))) + m3ua-parameter-header-length)))) + (m3ua-make-dereg-rsp-message (list (m3ua-make-deregistration-result-parameter + (list (m3ua-make-routing-context-parameter (list rc)) + (m3ua-make-deregistration-status-parameter m3ua-successfully-deregistered-dereg-status))))))) + +;;;(m3ua-make-dereg-rsp-from-dereg-req (m3ua-make-dereg-req-message (list (m3ua-make-routing-context-parameter (list 1 2 3))))) + + + +(define (m3ua-make-simple-reg-rsp-message id status context) + (m3ua-make-reg-rsp-message (list (m3ua-make-registration-result-parameter + (list (m3ua-make-local-routing-key-identifier-parameter id) + (m3ua-make-registration-status-parameter status) + (m3ua-make-routing-context-parameter (list context))))))) +;;; (m3ua-make-simple-reg-rsp-message 1 0 0) + + +(define (m3ua-get-routing-context-from-reg-rsp reg-rsp) + (bytes->uint32 (list-tail (car (filter m3ua-routing-context-parameter? + (m3ua-get-parameters-of-parameter + (car (filter m3ua-registration-result-parameter? (m3ua-get-parameters-of-message reg-rsp)))))) + m3ua-parameter-header-length))) +;;; (m3ua-get-routing-context-from-reg-rsp (m3ua-make-simple-reg-rsp-message 1 2 6)) + + +(define (m3ua-get-error-code-from-message msg) + (m3ua-get-error-code-from-parameter (car (filter m3ua-error-code-parameter? (m3ua-get-parameters msg))))) +;;;(m3ua-get-error-code-from-message (m3ua-make-error-message m3ua-unexpected-message-error-code)) + + +(define (m3ua-get-status-type-from-message msg) + (m3ua-get-status-type-from-parameter (car (filter m3ua-status-parameter? (m3ua-get-parameters msg))))) +;;;(m3ua-get-status-type-from-message (m3ua-make-notify-message 2 3)) + + +(define (m3ua-get-status-info-from-message msg) + (m3ua-get-status-info-from-parameter (car (filter m3ua-status-parameter? (m3ua-get-parameters msg))))) +;;;(m3ua-get-status-info-from-message (m3ua-make-notify-message 2 3)) + + + +;;; +;;; General accessor function for parameters +;;; + +(define m3ua-parameter-tag-offset 0) +(define m3ua-parameter-length-offset 2) +(define m3ua-parameter-value-offset 4) + +(define (m3ua-get-parameter-tag l) + (bytes->uint16 (list-tail l m3ua-parameter-tag-offset))) +;;; (m3ua-get-parameter-tag (m3ua-make-parameter 1 (list 1 2 3))) + +(define (m3ua-get-parameter-length l) + (bytes->uint16 (list-tail l m3ua-parameter-length-offset))) +;;; (m3ua-get-parameter-length (m3ua-make-parameter 1 (list 1 2 3))) + +(define (m3ua-get-parameter-value l) + (list-tail (list-head l (m3ua-get-parameter-length l)) m3ua-parameter-value-offset)) +;;; (m3ua-get-parameter-value (m3ua-make-parameter 1 (list 1 2 3))) + +(define (m3ua-get-parameter-padding l) + (list-tail l (m3ua-get-parameter-length l))) +;;; (m3ua-get-parameter-padding (m3ua-make-parameter 1 (list 1 2 3 4))) + + +;;; +;;; M3UA helper routines +;;; + +(define m3ua-maximum-message-length (expt 2 16)) + +(define (m3ua-connect local-addr local-port remote-addr remote-port) + (let ((s (socket AF_INET SOCK_STREAM IPPROTO_SCTP))) + (catch 'system-error + (lambda () + (bind s AF_INET (inet-aton local-addr) local-port) + (connect s AF_INET (inet-aton remote-addr) remote-port) + (if (defined? 'SCTP_NODELAY) + (setsockopt s IPPROTO_SCTP SCTP_NODELAY 1)) + s) + (lambda (key . args) + (close s))))) + +;;; (m3ua-connect "127.0.0.1" 0 "127.0.0.1" m3ua-port) + +(define (m3ua-accept local-addr local-port) + (let ((s (socket AF_INET SOCK_STREAM IPPROTO_SCTP))) + (catch 'system-error + (lambda () + (bind s AF_INET (inet-aton local-addr) local-port) + (listen s 1) + (let ((ss (car (accept s)))) + (close s) + (if (defined? 'SCTP_NODELAY) + (setsockopt ss IPPROTO_SCTP SCTP_NODELAY 1)) + ss)) + (lambda (key . args) + (close s))))) + + +;;;(m3ua-accept "127.0.0.1" m3ua-port) + +(define (m3ua-send-message socket stream message) + (catch 'system-error + (lambda() + (sctp-sendmsg socket (bytes->string message) (htonl m3ua-ppid) stream 0 0 AF_INET INADDR_ANY 0)) + (lambda (key . args) + 0))) + +(define (m3ua-recv-message socket) + (let ((buffer (make-string m3ua-maximum-message-length))) + (catch 'system-error + (lambda () + (let ((n (recv! socket buffer))) + (string->bytes (substring buffer 0 n)))) + (lambda (key . args) + (list))))) + +;;; (m3ua-recv-message s) +(define (m3ua-recv-message-with-timeout socket seconds) + (let ((buffer (make-string m3ua-maximum-message-length))) + (catch 'system-error + (lambda () + (let ((result (select (list socket) (list) (list) seconds))) + (if (null? (car result)) + (list) + (let ((n (recv! socket buffer))) + (string->bytes (substring buffer 0 n)))))) + (lambda (key . args) + (list))))) + +;;; (m3ua-recv-message-with-timeout s 2) + +(define (m3ua-wait-for-message socket predicate) + (let ((m (m3ua-recv-message socket))) + (if (or (zero? (length m)) (predicate m)) + m + (m3ua-wait-for-message socket predicate)))) + +(define (m3ua-wait-for-message-with-timeout socket predicate seconds) + (let ((m (m3ua-recv-message-with-timeout socket seconds))) + (if (or (zero? (length m)) (predicate m)) + m + (m3ua-wait-for-message-with-timeout socket predicate seconds)))) + +(define (m3ua-version-ok? version) + (= version m3ua-version)) +;;; (m3ua-version-ok? m3ua-version) +;;; (m3ua-version-ok? (+ m3ua-version 1)) + +(define (m3ua-message-class-ok? class rkm-message-class-supported?) + (or (= class m3ua-mgmt-message-class) + (= class m3ua-tfer-message-class) + (= class m3ua-ssnm-message-class) + (= class m3ua-aspsm-message-class) + (= class m3ua-asptm-message-class) + (and rkm-message-class-supported? (= class m3ua-rkm-message-class)))) +;;; (m3ua-message-class-ok? m3ua-mgmt-message-class #t) +;;; (m3ua-message-class-ok? m3ua-rkm-message-class #t) +;;; (m3ua-message-class-ok? m3ua-rkm-message-class #f) +;;; (m3ua-message-class-ok? 1000) + +(define (m3ua-message-type-ok? class type) + (cond + ((= class m3ua-mgmt-message-class) + (or (= type m3ua-err-message-type) + (= type m3ua-ntfy-message-type))) + ((= class m3ua-tfer-message-class) + (or (= type m3ua-data-message-type))) + ((= class m3ua-ssnm-message-class) + (or (= type m3ua-duna-message-type) + (= type m3ua-dava-message-type) + (= type m3ua-daud-message-type) + (= type m3ua-scon-message-type) + (= type m3ua-dupu-message-type) + (= type m3ua-drst-message-type))) + ((= class m3ua-aspsm-message-class) + (or (= type m3ua-aspup-message-type) + (= type m3ua-aspdn-message-type) + (= type m3ua-beat-message-type) + (= type m3ua-aspup-ack-message-type) + (= type m3ua-aspdn-ack-message-type) + (= type m3ua-beat-ack-message-type))) + ((= class m3ua-asptm-message-class) + (or (= type m3ua-aspac-message-type) + (= type m3ua-aspia-message-type) + (= type m3ua-aspac-ack-message-type) + (= type m3ua-aspia-ack-message-type))) + ((= class m3ua-rkm-message-class) + (or (= type m3ua-reg-req-message-type) + (= type m3ua-reg-rsp-message-type) + (= type m3ua-dereg-req-message-type) + (= type m3ua-dereg-rsp-message-type))))) + +;;; (m3ua-message-type-ok? m3ua-aspsm-message-class 7) + +(define (m3ua-check-common-header fd message rkm-message-class-supported?) + (if (not (m3ua-version-ok? (m3ua-get-version message))) + (begin + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-invalid-version-error-code)) + #f) + (if (not (m3ua-message-class-ok? (m3ua-get-message-class message) rkm-message-class-supported?)) + (begin + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-unsupported-message-class-error-code)) + #f) + (if (not (m3ua-message-type-ok? (m3ua-get-message-class message) + (m3ua-get-message-type message))) + (begin + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-unsupported-message-type-error-code)) + #f) + #t)))) + +(define (m3ua-data-message? message) + (and (= (m3ua-get-message-class message) m3ua-tfer-message-class) + (= (m3ua-get-message-type message) m3ua-data-message-type))) +;;; (m3ua-data-message? (m3ua-make-data-message 1 2 3 4 5 6 (list 1 2) (list))) +;;; (m3ua-data-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-error-message? message) + (and (= (m3ua-get-message-class message) m3ua-mgmt-message-class) + (= (m3ua-get-message-type message) m3ua-err-message-type))) +;;; (m3ua-error-message? (m3ua-make-error-message m3ua-unexpected-message-error-code)) +;;; (m3ua-error-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-notify-message? message) + (and (= (m3ua-get-message-class message) m3ua-mgmt-message-class) + (= (m3ua-get-message-type message) m3ua-ntfy-message-type))) +;;; (m3ua-notify-message? (m3ua-make-notify-message m3ua-as-state-change-status-type m3ua-as-inactive)) +;;; (m3ua-notify-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-beat-message? message) + (and (= (m3ua-get-message-class message) m3ua-aspsm-message-class) + (= (m3ua-get-message-type message) m3ua-beat-message-type))) +;;; (m3ua-beat-message? (m3ua-make-beat-message (list 1 2 3))) +;;; (m3ua-beat-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-beat-ack-message? message) + (and (= (m3ua-get-message-class message) m3ua-aspsm-message-class) + (= (m3ua-get-message-type message) m3ua-beat-ack-message-type))) +;;; (m3ua-beat-ack-message? (m3ua-make-beat-ack-message (list 1 2 3))) +;;; (m3ua-beat-ack-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-asp-up-message? message) + (and (= (m3ua-get-message-class message) m3ua-aspsm-message-class) + (= (m3ua-get-message-type message) m3ua-aspup-message-type))) +;;; (m3ua-asp-up-message? (m3ua-make-asp-up-message (list))) +;;; (m3ua-asp-up-message? (m3ua-make-asp-down-message)) + +(define (m3ua-asp-up-ack-message? message) + (and (= (m3ua-get-message-class message) m3ua-aspsm-message-class) + (= (m3ua-get-message-type message) m3ua-aspup-ack-message-type))) +;;; (m3ua-asp-up-ack-message? (m3ua-make-asp-up-ack-message)) +;;; (m3ua-asp-up-ack-message? (m3ua-make-asp-down-message)) + +(define (m3ua-asp-active-message? message) + (and (= (m3ua-get-message-class message) m3ua-asptm-message-class) + (= (m3ua-get-message-type message) m3ua-aspac-message-type))) +;;; (m3ua-asp-active-message? (m3ua-make-asp-active-message (list))) +;;; (m3ua-asp-active-message? (m3ua-make-asp-down-message)) + +(define (m3ua-asp-active-ack-message? message) + (and (= (m3ua-get-message-class message) m3ua-asptm-message-class) + (= (m3ua-get-message-type message) m3ua-aspac-ack-message-type))) +;;; (m3ua-asp-active-ack-message? (m3ua-make-asp-active-ack-message (list))) +;;; (m3ua-asp-active-ack-message? (m3ua-make-asp-down-message)) + +(define (m3ua-asp-down-message? message) + (and (= (m3ua-get-message-class message) m3ua-aspsm-message-class) + (= (m3ua-get-message-type message) m3ua-aspdn-message-type))) +;;; (m3ua-asp-down-message? (m3ua-make-asp-down-message)) +;;; (m3ua-asp-down-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-asp-down-ack-message? message) + (and (= (m3ua-get-message-class message) m3ua-aspsm-message-class) + (= (m3ua-get-message-type message) m3ua-aspdn-ack-message-type))) +;;; (m3ua-asp-down-ack-message? (m3ua-make-asp-down-ack-message)) +;;; (m3ua-asp-down-ack-message? (m3ua-make-asp-up-message (list))) + +(define (m3ua-asp-inactive-message? message) + (and (= (m3ua-get-message-class message) m3ua-asptm-message-class) + (= (m3ua-get-message-type message) m3ua-aspia-message-type))) +;;; (m3ua-asp-inactive-message? (m3ua-make-asp-inactive-message (list))) +;;; (m3ua-asp-inactive-message? (m3ua-make-asp-down-message)) + +(define (m3ua-asp-inactive-ack-message? message) + (and (= (m3ua-get-message-class message) m3ua-asptm-message-class) + (= (m3ua-get-message-type message) m3ua-aspia-ack-message-type))) +;;; (m3ua-asp-inactive-ack-message? (m3ua-make-asp-inactive-ack-message (list))) +;;; (m3ua-asp-inactive-ack-message? (m3ua-make-asp-down-message)) + +(define (m3ua-daud-message? message) + (and (= (m3ua-get-message-class message) m3ua-ssnm-message-class) + (= (m3ua-get-message-type message) m3ua-daud-message-type))) +;;; (m3ua-daud-message? (m3ua-make-daud-message (list))) +;;; (m3ua-daud-message? (m3ua-make-asp-down-message)) + +(define (m3ua-duna-message? message) + (and (= (m3ua-get-message-class message) m3ua-ssnm-message-class) + (= (m3ua-get-message-type message) m3ua-duna-message-type))) +;;; (m3ua-duna-message? (m3ua-make-duna-message (list))) +;;; (m3ua-duna-message? (m3ua-make-asp-down-message)) + +(define (m3ua-dava-message? message) + (and (= (m3ua-get-message-class message) m3ua-ssnm-message-class) + (= (m3ua-get-message-type message) m3ua-dava-message-type))) +;;; (m3ua-dava-message? (m3ua-make-dava-message (list))) +;;; (m3ua-dava-message? (m3ua-make-asp-down-message)) + +(define (m3ua-drst-message? message) + (and (= (m3ua-get-message-class message) m3ua-ssnm-message-class) + (= (m3ua-get-message-type message) m3ua-drst-message-type))) +;;; (m3ua-drst-message? (m3ua-make-drst-message (list))) +;;; (m3ua-drst-message? (m3ua-make-asp-down-message)) + +(define (m3ua-scon-message? message) + (and (= (m3ua-get-message-class message) m3ua-ssnm-message-class) + (= (m3ua-get-message-type message) m3ua-scon-message-type))) +;;; (m3ua-scon-message? (m3ua-make-scon-message (list))) +;;; (m3ua-scon-message? (m3ua-make-asp-down-message)) + +(define (m3ua-reg-req-message? message) + (and (= (m3ua-get-message-class message) m3ua-rkm-message-class) + (= (m3ua-get-message-type message) m3ua-reg-req-message-type))) +;;; (m3ua-reg-req-message? (m3ua-make-reg-req-message (list))) +;;; (m3ua-reg-req-message? (m3ua-make-asp-down-message)) + +(define (m3ua-reg-rsp-message? message) + (and (= (m3ua-get-message-class message) m3ua-rkm-message-class) + (= (m3ua-get-message-type message) m3ua-reg-rsp-message-type))) +;;; (m3ua-reg-rsp-message? (m3ua-make-reg-rsp-message (list))) +;;; (m3ua-reg-rsp-message? (m3ua-make-asp-down-message)) + +(define (m3ua-dereg-req-message? message) + (and (= (m3ua-get-message-class message) m3ua-rkm-message-class) + (= (m3ua-get-message-type message) m3ua-dereg-req-message-type))) +;;; (m3ua-dereg-req-message? (m3ua-make-dereg-req-message (list))) +;;; (m3ua-dereg-req-message? (m3ua-make-asp-down-message)) + +(define (m3ua-dereg-rsp-message? message) + (and (= (m3ua-get-message-class message) m3ua-rkm-message-class) + (= (m3ua-get-message-type message) m3ua-dereg-rsp-message-type))) +;;; (m3ua-dereg-rsp-message? (m3ua-make-dereg-rsp-message (list))) +;;; (m3ua-dereg-rsp-message? (m3ua-make-asp-down-message)) + +(define m3ua-asp-down 0) +(define m3ua-asp-inactive 1) +(define m3ua-asp-active 2) +(define m3ua-asp-reflect-beat 3) +(define m3ua-asp-send-data 4) +(define m3ua-asp-receive-data 5) +(define m3ua-asp-send-reg-req 6) +(define m3ua-asp-send-dereg-req 7) + +(define (m3ua-handle-sgp-message fd state rkm-message-class-supported?) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message rkm-message-class-supported?) + (cond + ((m3ua-beat-message? message) + (m3ua-send-message fd 0 (m3ua-make-message m3ua-aspsm-message-class + m3ua-beat-ack-message-type + (m3ua-get-parameters message))) + (m3ua-handle-sgp-message fd state rkm-message-class-supported?)) + + ((m3ua-asp-up-message? message) + (if (= state m3ua-asp-active) + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-unexpected-message-error-code))) + (m3ua-send-message fd 0 (m3ua-make-asp-up-ack-message)) + (if (not (= state m3ua-asp-inactive)) + (m3ua-send-message fd 0 (m3ua-make-notify-message m3ua-as-state-change-status-type + m3ua-as-inactive))) + (m3ua-handle-sgp-message fd m3ua-asp-inactive rkm-message-class-supported?)) + + ((m3ua-asp-active-message? message) + (if (= state m3ua-asp-down) + (begin + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-unexpected-message-error-code)) + (m3ua-handle-sgp-message fd m3ua-asp-down rkm-message-class-supported?)) + (begin + (m3ua-send-message fd 0 (m3ua-make-asp-active-ack-message (m3ua-get-parameters message))) + (if (not (= state m3ua-asp-active)) + (m3ua-send-message fd 0 (m3ua-make-notify-message m3ua-as-state-change-status-type + m3ua-as-active))) + (m3ua-handle-sgp-message fd m3ua-asp-active rkm-message-class-supported?)))) + + ((m3ua-asp-down-message? message) + (m3ua-send-message fd 0 (m3ua-make-asp-down-ack-message)) + (m3ua-handle-sgp-message fd m3ua-asp-down rkm-message-class-supported?)) + + ((m3ua-asp-inactive-message? message) + (if (= state m3ua-asp-down) + (begin + (m3ua-send-message fd 0 (m3ua-make-asp-down-ack-message)) + (m3ua-handle-sgp-message fd m3ua-asp-down rkm-message-class-supported?)) + (begin + (m3ua-send-message fd 0 (m3ua-make-asp-inactive-ack-message (list))) + (if (= state m3ua-asp-active) + (m3ua-send-message fd 0 (m3ua-make-notify-message m3ua-as-state-change-status-type + m3ua-as-pending))) + (m3ua-handle-sgp-message fd m3ua-asp-inactive rkm-message-class-supported?)))) + ((m3ua-reg-req-message? message) + (if (= state m3ua-asp-inactive) + (m3ua-send-message fd 0 (m3ua-make-reg-rsp-from-reg-req message)) + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-unexpected-message-error-code))) + (m3ua-handle-sgp-message fd state rkm-message-class-supported?)) + ((m3ua-dereg-req-message? message) + (m3ua-send-message fd 0 (m3ua-make-dereg-rsp-from-dereg-req message)) + (m3ua-handle-sgp-message fd state rkm-message-class-supported?)) + (else + (m3ua-send-message fd 0 (m3ua-make-error-message m3ua-unexpected-message-error-code)) + (m3ua-handle-sgp-message fd state rkm-message-class-supported?))))))) + +(define (m3ua-run-sgp port rkm-message-class-supported?) + (let ((fd (m3ua-accept "0.0.0.0" port))) + (m3ua-handle-sgp-message fd m3ua-asp-down rkm-message-class-supported?) + (close fd))) +;;; (m3ua-run-sgp m3ua-port #t) ;;; RKM message class supported +;;; (m3ua-run-sgp m3ua-port #f) ;;; RKM message class not supported + + + + +(define (m3ua-perform-asp-states fd current-state states) + (if (null? states) + (close fd) + (cond + ((= (car states) m3ua-asp-down) + (m3ua-send-message fd 0 (m3ua-make-asp-down-message)) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (if (m3ua-asp-down-ack-message? message) + (m3ua-perform-asp-states fd m3ua-asp-down (cdr states)) + (close fd)) + (close fd))) + (close fd))) + ((= (car states) m3ua-asp-inactive) + (if (= current-state m3ua-asp-down) + (begin + (m3ua-send-message fd 0 (m3ua-make-asp-up-message (list))) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (if (m3ua-asp-up-ack-message? message) + (m3ua-perform-asp-states fd m3ua-asp-inactive (cdr states)) + (close fd)) + (close fd)) + (close fd)))) + (begin + (m3ua-send-message fd 0 (m3ua-make-asp-inactive-message (list))) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (if (m3ua-asp-inactive-ack-message? message) + (m3ua-perform-asp-states fd m3ua-asp-inactive (cdr states)) + (close fd)) + (close fd)) + (close fd)))))) + ((= (car states) m3ua-asp-active) + (m3ua-send-message fd 0 (m3ua-make-asp-active-message (list))) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (if (m3ua-asp-active-ack-message? message) + (m3ua-perform-asp-states fd m3ua-asp-active (cdr states)) + (close fd)) + (close fd)) + (close fd)))) + ((= (car states) m3ua-asp-reflect-beat) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (if (m3ua-beat-message? message) + (begin + (m3ua-send-message fd 0 (m3ua-make-beat-ack-message (m3ua-get-parameter-value (car (m3ua-get-parameters message))))) + (m3ua-perform-asp-states fd current-state (cdr states))) + (m3ua-perform-asp-states fd current-state states)) + (close fd)) + (close fd)))) + ((= (car states) m3ua-asp-send-data) + (m3ua-send-message fd 1 (m3ua-make-data-message opc dpc si ni mp sls ss7-message data-message-parameters)) + (m3ua-perform-asp-states fd current-state (cdr states))) + ((= (car states) m3ua-asp-receive-data) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (m3ua-perform-asp-states fd current-state (cdr states)) + (close fd)) + (close fd)))) + ((= (car states) m3ua-asp-send-reg-req) + (m3ua-send-message fd 0 (m3ua-make-reg-req-message + (list (m3ua-make-routing-key-parameter + (list (m3ua-make-local-routing-key-identifier-parameter 1) + (m3ua-make-destination-point-code-parameter 2)))))) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (m3ua-perform-asp-states fd current-state (cdr states)) + (close fd)) + (close fd)))) + ((= (car states) m3ua-asp-send-dereg-req) + (m3ua-send-message fd 0 (m3ua-make-dereg-req-message (list (m3ua-make-routing-context-parameter (list 1))))) + (let ((message (m3ua-recv-message fd))) + (if (positive? (length message)) + (if (m3ua-check-common-header fd message #t) + (m3ua-perform-asp-states fd current-state (cdr states)) + (close fd)) + (close fd)))) + (else + (error 'wrong-state))))) + +(define (m3ua-run-asp remote-addr states) + (let ((fd (m3ua-connect "0.0.0.0" 0 remote-addr m3ua-port))) + (m3ua-perform-asp-states fd m3ua-asp-down states))) + +(define (m3ua-send-beats local-addr local-port remote-addr remote-port number length) + (let ((fd (m3ua-connect local-addr local-port remote-addr remote-port)) + (beat-message (m3ua-make-beat-message (random-bytes length)))) + (dotimes (n number) + (m3ua-send-message fd 0 beat-message) + (m3ua-recv-message fd)) + (sleep 1) + (close fd))) +;;; (m3ua-send-beats "192.168.1.2" m3ua-port "192.168.1.8" m3ua-port 1000 1000) |