#lang syndicate
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2011-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

;;; Error-raising and -handling utilities used in structuring SSH sessions.

(provide (struct-out protocol-error)
	 disconnect-with-error
	 disconnect-with-error/local-info
	 disconnect-with-error*)

;; A `protocol-error`, when asserted, will cause a SSH_MSG_DISCONNECT
;; to be sent to the remote party with the included reason code, using
;; `message` as the description. The `local-info` field is useful
;; information for diagnosing problems known to the local stack that
;; should not be transmitted to the remote party. For example, upon
;; detection of a MAC failure, it might be useful to know the expected
;; and actual MACs for debugging, but they should not be sent over the
;; wire because we could be experiencing some kind of attack.
(struct protocol-error (reason-code message local-info originated-at-peer?) #:prefab)

;; DS Natural FormatString [Any ...] -> signalled protocol-error
(define (disconnect-with-error ds reason-code format-string . args)
  (apply disconnect-with-error* ds #f '() reason-code format-string args))

;; DS Any Natural FormatString [Any ...] -> signalled protocol-error
(define (disconnect-with-error/local-info ds local-info reason-code format-string . args)
  (apply disconnect-with-error* ds #f local-info reason-code format-string args))

;; DS Boolean Any Natural FormatString [Any ...] -> signalled protocol-error
(define (disconnect-with-error* ds
                                originated-at-peer?
				local-info
				reason-code
				format-string
				. args)
  (define message (apply format format-string args))
  (spawn (at ds (assert (protocol-error reason-code message local-info originated-at-peer?))))
  (error 'protocol-error "(~a) ~a: ~v" reason-code message local-info))