;;;; SPDX-FileCopyrightText: 2023 Vasilij Schneidermann <mail@vasilij.de>
;;;;
;;;; SPDX-License-Identifier: MIT

(module xcb
    (connect disconnect flush generate-id
             connection? connection-host connection-display connection-screen connection-type connection-socket connection-remote connection-setup)

(import scheme)
(import (chicken base))
(import (chicken bitwise))
(import (chicken file))
(import (chicken format))
(import (chicken io))
(import (chicken irregex))
(import (chicken port))
(import (chicken string))
(import (chicken tcp))
(import (chicken type))
(import (srfi 18))
(import socket)

(import (xcb xproto))
(import (xcb types))

(define display-spec-rx "(.+)?:([0-9]+)(?:\\.([0-9]+))?")

(define (local-socket-path connection)
  (format "/tmp/.X11-unix/X~a" (connection-display connection)))

(define (tcp-socket-port connection)
  (+ 6000 (connection-display connection)))

;; TODO: come up with X11-specific buffered IO
;; NOTE: this could be something as stupid as a list of requests
;; NOTE: each request would be metadata + a string (as obtained via
;; string port)

(define (open-tcp-socket! connection)
  (let* ((host (connection-host connection))
         (port (tcp-socket-port connection))
         (addrs (address-information host port type: sock/stream))
         (so (socket-connect/ai addrs)))
    (connection-type-set! connection 'tcp)
    (connection-socket-set! connection so)
    (connection-remote-set! connection (format "~a:~a" host port))))

(define (open-local-socket! connection)
  (let ((so (socket af/unix sock/stream))
        (path (local-socket-path connection)))
    (socket-connect so (unix-address path))
    (connection-type-set! connection 'local)
    (connection-socket-set! connection so)
    (connection-remote-set! connection path)))

(define (peek-byte in)
  (let ((char (peek-char in)))
    (if (eof-object? char)
        char
        (char->integer char))))

(define peek-UINT8 peek-byte)
(define peek-CARD8 peek-UINT8)

(define byte-order/msb-first #x42)
(define byte-order/lsb-first #x6C)

(define protocol-major-version 11)
(define protocol-minor-version 0)

;; TODO: pluggable authorization (for example via parameter)

(define authorization-protocol-name "")
(define authorization-protocol-data "")

(: connect (string -> (struct connection)))
(define (connect display-spec)
  (let ((m (irregex-match display-spec-rx display-spec)))
    (when (not m)
      (error "Malformed display spec" display-spec))
    (let* ((host (irregex-match-substring m 1))
           (disp (string->number (irregex-match-substring m 2)))
           (screen (irregex-match-substring m 3))
           (screen (and screen (string->number screen)))
           (connection (make-connection #t host disp screen #f #f #f #f #f #f #f)))
      (cond
       (host
        (open-tcp-socket! connection))
       ((file-exists? (local-socket-path connection))
        (open-local-socket! connection))
       (else
        (open-tcp-socket! connection)))
      (receive (in out) (socket-i/o-ports (connection-socket connection))
        (connection-in-set! connection in)
        (connection-out-set! connection out))
      (let ((in (connection-in connection))
            (out (connection-out connection))
            (setup-request (make-SetupRequest byte-order/msb-first
                                              protocol-major-version
                                              protocol-minor-version
                                              (string-length authorization-protocol-name)
                                              (string-length authorization-protocol-data)
                                              authorization-protocol-name
                                              authorization-protocol-data)))
        (write-SetupRequest setup-request out)
        ;; TODO: flush
        (let ((setup-reply-type (peek-CARD8 in)))
          (case setup-reply-type
            ((0) (let ((setup-reply (read-SetupFailed in)))
                   (error "Setup failed"
                          (SetupFailed-protocol-major-version setup-reply)
                          (SetupFailed-protocol-minor-version setup-reply)
                          (SetupFailed-reason setup-reply))))
            ((2) (let ((setup-reply (read-SetupAuthenticate in)))
                   (error "Authentication required"
                          (SetupAuthenticate-status setup-reply)
                          (SetupAuthenticate-reason setup-reply))))
            ((1) (let* ((setup (read-Setup in))
                        (xid-base (Setup-resource-id-base setup))
                        (xid-mask (Setup-resource-id-mask setup))
                        (xid-inc (bitwise-and xid-mask (- xid-mask)))
                        (xid (make-xid 0 xid-base xid-mask xid-inc)))
                   (connection-setup-set! connection setup)
                   (connection-xid-set! connection xid)
                   connection))
            (else (error "Unknown setup reply" setup-reply-type))))))))

(: disconnect ((struct connection) -> void))
(define (disconnect connection)
  (when (connection-connected? connection)
    (socket-close (connection-socket connection))
    (connection-connected?-set! connection #f)))

;; TODO: write all outstanding X requests to out port
(: flush ((struct connection) -> void))
(define (flush connection)
  (void))

(: generate-id ((struct connection) -> fixnum))
(define (generate-id connection)
  (let* ((xid (connection-xid connection))
         (last (xid-last xid))
         (base (xid-base xid))
         (max (xid-max xid))
         (inc (xid-inc xid)))
    (when (>= last (add1 (- max inc)))
      ;; TODO: Make use of XC-MISC and XCMiscGetXIDRange to reallocate xids
      (error "X allocation error: Ran out of resource IDs"))
    (xid-last-set! xid (+ last inc))
    (bitwise-ior (xid-last xid) base)))

)