;;;
;;; sb-usb.lisp
;;;
;;; Linux usbdevfs access for SBCL
;;;

(cl:defpackage :sb-usb
  (:use :common-lisp :sb-alien)
  (:export "USB-DISCONNECT"
	   "USB-CONNECT"
	   "USB-CLAIM-INTERFACE"
	   "USB-RELEASE-INTERFACE"
	   "USB-GET-DRIVER"

	   "USB-TIMEOUT"
	   "RETRY"

	   "USB-CONTROL"
	   "USB-BULK"))

(cl:in-package :sb-usb)


;;; Linux IOCTL definition helpers

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Damned IOCTL junk is defined in unsigned, but implemented in signed. :-/
  (defun u32->s32 (foo)
    (if (logbitp 31 foo)
	(logior #x-80000000 foo)
	foo)))

(defmacro encode-ioctl (mode type index &optional (struct nil struct-p))
  (when (and (eq mode :io) struct-p)
    (error "Attempting to encode :IO IOCTL with a STRUCT"))
  (when (and (not (eq mode :io)) (not struct-p))
    (error "Attempting to encode ~S IOCTL without a STRUCT" mode))

  (let* ((mode-bits (ecase mode
		      (:iowr 3)
		      (:ior 2)
		      (:iow 1)
		      (:io 0)))
	 (type-bits (char-code type))
	 (length-bits `(alien-size ,struct :bytes))
	 (non-length-bits (dpb mode-bits (byte 2 30)
			       (dpb type-bits (byte 8 8)
				    index))))
    `(u32->s32 ,(if struct-p
		    `(dpb ,length-bits (byte 14 16)
			  ,non-length-bits)
		    non-length-bits))))

(defmacro define-ioctl (name mode type index &optional (struct nil struct-p))
  `(defconstant ,name (encode-ioctl ,mode ,type ,index ,@(when struct-p (list struct)))))


;;; USB IOCTL structures

(define-alien-type usbdevfs-ctrltransfer
    (struct usbdevfs-ctrltransfer
	    (request-type (unsigned 8))
	    (request (unsigned 8))
	    (value (unsigned 16))
	    (index (unsigned 16))
	    (length (unsigned 16))
	    (timeout (unsigned 32)) ;; in milliseconds (frames?)
	    (data (* t))))

(define-alien-type usbdevfs-bulktransfer
    (struct usbdevfs-bulktransfer
	    (endpoint unsigned-int)
	    (length unsigned-int)
	    (timeout unsigned-int) ;; in milliseconds (frames?)
	    (data (* t))))

(define-alien-type usbdevfs-setinterface
    (struct usbdevfs-setinterface
	    (interface unsigned-int)
	    (altsetting unsigned-int)))

(define-alien-type usbdevfs-disconnectsignal
    (struct usbdevfs-disconnectsignal
	    (signr unsigned-int)
	    (context (* t))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +usbdevfs-maxdrivername+ 255))

(define-alien-type usbdevfs-getdriver
    (struct usbdevfs-getdriver
	    (interface unsigned-int)
	    (driver (array char #.(1+ +usbdevfs-maxdrivername+)))))

(define-alien-type usbdevfs-connectinfo
    (struct usbdevfs-connectinfo
	    (devnum unsigned-int)
	    (slow unsigned-char)))

;; flags?
(defconstant +usbdevfs-urb-short-not-ok+ 1)
(defconstant +usbdevfs-urb-iso-asap+ 2)

(defconstant +usbdevfs-urb-type-iso+ 0)
(defconstant +usbdevfs-urb-type-interrupt+ 1)
(defconstant +usbdevfs-urb-type-control+ 2)
(defconstant +usbdevfs-urb-type-bulk+ 3)

(define-alien-type usbdevfs-iso-packet-desc
    (struct usbdevfs-iso-packet-desc
	    (length unsigned-int)
	    (actual-length unsigned-int)
	    (status unsigned-int)))

(define-alien-type usbdevfs-urb
    (struct usbdevfs-urb
	    (type unsigned-char)
	    (endpoint unsigned-char)
	    (status int)
	    (flags unsigned-int)
	    (buffer (* t))
	    (buffer-length int)
	    (actual-length int)
	    (start-frame int)
	    (number-of-packets int)
	    (error-count int)
	    (signr unsigned-int)
	    (usercontext (* t))
	    (iso-frame-desc (array usbdevfs-iso-packet-desc 0))))

(define-alien-type usbdevfs-ioctl
    (struct usbdevfs-ioctl
	    (ifno int)
	    (ioctl-code int)
	    (data (* t))))

(define-alien-type usbdevfs-hub-portinfo
    (struct usbdevfs-hub-portinfo
	    (nports char)
	    (port (array char 127))))


;;; USB IOCTLs

;; We're a userspace program, not a kernel, we don't need the 32-bit
;; specific ioctls, they're for compatability within the kernel
;; itself.
(define-ioctl USBDEVFS_CONTROL           :iowr #\U  0 usbdevfs-ctrltransfer)
(define-ioctl USBDEVFS_BULK              :iowr #\U  2 usbdevfs-bulktransfer)
(define-ioctl USBDEVFS_RESETEP           :ior  #\U  3 unsigned-int)
(define-ioctl USBDEVFS_SETINTERFACE      :ior  #\U  4 usbdevfs-setinterface)
(define-ioctl USBDEVFS_SETCONFIGURATION  :ior  #\U  5 unsigned-int)
(define-ioctl USBDEVFS_GETDRIVER         :iow  #\U  8 usbdevfs-getdriver)
(define-ioctl USBDEVFS_SUBMITURB         :ior  #\U 10 usbdevfs-urb)
;;(define-ioctl USBDEVFS_SUBMITURB32       :ior  #\U 10 usbdevfs-urb32)
(define-ioctl USBDEVFS_DISCARDURB        :io   #\U 11)
(define-ioctl USBDEVFS_REAPURB           :iow  #\U 12 (* t))
;;(define-ioctl USBDEVFS_REAPURB32         :iow  #\U 12 (unsigned 32))
(define-ioctl USBDEVFS_REAPURBNDELAY     :iow  #\U 13 (* t))
;;(define-ioctl USBDEVFS_REAPURBNDELAY32   :iow  #\U 13 (unsigned 32))
(define-ioctl USBDEVFS_DISCSIGNAL        :ior  #\U 14 usbdevfs-disconnectsignal)
(define-ioctl USBDEVFS_CLAIMINTERFACE    :ior  #\U 15 unsigned-int)
(define-ioctl USBDEVFS_RELEASEINTERFACE  :ior  #\U 16 unsigned-int)
(define-ioctl USBDEVFS_CONNECTINFO       :iow  #\U 17 usbdevfs-connectinfo)
(define-ioctl USBDEVFS_IOCTL             :iowr #\U 18 usbdevfs-ioctl)
;;(define-ioctl USBDEVFS_IOCTL32           :iowr #\U 18 usbdevfs-ioctl32)
(define-ioctl USBDEVFS_HUB_PORTINFO      :ior  #\U 19 usbdevfs-hub-portinfo)
(define-ioctl USBDEVFS_RESET             :io   #\U 20)
(define-ioctl USBDEVFS_CLEAR_HALT        :ior  #\U 21 unsigned-int)
(define-ioctl USBDEVFS_DISCONNECT        :io   #\U 22)
(define-ioctl USBDEVFS_CONNECT           :io   #\U 23)


;;; Extra syscall return values

(defconstant ETIMEDOUT 110)


;;; USB wrappers

;; FIXME: CONNECT, DISCONNECT and GETDRIVER all take an interface
;; number parameter.  This came as a surprise to me, but upon
;; reflection, aside from GETDRIVER, the IOCTL definitions make sense.
;; GETDRIVER is listed as a write-only interface, while CONNECT and
;; DISCONNECT pass the interface via the IOCTL structure.

(defun usb-disconnect (dev)
  "Persuade the kernel driver to relinquish its claim upon a device."
  (with-alien ((ctrl usbdevfs-ioctl))
    (setf (slot ctrl 'ioctl-code) USBDEVFS_DISCONNECT)
    (setf (slot ctrl 'ifno) 0)
    (setf (slot ctrl 'data) nil)
    (multiple-value-bind (successp error)
	(sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
			    USBDEVFS_IOCTL
			    (alien-sap (addr ctrl)))
      (unless successp
	(error "USBDEVFS_DISCONNECT failed: ~S" (sb-int:strerror error))))))

(defun usb-connect (dev)
  "Request the kernel driver to reassert its claim upon a device."
  (with-alien ((ctrl usbdevfs-ioctl))
    (setf (slot ctrl 'ioctl-code) USBDEVFS_CONNECT)
    (setf (slot ctrl 'ifno) 0)
    (setf (slot ctrl 'data) nil)
    (multiple-value-bind (successp error)
	(sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
			    USBDEVFS_IOCTL
			    (alien-sap (addr ctrl)))
      (unless successp
	(error "USBDEVFS_CONNECT failed: ~S" (sb-int:strerror error))))))

(defun usb-claim-interface (dev interface)
  (with-alien ((iface unsigned-long))
    (setf iface interface)
    (multiple-value-bind (successp error)
	(sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
			    USBDEVFS_CLAIMINTERFACE
			    (alien-sap (addr iface)))
      (unless successp
	(error "USBDEVFS_CLAIMINTERFACE failed: ~S" (sb-int:strerror error))))))

(defun usb-release-interface (dev interface)
  (with-alien ((iface unsigned-long))
    (setf iface interface)
    (multiple-value-bind (successp error)
	(sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
			    USBDEVFS_RELEASEINTERFACE
			    (alien-sap (addr iface)))
      (unless successp
	(error "USBDEVFS_RELEASEINTERFACE failed: ~S" (sb-int:strerror error))))))

(defun usb-get-driver (dev)
  (with-alien ((driver usbdevfs-getdriver))
    (setf (slot driver 'interface) 0)
    (multiple-value-bind (successp error)
	(sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
			    USBDEVFS_GETDRIVER
			    (alien-sap (addr driver)))
      (unless successp
	(error "USBDEVFS_GETDRIVER failed: ~S" (sb-int:strerror error))))
    (values (slot driver 'interface)
	    (cast (slot driver 'driver) c-string))))

(define-condition usb-timeout (error) ())

(defun usb-control (dev request-type request value index data)
  (with-alien ((ctrl usbdevfs-ctrltransfer))
    (setf (slot ctrl 'request-type) request-type
	  (slot ctrl 'request) request
	  (slot ctrl 'value) value
	  (slot ctrl 'index) index
	  (slot ctrl 'length) (length data)
	  (slot ctrl 'timeout) 50
	  (slot ctrl 'data) (sb-sys:vector-sap (sb-kernel:%array-data-vector data)))
    (tagbody
       :retry
       
       (restart-case
	   (multiple-value-bind (successp error)
	       (sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
				   USBDEVFS_CONTROL
				   (alien-sap (addr ctrl)))
	     (unless successp
	       (if (= error ETIMEDOUT)
		   (error 'usb-timeout)
		   (error "USBDEVFS_CONTROL failed: ~S" (sb-int:strerror error)))))
	 (retry () (go :retry))))
    (setf (fill-pointer data) (slot ctrl 'length))))

(defun usb-bulk (dev endpoint data &optional (offset 0))
  (with-alien ((bulk usbdevfs-bulktransfer))
    (setf (slot bulk 'endpoint) endpoint
	  (slot bulk 'length) (- (length data) offset)
	  (slot bulk 'timeout) 50
	  (slot bulk 'data) (sb-sys:sap+ (sb-sys:vector-sap (sb-kernel:%array-data-vector data)) offset))
    (tagbody
     :retry
       
       (restart-case
	   (multiple-value-bind (successp error)
	       (sb-unix:unix-ioctl (sb-sys:fd-stream-fd dev)
				   USBDEVFS_BULK
				   (alien-sap (addr bulk)))
	     (unless successp
	       (if (= error ETIMEDOUT)
		   (error 'usb-timeout)
		   (error "USBDEVFS_CONTROL failed: ~S" (sb-int:strerror error)))))
	 (retry () (go :retry))))
    (setf (fill-pointer data) (+ (slot bulk 'length) offset))))

#|

(with-alien ((urb usbdevfs-urb)
		     (buf (array (unsigned 8) 8))
		     (ptr (* usbdevfs-urb)))
	  (setf (slot urb 'type) +usbdevfs-urb-type-interrupt+)
	  (setf (slot urb 'endpoint) #x81)
	  (setf (slot urb 'flags) 0)
	  (setf (slot urb 'buffer) (addr buf))
	  (setf (slot urb 'buffer-length) 8)
	  (setf (slot urb 'signr) #xffffffff)
	  (setf (slot urb 'actual-length) 0)
	  (setf (slot urb 'number-of-packets) 0)
	  (setf (slot urb 'usercontext) nil)

	  (setf (slot urb 'error-count) 0)
	  (setf (slot urb 'start-frame) 0)
	  (setf (slot urb 'status) 0)
	  
	  (multiple-value-bind (successp error)
	      (sb-unix:unix-ioctl (sb-sys:fd-stream-fd cl-user::*dev*)
				  USBDEVFS_SUBMITURB
				  (alien-sap (addr urb)))
	    (unless successp
	      (error "USBDEVFS_SUBMITURB failed: ~S" (sb-int:strerror error))))
	  
	  (setf ptr nil)
	  (multiple-value-bind (successp error)
	      (sb-unix:unix-ioctl (sb-sys:fd-stream-fd cl-user::*dev*)
				  USBDEVFS_REAPURB
				  (alien-sap (addr ptr)))
	    (unless successp
	      (error "USBDEVFS_REAPURB failed: ~S" (sb-int:strerror error))))
	  
	  (inspect (list urb buf ptr)))


;; top-left
6 00FF008C00390302
6 00FF008C00380302
6 0061008C00380302
6 00FF008B00380302
6 0061008B00380202

;; top-right
6 00FF009E0FAA0302
6 0061009E0FAA0202
6 000000A70FAB0302
6 00FF00A80FAA0302
6 00FF00A70FAC0302
6 000000A70FAC0202

;; bottom-left
6 00000F8F00400302
6 00020F8D00410302
6 00FF0F8A00420302
6 00FF0F8900420302
6 00000F8B00430302
6 00FF0F8B00440302
6 00FF0F8A00430302
6 00000F8A00430302
6 00FF0F8700420302
6 00000F8700420202

;; bottom-right
6 00FF0F430FAB0302
6 00610F450FA90302
6 00000F440FA50302
6 00020F430FA10302
6 00FF0F440FA00302
6 00FF0F440F9F0302
6 00FF0F450F9E0302
6 00000F460FA00302
6 00610F450FA20302
6 00FF0F450FA20202

;; drag, top edge, left-to-right
6 00FF008206080302
6 00FF008106090302
6 0061007F06090302
6 00FF007E06090302
6 00FF007E060C0302
6 00FF00BE060F0302
6 006100BE06160302
6 000000AC061C0302
6 0002009D06210302
6 00FF009006250302
6 00FF0087062A0302
6 00FF0081062E0302
6 0000007E06320302
6 0061007D06360302
6 0002007F06390302
6 00FF007E063D0302
6 0000007D06430302
6 0061007B064A0302
6 0002007906520302
6 00FF0079065B0302
6 0000007906630302
6 00610079066C0302
6 0002007A06750302
6 00FF007A067D0302
6 0000007906860302
6 00FF007906900302
6 0000007B069B0302
6 00FF007D06A90302
6 0000007E06B80302
6 00FF008106C90302
6 00FF008306DB0302
6 00FF008606EE0302
6 00FF008607000302
6 00FF0086070F0302
6 00000086071D0302
6 00FF0085072B0302
6 00FF008307390302
6 0000008307150302
6 0061008207210302
6 00FF008107380302
6 0000007F074D0302
6 0061007F074D0202

;; Left edge, top-to-bottom
6 00000487004A0302
6 00FF0487004A0202
6 000004A300510302
6 000204A300510302
6 000204A600510302
6 00FF04A900510302
6 000004AD00520302
6 006104B200530302
6 00FF04B800550302
6 000004BD00560302
6 00FF04C300570302
6 000004CC00580302
6 000204D6005A0302
6 000004E1005C0302
6 000204EF005D0302
6 00FF0501005C0302
6 00FF0513005B0302
6 00FF052500580302
6 0000053600560302
6 00FF054600540302
6 0000055600510302
6 00FF0565004F0302
6 00FF0573004D0302
6 00000581004C0302
6 0061058F004B0302
6 00FF059C004A0302
6 000005AA004A0302
6 006105B800490302
6 000205C7004A0302
6 000005D4004A0302
6 00FF05E1004A0302
6 000205E1004A0202

;;; Packet format looks like:
;; +-------+----------------------------------------------+
;; | 00    | Unknown, always 00.                          |
;; | 01    | Pressure sensor (stylus down if 3, up if 2). |
;; | 02-03 | X-coordinate (0 - #xfff)                     |
;; | 04-05 | Y-coordinate (0 - #xfff)                     |
;; +-------+----------------------------------------------+
|#

;;; EOF