1228 lines
52 KiB
Scheme
1228 lines
52 KiB
Scheme
;;;
|
|
;;; 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)
|