path: root/sua.scm

;;;
;;; Copyright (c) 2011 Michael Tuexen
;;; 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.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR 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: sua.scm,v 1.7 2012/08/25 23:40:33 tuexen Exp $

(define sua-test-result-passed                0)
(define sua-test-result-failed                1)
(define sua-test-result-unknown               2)
(define sua-test-result-not-applicable      253)

;;; This is the IANA registered PPID for SUA in host byte order
(define sua-ppid                              4)

;;; This is the IANA registered port for SUA
(define sua-port                          14001)

;;; Constants for the message classes
(define sua-mgmt-message-class                0)
(define sua-ssnm-message-class                2)
(define sua-aspsm-message-class               3)
(define sua-asptm-message-class               4)
(define sua-connection-less-message-class     7)
(define sua-connection-oriented-message-class 8)
(define sua-rkm-message-class                 9)
(define sua-reserved-message-class           99)

;;; Constants for the message types
;;; MGMT messages
(define sua-err-message-type                  0)
(define sua-ntfy-message-type                 1)

;;; SSNM messages
(define sua-duna-message-type                 1)
(define sua-dava-message-type                 2)
(define sua-daud-message-type                 3)
(define sua-scon-message-type                 4)
(define sua-dupu-message-type                 5)
(define sua-drst-message-type                 6)

;;; ASPSM messages
(define sua-aspup-message-type                1)
(define sua-aspdn-message-type                2)
(define sua-beat-message-type                 3)
(define sua-aspup-ack-message-type            4)
(define sua-aspdn-ack-message-type            5)
(define sua-beat-ack-message-type             6)
(define sua-reserved-aspsm-message-type       7)

;;; ASPTM messages
(define sua-aspac-message-type                1)
(define sua-aspia-message-type                2)
(define sua-aspac-ack-message-type            3)
(define sua-aspia-ack-message-type            4)
(define sua-reserved-asptm-message-type       5)

;;; RKM messages
(define sua-reg-req-message-type              1)
(define sua-reg-rsp-message-type              2)
(define sua-dereg-req-message-type            3)
(define sua-dereg-rsp-message-type            4)
(define sua-reserved-rkm-message-type         5)

;;; CL messages
(define sua-cldt-message-type                 1)
(define sua-cldr-message-type                 2)
(define sua-reserved-cl-message-type          3)

;;; CO message
(define sua-core-message-type                 1)
(define sua-coak-message-type                 2)
(define sua-coref-message-type                3)
(define sua-relre-message-type                4)
(define sua-relco-message-type                5)
(define sua-resco-message-type                6)
(define sua-resre-message-type                7)
(define sua-codt-message-type                 8)
(define sua-coda-message-type                 9)
(define sua-coerr-message-type               10)
(define sua-coit-message-type                11)
(define sua-reserved-co-message-type         12)

;;; Constant for the protocol version
(define sua-version                           1)

;;; Constant for reserved
(define sua-reserved                          0)

;;;
;;; Creator functions for messages
;;;

(define (sua-make-common-header version reserved class type length)
  (append (uint8->bytes version)
	  (uint8->bytes reserved)
	  (uint8->bytes class)
	  (uint8->bytes type)
	  (uint32->bytes length)))

;;;(sua-make-common-header 1 2 3 4 5)
;;;(sua-make-common-header sua-version sua-reserved sua-connection-less-message-class sua-cldt-message-type 16)

(define (sua-increment-version l)
  (if (positive? (length l))
      (cons (+ (car l) 1) (cdr l))
      (list)))
;;;(sua-increment-version (list 1 2 3))
;;;(sua-increment-version (list))

;;;
;;; Creator functions for parameters
;;;

(define sua-parameter-header-length 4)
(define sua-common-header-length 8)
(define sua-data-parameter-header-length 16)

(define (sua-number-of-padding-bytes l)
  (remainder (- 4 (remainder l 4)) 4))
;;; (sua-number-of-padding-bytes 0)
;;; (sua-number-of-padding-bytes 1)
;;; (sua-number-of-padding-bytes 2)
;;; (sua-number-of-padding-bytes 3)

(define (sua-add-padding l)
  (+ l (sua-number-of-padding-bytes l)))
;;; (sua-add-padding 2)

(define (sua-padding data)
  (zero-bytes (sua-number-of-padding-bytes (length data))))
;;;(sua-padding (list 1 2 3 4 5))

(define (sua-make-parameter tag value)
  (append (uint16->bytes tag)
	  (uint16->bytes (+ (length value) sua-parameter-header-length))
	  value
	  (sua-padding value)))

(define (sua-make-random-parameter l)
  (sua-make-parameter (random 2^16) (random-bytes l)))
;;;(sua-make-random-parameter 10)

(define (sua-add-parameter parameter list)
  (cons parameter (remove (lambda(p) (equal? (sua-get-parameter-tag p)
					     (sua-get-parameter-tag parameter)))
			  list)))
;;;(sua-add-parameter (sua-make-info-string-parameter "Hello1") (list (sua-make-correlation-id-parameter 34)))
;;;(sua-add-parameter (sua-make-info-string-parameter "Hello1") (list (sua-make-correlation-id-parameter 34) (sua-make-info-string-parameter "Hello")))

(define (sua-make-message class type parameters)
  (append (sua-make-common-header sua-version
				  sua-reserved
				  class
				  type
				  (+ sua-common-header-length (apply + (map length parameters))))
	  (apply append parameters)))

