worlds best VNC server (real)

vnc.lisp

(ql:quickload '(:usocket :nibbles :babel))

(defun herald (stream)
  (let ((version (map 'vector #'char-code #(#\R #\F #\B #\Space #\0 #\0 #\3 #\. #\0 #\0 #\3 #\Newline))))
    (write-sequence version stream)
    (finish-output stream)
    (map 'string #'code-char (loop repeat 12 collect (read-byte stream)))))

(defun security-type (type stream)
  (nibbles:write-ub32/be type stream)
  (finish-output stream))

(defun pixel-format (stream)
  (write-byte 32 stream) ; bpp
  (write-byte 24 stream) ; depth
  (write-byte 1 stream) ; big-endian?
  (write-byte 1 stream) ; true colour?
  (dotimes (i 3) (nibbles:write-ub16/be 255 stream)) ; RGB max
  (dotimes (i 3) (write-byte (- 24 (* 8 i)) stream)) ; RGB shift
  (dotimes (i 3) (write-byte 0 stream))) ; padding

(defun server-init (width height name stream)
  (nibbles:write-ub16/be width stream)
  (nibbles:write-ub16/be height stream)
  (pixel-format stream)
  (nibbles:write-ub32/be (length name) stream)
  (write-sequence name stream)
  (finish-output stream))

;; C->S messages
(defun read-pixel-format (stream)
  (dotimes (i 3) (read-byte stream)) ; padding
  (format t "Pixel format: ~D ~D ~D ~D max ~D ~D ~D shift ~D ~D ~D~%"
          (read-byte stream) ; bpp
          (read-byte stream) ; depth
          (read-byte stream) ; big-endian?
          (read-byte stream) ; true colour?
          (nibbles:read-ub16/be stream) ; red max
          (nibbles:read-ub16/be stream) ; green max
          (nibbles:read-ub16/be stream) ; blue max
          (read-byte stream) ; red shift
          (read-byte stream) ; green shift
          (read-byte stream)) ; blue shift
  (dotimes (i 3) (read-byte stream))) ; padding

(defun set-encodings (stream)
  (read-byte stream) ; padding
  (let ((count (nibbles:read-ub16/be stream)))
    (format t "Client has ~D encoding~:P~%" count)
    (format t "Encodings: ~{~4,'0X,~^ ~}~%"
            (loop repeat count
                  collect (nibbles:read-ub32/be stream)))))

(defun frame (buffer x y stream)
  (write-byte 0 stream)
  (write-byte 0 stream) ; padding
  (nibbles:write-ub16/be 1 stream) ; number of rectangles
  (nibbles:write-ub16/be x stream) ; x
  (nibbles:write-ub16/be y stream) ; y
  (nibbles:write-ub16/be (array-dimension buffer 1) stream) ; width
  (nibbles:write-ub16/be (array-dimension buffer 0) stream) ; height
  (nibbles:write-ub32/be 0 stream)
  (dotimes (y (array-dimension buffer 0))
    (dotimes (x (array-dimension buffer 1))
      (dotimes (c 3)
        (write-byte (aref buffer y x c) stream))
      ;; Padding byte to 32bpp
      (write-byte 0 stream))))

(defvar *smpte* (make-array '(480 640 3) :element-type '(unsigned-byte 8)))
(defvar *bars* #(#b111 #b110 #b011 #b010 #b101 #b100 #b001 #b000))
(dotimes (y 480)
  (dotimes (x 640)
    (let ((bar (aref *bars* (floor x (/ 640 (length *bars*))))))
      (flet ((part (i) (if (logbitp i bar) #xFF 0)))
        (setf (aref *smpte* y x 0) (part 2)
              (aref *smpte* y x 1) (part 1)
              (aref *smpte* y x 2) (part 0))))))

(defun framebuffer-update-request (stream)
  (let ((incremental (read-byte stream)))
    (format t "Update ~[incremental~;all~] (~D,~D) + (~D,~D)~%"
            incremental
            (nibbles:read-ub16/be stream)
            (nibbles:read-ub16/be stream)
            (nibbles:read-ub16/be stream)
            (nibbles:read-ub16/be stream))
    (when (zerop incremental)
      (frame *smpte* 0 0 stream)
      (finish-output stream))))

(defun pointer-event (stream)
  (format t "Pointer ~8,'0B @ (~D,~D)~%"
          (read-byte stream)
          (nibbles:read-ub16/be stream)
          (nibbles:read-ub16/be stream)))

(defun key-event (stream)
  (let ((down (read-byte stream)))
    (dotimes (i 2) (read-byte stream)) ; padding
    (format t "Key ~[up~:;down~] ~C~%"
            down
            (code-char (nibbles:read-ub32/be stream)))))

(defun clipboard-event (stream)
  (dotimes (i 3) (read-byte stream)) ; padding
  (let* ((length (nibbles:read-ub32/be stream))
         (bytes (make-array length :element-type '(unsigned-byte 8))))
    (dotimes (i length) (setf (aref bytes i) (read-byte stream)))
    (format t "Clipboard event ~S~%"
            (babel:octets-to-string bytes))))

(defun dispatch (message-type stream)
  (ecase message-type
    (0 (read-pixel-format stream))
    (2 (set-encodings stream))
    (3 (framebuffer-update-request stream))
    (4 (key-event stream))
    (5 (pointer-event stream))
    (6 (clipboard-event stream))))

(defun handle (stream)
  (format t "Version: ~S~%" (herald stream))
  (security-type 1 stream)
  (let ((shared-flag (read-byte stream)))
    (format t "Shared: ~D~%" shared-flag))
  (server-init 640 480 (babel:string-to-octets "Is your fridge running?") stream)
  (frame *smpte* 0 0 stream)
  (loop for message-type = (read-byte stream)
        do (format t "C->S ~D~%" message-type)
           (dispatch message-type stream)))

(defun server ()
  (let ((sock (usocket:socket-listen "localhost" 5900 :reuse-address t)))
    (unwind-protect
         (loop
           (let ((client (usocket:socket-accept sock :element-type '(unsigned-byte 8))))
             (with-simple-restart (abort "Give up on this connection.")
               (unwind-protect
                    (handle (usocket:socket-stream client))
                 (usocket:socket-close client)))))
      (usocket:socket-close sock))))