(define sua-info-string-tag                  #x0004)
(define sua-routing-context-tag              #x0006)
(define sua-diagnostic-info-tag              #x0007)
(define sua-heartbeat-data-tag               #x0009)
(define sua-traffic-mode-type-tag            #x000b)
(define sua-error-code-tag                   #x000c)
(define sua-status-tag                       #x000d)
(define sua-asp-identifier-tag               #x0011)
(define sua-affected-point-code-tag          #x0012)
(define sua-correlation-id-tag               #x0013)
(define sua-registration-result-tag          #x0014)
(define sua-deregistration-result-tag        #x0015)
(define sua-registration-status-tag          #x0016)
(define sua-deregistration-status-tag        #x0017)
(define sua-local-routing-key-identifier-tag #x0018)

(define sua-ss7-hop-counter-tag              #x0101)
(define sua-source-address-tag               #x0102)
(define sua-destination-address-tag          #x0103)
(define sua-source-reference-number-tag      #x0104)
(define sua-destination-reference-number-tag #x0105)
(define sua-sccp-cause-tag                   #x0106)
(define sua-sequence-number-tag              #x0107)
(define sua-receive-sequence-number-tag      #x0108)
(define sua-asp-capabilities-tag             #x0109)
(define sua-credit-tag                       #x010a)
(define sua-data-tag                         #x010b)
(define sua-user-cause-tag                   #x010c)
(define sua-network-appearance-tag           #x010d)
(define sua-routing-key-tag                  #x010e)
(define sua-drn-label-tag                    #x010f)
(define sua-tid-label-tag                    #x0110)
(define sua-address-range-tag                #x0111)
(define sua-smi-tag                          #x0112)
(define sua-importance-tag                   #x0113)
(define sua-message-priority-tag             #x0114)
(define sua-protocol-class-tag               #x0115)
(define sua-sequence-control-tag             #x0116)
(define sua-segmentation-tag                 #x0117)
(define sua-congestion-level-tag             #x0118)

(define sua-global-title-tag                 #x8001)
(define sua-point-code-tag                   #x8002)
(define sua-subsystem-number-tag             #x8003)
(define sua-ipv4-address-tag                 #x8004)
(define sua-hostname-tag                     #x8005)
(define sua-ipv6-address-tag                 #x8006)

(define (sua-make-info-string-parameter string)
  (sua-make-parameter sua-info-string-tag (string->bytes string)))
;;; (sua-make-info-string-parameter "Hello")

(define (sua-make-routing-context-parameter contexts)
  (sua-make-parameter sua-routing-context-tag (apply append (map uint32->bytes contexts))))
;;; (sua-make-routing-context-parameter (list 1024))
;;; (sua-make-routing-context-parameter (list))
;;; (sua-make-routing-context-parameter (list 1024 4 5 6))

(define (sua-make-diagnostic-info-parameter info)
  (sua-make-parameter sua-diagnostic-info-tag info))
;;; (sua-make-diagnostic-info-parameter (list 1 2 3 4 5))

(define (sua-make-heartbeat-data-parameter data)
  (sua-make-parameter sua-heartbeat-data-tag data))
;;; (sua-make-heartbeat-data-parameter (string->bytes "SUA rocks"))

(define sua-traffic-mode-type-override  1)
(define sua-traffic-mode-type-loadshare 2)
(define sua-traffic-mode-type-broadcast 3)
(define sua-traffic-mode-type-invalid   4)

(define (sua-make-traffic-mode-type-parameter mode)
  (sua-make-parameter sua-traffic-mode-type-tag (uint32->bytes mode)))
;;; (sua-make-traffic-mode-type-parameter sua-traffic-mode-type-override)

(define sua-invalid-version-error-code               #x0001)
(define sua-unsupported-message-class-error-code     #x0003)
(define sua-unsupported-message-type-error-code      #x0004)
(define sua-unsupported-traffic-mode-type-error-code #x0005)
(define sua-unexpected-message-error-code            #x0006)
(define sua-protocol-error-error-code                #x0007)
(define sua-invalid-stream-identifier-error-code     #x0009)
(define sua-refused-management-blocking-error-code   #x000d)
(define sua-asp-identifier-required-error-code       #x000e)
(define sua-invalid-parameter-value-error-code       #x0011)
(define sua-parameter-field-error-error-code         #x0012)
(define sua-unexpected-parameter-error-code          #x0013)
(define sua-destination-status-unknown-error-code    #x0014)
(define sua-invalid-network-appearance-error-code    #x0015)
(define sua-missing-parameter-error-code             #x0016)
(define sua-invalid-routing-context-error-code       #x0019)
(define sua-no-configured-as-for-asp-error-code      #x001a)
(define sua-subsystem-status-unknown-error-code      #x001b)
(define sua-invalid-loadsharing-label-error-code     #x001c)

(define (sua-make-error-code-parameter code)
  (sua-make-parameter sua-error-code-tag (uint32->bytes code)))
;;; (sua-make-error-code-parameter sua-protocol-error-error-code)

(define (sua-get-error-code-from-parameter p)
  (bytes->uint32 (sua-get-parameter-value p)))
;;;(sua-get-error-code-from-parameter (sua-make-error-code-parameter sua-protocol-error-error-code))

(define sua-as-state-change-status-type 1)
(define sua-other-status-type           2)

(define sua-as-inactive                 2)
(define sua-as-active                   3)
(define sua-as-pending                  4)

(define sua-insufficient-resources      1)
(define sua-alternate-asp-active        2)
(define sua-asp-failure                 3)

(define (sua-make-status-parameter type info)
  (sua-make-parameter sua-status-tag
		      (append (uint16->bytes type)
			      (uint16->bytes info))))
;;; (sua-make-status-parameter 2 3)

(define (sua-get-status-type-from-parameter l)
  (bytes->uint16 (sua-get-parameter-value l)))
;;; (sua-get-status-type-from-parameter (sua-make-status-parameter 2 3))

(define (sua-get-status-info-from-parameter l)
  (bytes->uint16  (list-tail (sua-get-parameter-value l) 2)))
;;;  (sua-get-status-info-from-parameter (sua-make-status-parameter 2 3))

(define (sua-make-asp-id-parameter aid)
  (sua-make-parameter sua-asp-identifier-tag (uint32->bytes aid)))
;;; (sua-make-asp-id-parameter 1024)

(define (sua-make-affected-point-code-parameter mask-pc-pair-list)
  (sua-make-parameter sua-affected-point-code-tag
		      (apply append (map (lambda (x)
					   (append (uint8->bytes (car x))
						   (uint24->bytes (cadr x))))
					 mask-pc-pair-list))))
;;; (sua-make-affected-point-code-parameter (list (list 0 34) (list 255 89)))

(define (sua-make-correlation-id-parameter id)
  (sua-make-parameter sua-correlation-id-tag (uint32->bytes id)))
;;; (sua-make-correlation-id-parameter 1024)

(define (sua-make-registration-result-parameter parameterlist)
  (sua-make-parameter sua-registration-result-tag (apply append parameterlist)))
;;; (sua-make-registration-result-parameter (list (sua-make-local-routing-key-identifier-parameter 1234) (sua-make-registration-status-parameter sua-successfully-registered-reg-status) (sua-make-routing-context-parameter (list 12))))

(define (sua-make-deregistration-result-parameter parameterlist)
  (sua-make-parameter sua-deregistration-result-tag (apply append parameterlist)))
;;; (sua-make-deregistration-result-parameter (list (sua-make-routing-context-parameter (list 12)) (sua-make-deregistration-status-parameter sua-successfully-deregistered-dereg-status)))

(define sua-successfully-registered-reg-status                          0)
(define sua-error-unknown-reg-status                                    1)
(define sua-error-invalid-destination-address-reg-status                2)
(define sua-error-invalid-network-appearance-reg-status                 3)
(define sua-error-invalid-routing-key-reg-status                        4)         
(define sua-error-permission-denied-reg-status                          5)
(define sua-error-cannot-support-unique-routing-reg-status              6)
(define sua-error-routing-key-not-currently-provisioned-reg-status      7)
(define sua-error-insufficient-resources-reg-status                     8)
(define sua-error-unsupported-rk-parameter-field-reg-status             9)
(define sua-error-unsupported-invalid-traffic-handling-mode-reg-status 10)
(define sua-error-routing-key-change-refused-reg-status                11)
(define sua-error-routing-key-already-registered-req-status            12)

(define (sua-make-registration-status-parameter status)
  (sua-make-parameter sua-registration-status-tag (uint32->bytes status)))
;;; (sua-make-registration-status-parameter 123)

(define sua-successfully-deregistered-dereg-status                      0)
(define sua-error-unknown-dereg-status                                  1)
(define sua-error-invalid-routing-context-dereg-status                  2)
(define sua-error-permission-denied-dereg-status                        3)
(define sua-error-not-registered-dereg-status                           4)
(define sua-error-asp-currently-active-for-routing-context-dereg-status 5)

(define (sua-make-deregistration-status-parameter status)
  (sua-make-parameter sua-deregistration-status-tag (uint32->bytes status)))
;;; (sua-make-deregistration-status-parameter 123)

(define (sua-make-local-routing-key-identifier-parameter id)
  (sua-make-parameter sua-local-routing-key-identifier-tag (uint32->bytes id)))
;;; (sua-make-local-routing-key-identifier-parameter 234)

(define (sua-make-ss7-hop-counter-parameter counter)
  (sua-make-parameter sua-ss7-hop-counter-tag (append (uint24->bytes 0)
						      (uint8->bytes counter))))
;;; (sua-make-ss7-hop-counter-parameter 4)

(define sua-reserved-routing-indicator                  0)
(define sua-route-on-gt-indicator                       1)
(define sua-route-on-ssn-and-pc-indicator               2)
(define sua-route-on-hostname-indicator                 3)
(define sua-route-on-ssn-and-ip-address-indicator       4)

(define sua-address-indicator-ssn-mask #b0000000000000001)
(define sua-address-indicator-pc-mask  #b0000000000000010)
(define sua-address-indicator-gt-mask  #b0000000000000100)

(define (sua-make-source-address-parameter routing-indicator address-indicator parameterlist)
  (sua-make-parameter sua-source-address-tag (append (uint16->bytes routing-indicator)
						     (uint16->bytes address-indicator)
						     (apply append parameterlist))))
;;; (sua-make-source-address-parameter sua-route-on-gt-indicator sua-address-indicator-gt-mask (list))

(define (sua-make-global-title-parameter gti translation-type numbering-plan nature-of-address gt)
  (sua-make-parameter sua-global-title-tag (append (uint24->bytes 0)
						   (uint8->bytes gti)
						   (uint8->bytes (length gt))
						   (uint8->bytes translation-type)
						   (uint8->bytes numbering-plan)
						   (uint8->bytes nature-of-address)
						   gt
						   (sua-padding gt))))
;;; (sua-make-global-title-parameter 1 1 1 2 (list 3 4))

(define (sua-make-point-code-parameter pc)
  (sua-make-parameter sua-point-code-tag (uint32->bytes pc)))
;;; (sua-make-point-code-parameter 5)

(define (sua-make-subsystem-number-parameter ssn)
  (sua-make-parameter sua-subsystem-number-tag (append (uint24->bytes 0)
						 (uint8->bytes ssn))))
;;; (sua-make-subsystem-number-parameter 5)

(define (sua-make-ipv4-address-parameter addr)
  (sua-make-parameter sua-ipv4-address-tag (string->bytes addr)))
;;; (sua-make-ipv4-address-parameter "127.0.0.1")
;;; Do they mean binary format?

(define (sua-make-ipv6-address-parameter addr)
  (sua-make-parameter sua-ipv6-address-tag (string->bytes addr)))
;;; (sua-make-ipv6-address-parameter "::1")
;;; Do they mean binary format?

(define (sua-make-hostname-parameter addr)
  (sua-make-parameter sua-hostname-tag (append (string->bytes addr)
					       (list 0))))
;;; (sua-make-hostname-parameter "sctp.fh-muenster.de")

(define (sua-make-destination-address-parameter routing-indicator address-indicator parameterlist)
  (sua-make-parameter sua-destination-address-tag (append (uint16->bytes routing-indicator)
							  (uint16->bytes address-indicator)
							  (apply append parameterlist))))
;;; (sua-make-destination-address-parameter sua-route-on-gt-indicator sua-address-indicator-gt-mask (list))

(define (sua-make-source-reference-number-parameter ref)
  (sua-make-parameter sua-source-reference-number-tag (uint32->bytes ref)))
;;; (sua-make-source-reference-number-parameter 5)

(define (sua-make-destination-reference-number-parameter ref)
  (sua-make-parameter sua-destination-reference-number-tag (uint32->bytes ref)))
;;; (sua-make-destination-reference-number-parameter 5)

(define sua-return-cause-type       1)
(define sua-refusal-cause-type      2)
(define sua-release-cause-type      3)
(define sua-reset-cause-type        4)
(define sua-error-cause-type        5)

(define (sua-make-sccp-cause-parameter type value)
  (sua-make-parameter sua-sccp-cause-tag (append (uint16->bytes 0)
						 (uint8->bytes type)
						 (uint8->bytes value))))
;;; (sua-make-sccp-cause-parameter sua-release-cause-type 1)

(define (sua-make-sequnce-number-parameter rec-num m-bit sent-num)
  (sua-make-parameter sua-sequence-number-tag (append (uint16->bytes 0)
						      (uint8->bytes (+ (* 2 rec-num) m-bit))
						      (uint8->bytes sent-num))))
;;; (sua-make-sequnce-number-parameter 5 1 9)

(define (sua-make-receive-sequence-number-parameter rec-num)
  (sua-make-parameter sua-receive-sequence-number-tag (append (uint24->bytes 0)
							      (uint8->bytes (* 2 rec-num)))))
;;; (sua-make-receive-sequence-number-parameter 4)

(define sua-protocol-class-0-flag #b00000001)
(define sua-protocol-class-1-flag #b00000010)
(define sua-protocol-class-2-flag #b00000100)
(define sua-protocol-class-3-flag #b00001000)

(define sua-no-interworking         0)
(define sua-asp-interworking        1)
(define sua-sg-interworking         2)
(define sua-relay-node-interworking 3)

(define (sua-make-asp-capabilities-parameter flags interworking)
  (sua-make-parameter sua-asp-capabilities-tag (append (uint16->bytes 0)
						       (uint8->bytes flags)
						       (uint8->bytes interworking))))
;;; (sua-make-asp-capabilities-parameter (logior sua-protocol-class-1-flag sua-protocol-class-2-flag) sua-sg-interworking)

(define (sua-make-credit-parameter credit)
  (sua-make-parameter sua-credit-tag (append (uint24->bytes 24)
					     (uint8->bytes credit))))
;;; (sua-make-credit-parameter 5)

(define (sua-make-data-parameter data)
  (sua-make-parameter sua-data-tag data))
;;; (sua-make-data-parameter (list 1 2 3))

(define sua-remote-sccp-unavailable  0)
(define sua-remote-sccp-unequipped   1)
(define sua-remote-sccp-inaccessible 2)

(define (sua-make-user-cause-parameter user cause)
  (sua-make-parameter sua-user-cause-tag (append (uint16->bytes cause)
						 (uint16->bytes user))))
;;; (sua-make-user-cause-parameter 3 sua-remote-sccp-inaccessible)

(define (sua-make-network-appearance-parameter appearance)
  (sua-make-parameter sua-network-appearance-tag (uint32->bytes appearance)))
;;; (sua-make-network-appearance-parameter 3)

(define (sua-make-routing-key-parameter local-routing-key-id parameterlist)
  (sua-make-parameter sua-routing-key-tag (append (sua-make-local-routing-key-identifier-parameter local-routing-key-id)
						  (apply append parameterlist))))
;;; (sua-make-routing-key-parameter 5 (list))

(define (sua-make-drn-label-parameter start end label)
  (sua-make-parameter sua-drn-label-tag (append (uint8->bytes start)
						(uint8->bytes end)
						(uint16->bytes label))))
;;; (sua-make-drn-label-parameter 2 3 4)

(define (sua-make-tid-label-parameter start end label)
  (sua-make-parameter sua-tid-label-tag (append (uint8->bytes start)
						(uint8->bytes end)
						(uint16->bytes label))))
;;; (sua-make-tid-label-parameter 2 3 4)

(define (sua-make-address-range-parameter parameterlist)
  (sua-make-parameter sua-address-range-tag (apply append parameterlist)))
;;; (sua-make-address-range-parameter (list))

(define sua-reserved-smi   #x00)
(define sua-solitary-smi   #x01)
(define sua-duplicated-smi #x02)
(define sua-triplicated    #x03)
(define sua-quadruplicated #x04)
(define sua-unspecified    #xff)

(define (sua-make-smi-parameter smi)
  (sua-make-parameter sua-smi-tag (append (uint24->bytes 0)
					  (uint8->bytes smi))))
;;; (sua-make-smi-parameter sua-solitary-smi)

(define (sua-make-importance-parameter importance)
  (sua-make-parameter sua-importance-tag (append (uint24->bytes 0)
						 (uint8->bytes importance))))
;;; (sua-make-importance-parameter 4)

(define (sua-make-message-priority-parameter priority)
  (sua-make-parameter sua-message-priority-tag (append (uint24->bytes 0)
						       (uint8->bytes priority))))
;;; (sua-make-message-priority-parameter 4)

(define sua-protocol-class-0 0)
(define sua-protocol-class-1 1)
(define sua-protocol-class-2 2)
(define sua-protocol-class-3 3)

(define (sua-make-protocol-class-parameter class return-on-error)
  (sua-make-parameter sua-protocol-class-tag (append (uint24->bytes 0)
						     (uint8->bytes (if return-on-error
								       (logior #b10000000 class)
								       class)))))
;;; (sua-make-protocol-class-parameter sua-protocol-class-1 #f)

(define (sua-make-sequence-control-parameter seq)
  (sua-make-parameter sua-sequence-control-tag (uint32->bytes seq)))
;;; (sua-make-sequence-control-parameter 3)

(define (sua-make-segmentation-parameter first num-remaining reference)
  (sua-make-parameter sua-segmentation-tag (append (uint8->bytes (if first
								     (logior #b10000000 num-remaining)
								     num-remaining))
						   (uint24->bytes reference))))
;;; (sua-make-segmentation-parameter #t 5 1)

(define sua-no-congestion-level 0)
(define sua-congestion-level-1  1)
(define sua-congestion-level-2  2)
(define sua-congestion-level-3  3)

(define (sua-make-congestion-level-parameter level)
  (sua-make-parameter sua-congestion-level-tag (append (uint24->bytes 0)
						       (uint8->bytes level))))
;;; (sua-make-congestion-level-parameter sua-congestion-level-2)

;;;------------------------------------------------------------------
;;; Parameter Predicates
;;;------------------------------------------------------------------

(define (sua-error-code-parameter? l)
  (= (sua-get-parameter-tag l) sua-error-code-tag))

(define (sua-status-parameter? l)
  (= (sua-get-parameter-tag l) sua-status-tag))

(define (sua-routing-key-parameter? l)
  (= (sua-get-parameter-tag l) sua-routing-key-tag))

(define (sua-local-routing-key-identifier-parameter? l)
  (= (sua-get-parameter-tag l) sua-local-routing-key-identifier-tag))

(define (sua-routing-context-parameter? l)
  (= (sua-get-parameter-tag l) sua-routing-context-tag))

(define (sua-registration-result-parameter? l)
  (= (sua-get-parameter-tag l) sua-registration-result-tag))

;;;------------------------------------------------------------------
;;; Message Contructors
;;;------------------------------------------------------------------

(define (sua-make-error-message code)
  (sua-make-message sua-mgmt-message-class
		    sua-err-message-type
		    (list (sua-make-error-code-parameter code))))
;;; (sua-make-error-message sua-no-configured-as-for-asp-error-code)

(define (sua-make-notify-message type info)
  (sua-make-message sua-mgmt-message-class
		    sua-ntfy-message-type
		    (list (sua-make-status-parameter type info))))
;;; (sua-make-notify-message sua-as-state-change-status-type sua-as-inactive)

(define (sua-make-duna-message parameters)
  (sua-make-message sua-ssnm-message-class
		    sua-duna-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-duna-message (list))

(define (sua-make-dava-message parameters)
  (sua-make-message sua-ssnm-message-class
		    sua-dava-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-dava-message (list))

(define (sua-make-daud-message parameters)
  (sua-make-message sua-ssnm-message-class
		    sua-daud-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-daud-message (list))

(define (sua-make-scon-message parameters)
  (sua-make-message sua-ssnm-message-class
		    sua-scon-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-scon-message (list))

(define (sua-make-dupu-message parameters)
  (sua-make-message sua-ssnm-message-class
		    sua-dupu-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-dupu-message (list))

(define (sua-make-drst-message parameters)
  (sua-make-message sua-ssnm-message-class
		    sua-drst-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-drst-message (list))

(define (sua-make-beat-message data)
  (sua-make-message sua-aspsm-message-class
		    sua-beat-message-type
		    (list (sua-make-heartbeat-data-parameter data))))
;;; (sua-make-beat-message (string->bytes "SUA rocks"))

(define (sua-make-beat-ack-message data)
  (sua-make-message sua-aspsm-message-class
		    sua-beat-ack-message-type
		    (list (sua-make-heartbeat-data-parameter data))))
;;; (sua-make-beat-ack-message (string->bytes "SUA rocks"))

(define (sua-make-asp-up-message parameters)
  (sua-make-message sua-aspsm-message-class
		    sua-aspup-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-asp-up-message (list))

(define (sua-make-asp-down-message)
  (sua-make-message sua-aspsm-message-class
		    sua-aspdn-message-type
		    (list (sua-make-info-string-parameter "SUA rocks"))))
;;; (sua-make-asp-down-message)

(define (sua-make-asp-up-ack-message)
  (sua-make-message sua-aspsm-message-class
		    sua-aspup-ack-message-type
		    (list (sua-make-info-string-parameter "SUA rocks"))))
;;; (sua-make-asp-up-ack-message)

(define (sua-make-asp-down-ack-message)
  (sua-make-message sua-aspsm-message-class
		    sua-aspdn-ack-message-type
		    (list (sua-make-info-string-parameter "SUA rocks"))))
;;; (sua-make-asp-down-ack-message)

(define (sua-make-asp-active-message parameters)
  (sua-make-message sua-asptm-message-class
		    sua-aspac-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-asp-active-message (list (sua-make-routing-context-parameter (list 3))))

(define (sua-make-asp-active-ack-message parameters)
  (sua-make-message sua-asptm-message-class
		    sua-aspac-ack-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-asp-active-ack-message (list))

(define (sua-make-asp-inactive-message parameters)
  (sua-make-message sua-asptm-message-class
		    sua-aspia-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-asp-inactive-message (list))

(define (sua-make-asp-inactive-ack-message parameters)
  (sua-make-message sua-asptm-message-class
		    sua-aspia-ack-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-asp-inactive-ack-message (list))

(define (sua-make-reg-req-message parameters)
  (sua-make-message sua-rkm-message-class
		    sua-reg-req-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-reg-req-message (list))

(define (sua-make-reg-rsp-message parameters)
  (sua-make-message sua-rkm-message-class
		    sua-reg-rsp-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-reg-rsp-message (list))

(define (sua-make-dereg-req-message parameters)
  (sua-make-message sua-rkm-message-class
		    sua-dereg-req-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-dereg-req-message (list))

(define (sua-make-dereg-rsp-message parameters)
  (sua-make-message sua-rkm-message-class
		    sua-dereg-rsp-message-type
		    (sua-add-parameter (sua-make-info-string-parameter "SUA rocks") parameters)))
;;; (sua-make-dereg-rsp-message (list))

(define (sua-make-cldt-message parameters)
  (sua-make-message sua-connection-less-message-class
		    sua-cldt-message-type
		    parameters))
;;; (sua-make-cldt-message (list))

(define (sua-make-cldr-message parameters)
  (sua-make-message sua-connection-less-message-class
		    sua-cldr-message-type
		    parameters))
;;; (sua-make-cldr-message (list))

(define (sua-make-core-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-core-message-type
		    parameters))
;;; (sua-make-core-message (list))

(define (sua-make-coak-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-coak-message-type
		    parameters))
;;; (sua-make-coak-message (list))

(define (sua-make-coref-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-coref-message-type
		    parameters))
;;; (sua-make-coref-message (list))

(define (sua-make-relre-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-relre-message-type
		    parameters))
;;; (sua-make-relre-message (list))

(define (sua-make-relco-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-relco-message-type
		    parameters))
;;; (sua-make-relco-message (list))

(define (sua-make-resco-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-resco-message-type
		    parameters))
;;; (sua-make-resco-message (list))

(define (sua-make-resre-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-resre-message-type
		    parameters))
;;; (sua-make-resre-message (list))

(define (sua-make-codt-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-codt-message-type
		    parameters))
;;; (sua-make-codt-message (list))

(define (sua-make-coda-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-coda-message-type
		    parameters))
;;; (sua-make-core-message (list))

(define (sua-make-coerr-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-coerr-message-type
		    parameters))
;;; (sua-make-coerr-message (list))

(define (sua-make-coit-message parameters)
  (sua-make-message sua-connection-oriented-message-class
		    sua-coit-message-type
		    parameters))
;;; (sua-make-coit-message (list))

;;;
;;; General accessor functions for messages
;;;

(define (sua-get-common-header l)
  (list-head l sua-common-header-length))
;;; (sua-get-common-header (sua-make-asp-up-message (list)))

(define sua-version-offset        0)
(define sua-reserved-offset       1)
(define sua-message-class-offset  2)
(define sua-message-type-offset   3)
(define sua-message-length-offset 4)

(define (sua-get-version l)
  (bytes->uint8 (list-tail l sua-version-offset)))

;;; (define hb (sua-make-beat-message (string->bytes "SUA rocks")))
;;; (sua-get-version hb)

(define (sua-get-reserved l)
  (bytes->uint8 (list-tail l sua-reserved-offset)))
;;; (sua-get-reserved hb)

(define (sua-get-message-class l)
  (bytes->uint8 (list-tail l sua-message-class-offset)))
;;; (sua-get-message-class hb)

(define (sua-get-message-type l)
  (bytes->uint8 (list-tail l sua-message-type-offset)))
;;; (sua-get-message-type hb)

(define (sua-get-message-length l)
  (bytes->uint32 (list-tail l sua-message-length-offset)))
;;; (sua-get-message-length hb)

(define (sua-get-parameters-1 l)
  (if (>= (length l) sua-parameter-header-length)
      (let ((parameter-length (sua-add-padding (sua-get-parameter-length l))))
	(cons (list-head l parameter-length)
	      (sua-get-parameters-1 (list-tail l parameter-length))))
      (list)))

(define (sua-get-parameters-of-message l)
  (if (>= (length l) sua-common-header-length)
      (sua-get-parameters-1 (list-tail l sua-common-header-length))
      (list)))
;;; (sua-get-parameters-of-message (sua-make-beat-message (string->bytes "SUA rocks")))
;;; (sua-get-parameters-of-message (list 2 2))

(define sua-get-parameters sua-get-parameters-of-message)

(define (sua-get-parameters-of-parameter l)
  (if (>= (length l) sua-common-header-length)
      (sua-get-parameters-1 (list-tail l sua-parameter-header-length))
      (list)))
;;; (sua-get-parameters-of-parameter (sua-make-routing-key-parameter 3 (list (sua-make-local-routing-key-identifier-parameter 3) (sua-make-correlation-id-parameter 4))))

(define (sua-make-registration-result-from-routing-key key status)
  (let ((local-rk-id (bytes->uint32 (list-tail (car (filter sua-local-routing-key-identifier-parameter?
							    (sua-get-parameters-of-parameter key)))
					       sua-parameter-header-length))))
    (if (= status sua-successfully-registered-reg-status)
	(let ((routing-contexts (filter sua-routing-context-parameter? (sua-get-parameters-of-parameter key))))
	  (if (null? routing-contexts)
	      (sua-make-registration-result-parameter (list (sua-make-local-routing-key-identifier-parameter local-rk-id)
							    (sua-make-registration-status-parameter status)
							    (sua-make-routing-context-parameter (list tester-rc-valid))))
	      (let ((rc (bytes->uint32 (list-tail routing-contexts) sua-parameter-header-length)))
	      	(sua-make-registration-result-parameter (list (sua-make-local-routing-key-identifier-parameter local-rk-id)
							      (sua-make-registration-status-parameter status)
							      (sua-make-routing-context-parameter (list rc)))))))
	(sua-make-registration-result-parameter (list (sua-make-local-routing-key-identifier-parameter local-rk-id)
						      (sua-make-registration-status-parameter status)
						      (sua-make-routing-context-parameter (list 0)))))))

;;; (sua-make-registration-result-from-routing-key (sua-make-routing-key-parameter 1 (list (sua-make-local-routing-key-identifier-parameter 3) (sua-make-correlation-id-parameter 4))) 0)

(define (sua-make-reg-rsp-from-reg-req reg-req)
  (let ((routing-keys (filter sua-routing-key-parameter? (sua-get-parameters-of-message reg-req))))
    (sua-make-reg-rsp-message
     (cons (sua-make-registration-result-from-routing-key (car routing-keys) sua-successfully-registered-reg-status)
	   (map (lambda (key) (sua-make-registration-result-from-routing-key key sua-error-insufficient-resources-reg-status))
		(cdr routing-keys))))))
;;; (sua-make-reg-rsp-from-reg-req (sua-make-reg-req-message (list (sua-make-routing-key-parameter 1 (list (sua-make-local-routing-key-identifier-parameter 3) (sua-make-correlation-id-parameter 4))))))

(define (sua-make-dereg-rsp-from-dereg-req dereg-req)
  (let ((rc (bytes->uint32 (list-tail (car (filter sua-routing-context-parameter? (sua-get-parameters-of-message dereg-req)))
				      sua-parameter-header-length))))
    (sua-make-dereg-rsp-message (list (sua-make-deregistration-result-parameter
				       (list (sua-make-routing-context-parameter (list rc))
					     (sua-make-deregistration-status-parameter sua-successfully-deregistered-dereg-status)))))))
;;; (sua-make-dereg-rsp-from-dereg-req (sua-make-dereg-req-message (list (sua-make-routing-context-parameter (list 1 2 3)))))

(define (sua-make-simple-reg-rsp-message id status context)
  (sua-make-reg-rsp-message (list (sua-make-registration-result-parameter
				    (list (sua-make-local-routing-key-identifier-parameter id)
					  (sua-make-registration-status-parameter status)
					  (sua-make-routing-context-parameter (list context)))))))
;;; (sua-make-simple-reg-rsp-message 1 0 0)

(define (sua-get-routing-context-from-reg-rsp reg-rsp)
  (bytes->uint32 (list-tail (car (filter sua-routing-context-parameter?
					 (sua-get-parameters-of-parameter 
					  (car (filter sua-registration-result-parameter? (sua-get-parameters-of-message reg-rsp))))))
			    sua-parameter-header-length)))
;;; (sua-get-routing-context-from-reg-rsp (sua-make-simple-reg-rsp-message 1 2 6))

(define (sua-get-error-code-from-message msg)
  (sua-get-error-code-from-parameter (car (filter sua-error-code-parameter? (sua-get-parameters msg)))))
;;; (sua-get-error-code-from-message (sua-make-error-message sua-unexpected-message-error-code))

(define (sua-get-status-type-from-message msg)
  (sua-get-status-type-from-parameter (car (filter sua-status-parameter? (sua-get-parameters msg)))))
;;; (sua-get-status-type-from-message (sua-make-notify-message 2 3))

(define (sua-get-status-info-from-message msg)
  (sua-get-status-info-from-parameter (car (filter sua-status-parameter? (sua-get-parameters msg)))))
;;; (sua-get-status-info-from-message (sua-make-notify-message 2 3))



;;;
;;; General accessor function for parameters
;;;

(define sua-parameter-tag-offset    0)
(define sua-parameter-length-offset 2)
(define sua-parameter-value-offset  4)

(define (sua-get-parameter-tag l)
  (bytes->uint16 (list-tail l sua-parameter-tag-offset)))
;;; (sua-get-parameter-tag (sua-make-parameter 1 (list 1 2 3)))

(define (sua-get-parameter-length l)
  (bytes->uint16 (list-tail l sua-parameter-length-offset)))
;;; (sua-get-parameter-length (sua-make-parameter 1 (list 1 2 3)))

(define (sua-get-parameter-value l)
  (list-tail (list-head l (sua-get-parameter-length l))  sua-parameter-value-offset))
;;; (sua-get-parameter-value (sua-make-parameter 1 (list 1 2 3)))

(define (sua-get-parameter-padding l)
  (list-tail l (sua-get-parameter-length l)))
;;; (sua-get-parameter-padding (sua-make-parameter 1 (list  1 2 3 4)))
 

;;;
;;;  SUA helper routines
;;;

(define sua-maximum-message-length (expt 2 16))

(define (sua-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)))))

;;; (sua-connect "127.0.0.1" 0 "127.0.0.1" sua-port)

(define (sua-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)))))
    

;;;(sua-accept "127.0.0.1" sua-port)

(define (sua-send-message socket stream message)
  (catch 'system-error
	 (lambda()
	   (sctp-sendmsg socket (bytes->string message) (htonl sua-ppid) stream 0 0 AF_INET INADDR_ANY 0))
	 (lambda (key . args)
	   0)))

(define (sua-recv-message socket)
  (let ((buffer (make-string sua-maximum-message-length)))
    (catch 'system-error
	   (lambda ()
	     (let ((n (recv! socket buffer)))
	       (string->bytes (substring buffer 0 n))))
	   (lambda (key . args)
	     (list)))))

;;; (sua-recv-message s)
(define (sua-recv-message-with-timeout socket seconds)
  (let ((buffer (make-string sua-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)))))

;;; (sua-recv-message-with-timeout s 2)

(define (sua-wait-for-message socket predicate)
  (let ((m (sua-recv-message socket)))
    (if (or (zero? (length m)) (predicate m))
	m
	(sua-wait-for-message socket predicate))))

(define (sua-wait-for-message-with-timeout socket predicate seconds)
  (let ((m (sua-recv-message-with-timeout socket seconds)))
    (if (or (zero? (length m)) (predicate m))
	m
	(sua-wait-for-message-with-timeout socket predicate seconds))))

(define (sua-version-ok? version)
  (= version sua-version))
;;; (sua-version-ok? sua-version)
;;; (sua-version-ok? (+ sua-version 1))

(define (sua-message-class-ok? class rkm-message-class-supported?)
  (or (= class sua-mgmt-message-class)
      (= class sua-ssnm-message-class)
      (= class sua-aspsm-message-class)
      (= class sua-asptm-message-class)
      (= class sua-connection-less-message-class)
      (= class sua-connection-oriented-message-class)
      (and rkm-message-class-supported? (= class sua-rkm-message-class))))
;;; (sua-message-class-ok? sua-mgmt-message-class #t)
;;; (sua-message-class-ok? sua-rkm-message-class #t)
;;; (sua-message-class-ok? sua-rkm-message-class #f)
;;; (sua-message-class-ok? 1000)

(define (sua-message-type-ok? class type)
  (cond
    ((= class sua-mgmt-message-class)
     (or (= type sua-err-message-type)
	 (= type sua-ntfy-message-type)))
    ((= class sua-ssnm-message-class)
     (or (= type sua-duna-message-type)
	 (= type sua-dava-message-type)
	 (= type sua-daud-message-type)
	 (= type sua-scon-message-type)
	 (= type sua-dupu-message-type)
	 (= type sua-drst-message-type)))
    ((= class sua-aspsm-message-class)
     (or (= type sua-aspup-message-type)
	 (= type sua-aspdn-message-type)
	 (= type sua-beat-message-type)
	 (= type sua-aspup-ack-message-type)
	 (= type sua-aspdn-ack-message-type)
	 (= type sua-beat-ack-message-type)))
    ((= class sua-asptm-message-class)
     (or (= type sua-aspac-message-type)
	 (= type sua-aspia-message-type)
	 (= type sua-aspac-ack-message-type)
	 (= type sua-aspia-ack-message-type)))
    ((= class sua-connection-less-message-class)
     (or (= type sua-cldt-message-type)
	 (= type sua-cldr-message-type)))
    ((= class sua-connection-oriented-message-class)
     (or (= type sua-core-message-type)
	 (= type sua-coak-message-type)
	 (= type sua-coref-message-type)
	 (= type sua-relre-message-type)
	 (= type sua-relco-message-type)
	 (= type sua-resco-message-type)
	 (= type sua-resre-message-type)
	 (= type sua-codt-message-type)
	 (= type sua-coda-message-type)
	 (= type sua-coerr-message-type)
	 (= type sua-coit-message-type)))
    ((= class sua-rkm-message-class)
     (or (= type sua-reg-req-message-type)
	 (= type sua-reg-rsp-message-type)
	 (= type sua-dereg-req-message-type)
	 (= type sua-dereg-rsp-message-type)))))

;;; (sua-message-type-ok? sua-aspsm-message-class 7)

(define (sua-check-common-header fd message rkm-message-class-supported?)
  (if (not (sua-version-ok? (sua-get-version message)))
      (begin
	(sua-send-message fd 0 (sua-make-error-message sua-invalid-version-error-code))
	#f)
      (if (not (sua-message-class-ok? (sua-get-message-class message) rkm-message-class-supported?))
	  (begin
	    (sua-send-message fd 0 (sua-make-error-message sua-unsupported-message-class-error-code))
	    #f)
	  (if (not (sua-message-type-ok? (sua-get-message-class message)
					 (sua-get-message-type message)))
	      (begin
		(sua-send-message fd 0 (sua-make-error-message sua-unsupported-message-type-error-code))
		#f)
	      #t))))

(define (sua-cldt-message? message)
  (and (= (sua-get-message-class message) sua-connection-less-message-class)
       (= (sua-get-message-type message)  sua-cldt-message-type)))
;;; (sua-cldt-message? (sua-make-cldt-message (list)))
;;; (sua-cldt-message? (sua-make-asp-up-message (list)))

(define (sua-error-message? message)
  (and (= (sua-get-message-class message) sua-mgmt-message-class)
       (= (sua-get-message-type message)  sua-err-message-type)))
;;; (sua-error-message? (sua-make-error-message sua-unexpected-message-error-code))
;;; (sua-error-message? (sua-make-asp-up-message (list)))

(define (sua-notify-message? message)
  (and (= (sua-get-message-class message) sua-mgmt-message-class)
       (= (sua-get-message-type message)  sua-ntfy-message-type)))
;;; (sua-notify-message? (sua-make-notify-message sua-as-state-change-status-type sua-as-inactive))
;;; (sua-notify-message? (sua-make-asp-up-message (list)))

(define (sua-beat-message? message)
  (and (= (sua-get-message-class message) sua-aspsm-message-class)
       (= (sua-get-message-type message)  sua-beat-message-type)))
;;; (sua-beat-message? (sua-make-beat-message (list 1 2 3)))
;;; (sua-beat-message? (sua-make-asp-up-message (list)))

(define (sua-beat-ack-message? message)
  (and (= (sua-get-message-class message) sua-aspsm-message-class)
       (= (sua-get-message-type message)  sua-beat-ack-message-type)))
;;; (sua-beat-ack-message? (sua-make-beat-ack-message (list 1 2 3)))
;;; (sua-beat-ack-message? (sua-make-asp-up-message (list)))

(define (sua-asp-up-message? message)
  (and (= (sua-get-message-class message) sua-aspsm-message-class)
       (= (sua-get-message-type message)  sua-aspup-message-type)))
;;; (sua-asp-up-message? (sua-make-asp-up-message (list)))
;;; (sua-asp-up-message? (sua-make-asp-down-message))

(define (sua-asp-up-ack-message? message)
  (and (= (sua-get-message-class message) sua-aspsm-message-class)
       (= (sua-get-message-type message)  sua-aspup-ack-message-type)))
;;; (sua-asp-up-ack-message? (sua-make-asp-up-ack-message))
;;; (sua-asp-up-ack-message? (sua-make-asp-down-message))

(define (sua-asp-active-message? message)
  (and (= (sua-get-message-class message) sua-asptm-message-class)
       (= (sua-get-message-type message)  sua-aspac-message-type)))
;;; (sua-asp-active-message? (sua-make-asp-active-message (list)))
;;; (sua-asp-active-message? (sua-make-asp-down-message))

(define (sua-asp-active-ack-message? message)
  (and (= (sua-get-message-class message) sua-asptm-message-class)
       (= (sua-get-message-type message)  sua-aspac-ack-message-type)))
;;; (sua-asp-active-ack-message? (sua-make-asp-active-ack-message (list)))
;;; (sua-asp-active-ack-message? (sua-make-asp-down-message))

(define (sua-asp-down-message? message)
  (and (= (sua-get-message-class message) sua-aspsm-message-class)
       (= (sua-get-message-type message)  sua-aspdn-message-type)))
;;; (sua-asp-down-message? (sua-make-asp-down-message))
;;; (sua-asp-down-message? (sua-make-asp-up-message (list)))

(define (sua-asp-down-ack-message? message)
  (and (= (sua-get-message-class message) sua-aspsm-message-class)
       (= (sua-get-message-type message)  sua-aspdn-ack-message-type)))
;;; (sua-asp-down-ack-message? (sua-make-asp-down-ack-message))
;;; (sua-asp-down-ack-message? (sua-make-asp-up-message (list)))

(define (sua-asp-inactive-message? message)
  (and (= (sua-get-message-class message) sua-asptm-message-class)
       (= (sua-get-message-type message)  sua-aspia-message-type)))
;;; (sua-asp-inactive-message? (sua-make-asp-inactive-message (list)))
;;; (sua-asp-inactive-message? (sua-make-asp-down-message))

(define (sua-asp-inactive-ack-message? message)
  (and (= (sua-get-message-class message) sua-asptm-message-class)
       (= (sua-get-message-type message)  sua-aspia-ack-message-type)))
;;; (sua-asp-inactive-ack-message? (sua-make-asp-inactive-ack-message (list)))
;;; (sua-asp-inactive-ack-message? (sua-make-asp-down-message))

(define (sua-daud-message? message)
  (and (= (sua-get-message-class message) sua-ssnm-message-class)
       (= (sua-get-message-type message)  sua-daud-message-type)))
;;; (sua-daud-message? (sua-make-daud-message (list)))
;;; (sua-daud-message? (sua-make-asp-down-message))

(define (sua-reg-req-message? message)
  (and (= (sua-get-message-class message) sua-rkm-message-class)
       (= (sua-get-message-type message)  sua-reg-req-message-type)))
;;; (sua-reg-req-message? (sua-make-reg-req-message (list)))
;;; (sua-reg-req-message? (sua-make-asp-down-message))

(define (sua-reg-rsp-message? message)
  (and (= (sua-get-message-class message) sua-rkm-message-class)
       (= (sua-get-message-type message)  sua-reg-rsp-message-type)))
;;; (sua-reg-rsp-message? (sua-make-reg-rsp-message (list)))
;;; (sua-reg-rsp-message? (sua-make-asp-down-message))

(define (sua-dereg-req-message? message)
  (and (= (sua-get-message-class message) sua-rkm-message-class)
       (= (sua-get-message-type message)  sua-dereg-req-message-type)))
;;; (sua-dereg-req-message? (sua-make-dereg-req-message (list)))
;;; (sua-dereg-req-message? (sua-make-asp-down-message))

(define (sua-dereg-rsp-message? message)
  (and (= (sua-get-message-class message) sua-rkm-message-class)
       (= (sua-get-message-type message)  sua-dereg-rsp-message-type)))
;;; (sua-dereg-rsp-message? (sua-make-dereg-rsp-message (list)))
;;; (sua-dereg-rsp-message? (sua-make-asp-down-message))

(define sua-asp-down           0)
(define sua-asp-inactive       1)
(define sua-asp-active         2)
(define sua-asp-reflect-beat   3)
(define sua-asp-send-data      4)
(define sua-asp-receive-data   5)
(define sua-asp-send-reg-req   6)
(define sua-asp-send-dereg-req 7)

(define (sua-handle-sgp-message fd state rkm-message-class-supported?)
  (let ((message (sua-recv-message fd)))
    (if (positive? (length message))
	(if (sua-check-common-header fd message rkm-message-class-supported?)
	    (cond 
	     ((sua-beat-message? message)
	      (sua-send-message fd 0 (sua-make-message sua-aspsm-message-class
						       sua-beat-ack-message-type
						       (sua-get-parameters message)))
	      (sua-handle-sgp-message fd state rkm-message-class-supported?))

	     ((sua-asp-up-message? message)
	      (if (= state sua-asp-active)
		  (sua-send-message fd 0 (sua-make-error-message sua-unexpected-message-error-code)))
	      (sua-send-message fd 0 (sua-make-asp-up-ack-message))
	      (if (not (= state sua-asp-inactive))
		  (sua-send-message fd 0 (sua-make-notify-message sua-as-state-change-status-type
								  sua-as-inactive)))
	      (sua-handle-sgp-message fd sua-asp-inactive rkm-message-class-supported?))
	     
	     ((sua-asp-active-message? message)
	      (if (= state sua-asp-down)
		  (begin
		    (sua-send-message fd 0 (sua-make-error-message sua-unexpected-message-error-code))
		    (sua-handle-sgp-message fd sua-asp-down rkm-message-class-supported?))
		  (begin
		    (sua-send-message fd 0 (sua-make-asp-active-ack-message (sua-get-parameters message)))
		    (if (not (= state sua-asp-active))
			(sua-send-message fd 0 (sua-make-notify-message sua-as-state-change-status-type
									sua-as-active)))
		    (sua-handle-sgp-message fd sua-asp-active rkm-message-class-supported?))))
	     
	     ((sua-asp-down-message? message)
	      (sua-send-message fd 0 (sua-make-asp-down-ack-message))
	      (sua-handle-sgp-message fd sua-asp-down rkm-message-class-supported?))
	     
	     ((sua-asp-inactive-message? message)
	      (if (= state sua-asp-down)
		  (begin
		    (sua-send-message fd 0 (sua-make-asp-down-ack-message))
		    (sua-handle-sgp-message fd sua-asp-down rkm-message-class-supported?))
		  (begin
		    (sua-send-message fd 0 (sua-make-asp-inactive-ack-message (list)))
		    (if (= state sua-asp-active)
			(sua-send-message fd 0 (sua-make-notify-message sua-as-state-change-status-type
									sua-as-pending)))
		    (sua-handle-sgp-message fd sua-asp-inactive rkm-message-class-supported?))))
	     ((sua-reg-req-message? message)
	      (if (= state sua-asp-inactive)
		  (sua-send-message fd 0 (sua-make-reg-rsp-from-reg-req message))
		  (sua-send-message fd 0 (sua-make-error-message sua-unexpected-message-error-code)))
	      (sua-handle-sgp-message fd state rkm-message-class-supported?))
	     ((sua-dereg-req-message? message)
	      (sua-send-message fd 0 (sua-make-dereg-rsp-from-dereg-req message))
	      (sua-handle-sgp-message fd state rkm-message-class-supported?))
	     (else
	      (sua-send-message fd 0 (sua-make-error-message sua-unexpected-message-error-code))
	      (sua-handle-sgp-message fd state rkm-message-class-supported?)))))))

(define (sua-run-sgp port rkm-message-class-supported?)
  (let ((fd (sua-accept "0.0.0.0" port)))
    (sua-handle-sgp-message fd sua-asp-down rkm-message-class-supported?)
    (close fd)))
;;; (sua-run-sgp sua-port #t) ;;; RKM message class supported
;;; (sua-run-sgp sua-port #f) ;;; RKM message class not supported




(define (sua-perform-asp-states fd current-state states)
  (if (null? states)
      (close fd)
      (cond
	((= (car states) sua-asp-down)
 	 (sua-send-message fd 0 (sua-make-asp-down-message))
	 (let ((message (sua-recv-message fd)))
	   (if (positive? (length message))
	       (if (sua-check-common-header fd message #t)
		   (if (sua-asp-down-ack-message? message)
		       (sua-perform-asp-states fd sua-asp-down (cdr states))
		       (close fd))
		   (close fd)))
	   (close fd)))
	((= (car states) sua-asp-inactive)
	 (if (= current-state sua-asp-down)
	     (begin
	       (sua-send-message fd 0 (sua-make-asp-up-message (list)))
	       (let ((message (sua-recv-message fd)))
		 (if (positive? (length message))
		     (if (sua-check-common-header fd message #t)
			 (if (sua-asp-up-ack-message? message)
			     (sua-perform-asp-states fd sua-asp-inactive (cdr states))
			     (close fd))
			 (close fd))
		     (close fd))))
	     (begin
	       (sua-send-message fd 0 (sua-make-asp-inactive-message (list)))
	       (let ((message (sua-recv-message fd)))
		 (if (positive? (length message))
		     (if (sua-check-common-header fd message #t)
			 (if (sua-asp-inactive-ack-message? message)
			     (sua-perform-asp-states fd sua-asp-inactive (cdr states))
			     (close fd))
			 (close fd))
		     (close fd))))))
	((= (car states) sua-asp-active)
	 (sua-send-message fd 0 (sua-make-asp-active-message (list)))
	 (let ((message (sua-recv-message fd)))
	   (if (positive? (length message))
	       (if (sua-check-common-header fd message #t)
		   (if (sua-asp-active-ack-message? message)
		       (sua-perform-asp-states fd sua-asp-active (cdr states))
		       (close fd))
		   (close fd))
	       (close fd))))
	((= (car states) sua-asp-reflect-beat)
	 (let ((message (sua-recv-message fd)))
	   (if (positive? (length message))
	       (if (sua-check-common-header fd message #t)
		   (if (sua-beat-message? message)
		       (begin
			 (sua-send-message fd 0 (sua-make-beat-ack-message (sua-get-parameter-value (car (sua-get-parameters message)))))
			 (sua-perform-asp-states fd current-state (cdr states)))
		       (sua-perform-asp-states fd current-state states))
		   (close fd))
	       (close fd))))
	((= (car states) sua-asp-send-data)
	 (sua-send-message fd 1 (sua-make-cldt-message (list (sua-make-routing-context-parameter (list tester-rc-valid))
							     (sua-make-protocol-class-parameter sua-protocol-class-0 #f)
							     (sua-make-source-address-parameter sua-route-on-ssn-and-pc-indicator 
												sua-address-indicator-ssn-mask
												(list (sua-make-point-code-parameter tester-pc)
												      (sua-make-subsystem-number-parameter tester-ssn)))
							     (sua-make-destination-address-parameter sua-route-on-ssn-and-pc-indicator
												     sua-address-indicator-ssn-mask
												     (list (sua-make-point-code-parameter sut-pc)
													   (sua-make-subsystem-number-parameter sut-ssn)))
							     (sua-make-sequence-control-parameter 0)
							     (sua-make-data-parameter sccp-test-message))))
	 (sua-perform-asp-states fd current-state (cdr states)))
	((= (car states) sua-asp-receive-data)
	 (let ((message (sua-recv-message fd)))
	   (if (positive? (length message))
	       (if (sua-check-common-header fd message #t)
		   (sua-perform-asp-states fd current-state (cdr states))
		   (close fd))
	       (close fd))))
	((= (car states) sua-asp-send-reg-req)
	 (sua-send-message fd 0 (sua-make-reg-req-message 
				 (list (sua-make-routing-key-parameter
					(list (sua-make-local-routing-key-identifier-parameter 1)
					      (sua-make-destination-point-code-parameter 2))))))
	 (let ((message (sua-recv-message fd)))
	   (if (positive? (length message))
	       (if (sua-check-common-header fd message #t)
		   (sua-perform-asp-states fd current-state (cdr states))
		   (close fd))
	       (close fd))))
	((= (car states) sua-asp-send-dereg-req)
	 (sua-send-message fd 0 (sua-make-dereg-req-message (list (sua-make-routing-context-parameter (list 1)))))
	 (let ((message (sua-recv-message fd)))
	   (if (positive? (length message))
	       (if (sua-check-common-header fd message #t)
		   (sua-perform-asp-states fd current-state (cdr states))
		   (close fd))
	       (close fd))))
	(else
	 (error 'wrong-state)))))

(define (sua-run-asp remote-addr states)
  (let ((fd (sua-connect "0.0.0.0" 0 remote-addr sua-port)))
    (sua-perform-asp-states fd sua-asp-down states)))

(define (sua-send-beats local-addr local-port remote-addr remote-port number length)
  (let ((fd (sua-connect local-addr local-port remote-addr remote-port))
	(beat-message (sua-make-beat-message (random-bytes length))))
    (dotimes (n number)
	     (sua-send-message fd 0 beat-message)
	     (sua-recv-message fd))
    (sleep 1)
    (close fd)))
;;; (sua-send-beats "192.168.1.2" sua-port "192.168.1.8" sua-port 1000 1000)