#lang scheme/base

;; FFI bindings for libusb.

;; This sticks to the origininal usb.h struct and field naming.  The
;; usb.h struct names are prefixed with "struct:" to avoid name
;; clashes with functions, which are imported verbatim.
;;
;; Note that `define-cstruct' adds dashes for field
;; accessors, which disambiguates things like:
;;
;;   struct:usb_device_descriptor   a struct syntax id
;;
;;   struct:usb_device-descriptor   a field accessor function
;;
;; While this naming scheme is a bit ugly, I find it easier to see
;; what's going on in the absence of any documentation or proper
;; high-level abstraction.  I.e. if you see struct:usb_foo-bar or
;; usb_foo_bar, you know to go look in libusb.  If you see usb-foo-bar
;; you know it's a higher level function defined in libusb.ss
;;
;;
;; Adapted from code posted by Jakub Piotr Cłapa
;; http://list.cs.brown.edu/pipermail/plt-scheme/2007-March/016671.html


(require
 (lib "foreign.ss")
 (lib "etc.ss")
 "usbconst.ss"
 )

(unsafe!)


(provide

 ;; High-level functions defined in libusb.ss
 usb-device-list
 usb-device-product

 ;; C functions from libusb (see libusb.h)
 usb_init
 usb_find_busses
 usb_find_devices
 usb_open
 usb_get_driver_np
 usb_detach_kernel_driver_np
 usb_set_configuration
 usb_claim_interface
 usb_release_interface
 usb_interrupt_write
 usb_interrupt_read
 
 ;; get-vendor-id
 ;; get-product-id
 ;; ids-filter
 ;; string-ids-filter
 
)

;; PLATFORM

(define (find-ffi-lib . _libs)
  (let try ((libs _libs))
    (if (null? libs)
        (error 'find-ffi-lib: "Can't find libusb, tried ~s\n" _libs)
        (let ((lib (car libs)))
          ; (printf "trying ~a\n" lib)
          (or
           (and (file-exists? lib)
                (ffi-lib lib))
           (try (cdr libs)))))))

(define libusb 
  (case (system-type)
    [(macosx)
     (ffi-lib "/System/Libraries/IOKit.framework/IOKit")
     (ffi-lib "/opt/local/lib/libusb") ]
    [(unix)
     ;; FIXME: This is a generic one + 2 needed for Debian.  Is there a better way?"
     (find-ffi-lib
      "/lib/libusb-0.1.so"
      "/lib/libusb-0.1.so.4"
      "/lib/x86_64-linux-gnu/libusb-0.1.so.4"
      )]
    [(windows)
     (ffi-lib "libusb0")]))

(define usb-max-path-len
  (case (system-type)
    [(unix) (+ 1 4096)]
    [(macosx) 1024]
    [(windows) 512]))


;; TYPES

;; Beware that usb.h has a mix of byte-packed and default-packed
;; structs.  Inheritance is not used as it seems to have some problems
;; Manual: "id: structure-type information compatible with struct-out
;; or match (but not define-struct); currently, this information is
;; correct only when no super-id is specified.")

;; * PACKED *

(define-cstruct _struct:usb_descriptor_header
  ([bLength          _uint8]
   [bDescriptorType  _uint8])
  #:alignment 1)


(define-cstruct _struct:usb_hid_descriptor
  ([bLength          _uint8]
   [bDescriptorType  _uint8]
   [bcdHID           _uint16]
   [bCountryCode     _uint8]
   [bNumDescriptors  _uint8])
  #:alignment 1)

(define-cstruct _struct:usb_device_descriptor
  ([bLength            _uint8]
   [bDescriptorType    _uint8]
   [bcdUSB             _uint16]
   [bDeviceClass       _uint8]
   [bDeviceSubClass    _uint8]
   [bDeviceProtocol    _uint8]
   [bMaxPacketSize0    _uint8]
   [idVendor           _uint16]
   [idProduct          _uint16]
   [bcdDevice          _uint16]
   [iManufacturer      _uint8]
   [iProduct           _uint8]
   [iSerialNumber      _uint8]
   [bNumConfigurations _uint8])
  #:alignment 1)


;; * NOT PACKED *
(define-cstruct _struct:usb_endpoint_descriptor
  ([bLength          _uint8]
   [bDescriptorType  _uint8]
   [bEndpointAddress _uint8]
   [bmAttributes     _uint8]
   [wMaxPacketSize   _uint16]
   [bInterval        _uint8]
   [bRefresh         _uint8]
   [bSynchAddress    _uint8]
   [extra            _pointer]
   [extralen         _int]
   ))

(define-cstruct _struct:usb_interface_descriptor
  ([bLength           _uint8]
   [bDescriptorType   _uint8]
   [bInterfaceNumber  _uint8]
   [bAlternateSetting _uint8]
   ;; ...
   ))

(define-cstruct _struct:usb_config_descriptor
  ([bLength          _uint8]
   [bDescriptorType  _uint8]
   ;; ...
   ))




;; path
(define (make-carray-type _x n)
  (make-cstruct-type
   (build-list n (lambda (i) _x))))
(define (cptr->bytes0 ptr max)
  (define (strlen b [n 0])
    (if (zero? (bytes-ref b n)) n
        (strlen b (add1 n))))
  (let ((b0 (make-sized-byte-string ptr max)))
    (subbytes b0 0 (strlen b0))))
(define (make-cmaxstring-type n)
  (make-ctype
   (make-carray-type _byte n)
   #f
   (lambda (ptr)
     (bytes->string/utf-8 
      (cptr->bytes0 ptr n)))))
(define _path-type (make-cmaxstring-type usb-max-path-len))





;; string

;; A 'buffer' is a byte string.

;; try to distinguish: ptr, byte-buffer, highlevel types.

;; Use a raw byte buffer
(define (cptr->descriptor-buffer ptr)
  (make-sized-byte-string ptr (- (ptr-ref ptr _uint8) 2)))

(define (string-descriptor-buffer->string buffer)
  (let ([length (- (bytes-ref buffer 0) 2)]
        [type (bytes-ref buffer 1)])
    (unless (eq? type 3)
      (error 'string-descriptor "not a string descriptor"))
    (unless (>= (bytes-length buffer) length)
      (error 'string-descriptor "string longer than the buffer"))
    (let*-values ([(buffer) (subbytes buffer 2 (+ length 2))]
                  [(converter) (bytes-open-converter "UTF-16LE" "UTF-8")]
                  [(result length status) (bytes-convert converter buffer)])
      (bytes-close-converter converter)
      (bytes->string/utf-8 result))))

(define-cpointer-type _struct:usb_string_descriptor
                      _struct:usb_descriptor_header
  #f
  (lambda (ptr)
    (string-descriptor-buffer->string
     (cptr->descriptor-buffer ptr))))

(define _struct:usb_bus/patch _pointer)
(define-cstruct _struct:usb_device
  ([next         _struct:usb_device-pointer/null]
   [prev         _struct:usb_device-pointer/null]
   [filename     _path-type]
   [bus          _struct:usb_bus/patch]
   [descriptor   _struct:usb_device_descriptor]
   [config       (_cpointer _struct:usb_config_descriptor)]
   [dev          _pointer]
   [devnum       _uint8]
   [num_children _uint8]
   [children     (_cpointer _struct:usb_device-pointer)]))

(define-cstruct _struct:usb_bus
  ([next         _struct:usb_bus-pointer/null]
   [prev         _struct:usb_bus-pointer/null]
   [dirname      _path-type]
   [devices      _struct:usb_device-pointer/null]
   [location     _uint32]
   [root-dev     _struct:usb_device-pointer/null]))

(set! _struct:usb_bus/patch _struct:usb_bus-pointer)

(define _usb-class
  (_enum '(per-interface audio comm hid printer mass-storage hub data
                         vendor-spec = #xff)))
(define _usb-request-type _uint)
(define _usb-request      _uint)


(define-cpointer-type _usb-dev-handle)


;; FFI FUNCTIONS

(define-syntax defusb
  (syntax-rules ()
    [(_ name type ...)
     (define name
       (get-ffi-obj 'name ;; (regexp-replaces 'name '((#rx"-" "_")))
                    libusb (_fun type ...)))]))



(defusb usb_strerror -> (message : _bytes)
  -> (bytes->string/latin-1 message))


(defusb usb_init -> _void)
(defusb usb_find_busses -> _int)
(defusb usb_find_devices -> _int)

(defusb usb_get_busses -> _struct:usb_bus-pointer)

(defusb usb_open   _struct:usb_device-pointer -> _usb-dev-handle)
(defusb usb_device _usb-dev-handle            -> _struct:usb_device)
(defusb usb_close  _usb-dev-handle            -> _int)


(define (usb-check retv)
  (when (< retv 0)
    (error (usb_strerror)))
  retv)

;; Send out a control message and wait for a raw result.
(defusb usb_control_msg (dev requesttype request value index buflen timeout) ::
  (dev : _usb-dev-handle)
  (requesttype : _usb-request-type)
  (request : _usb-request)
  (value : _int)
  (index : _int)
  (buffer : (_bytes o buflen))
  (buflen : _int)
  (timeout : _int)
  -> (recvlen : _int)
  -> (subbytes buffer 0 (usb-check recvlen)))

(defusb usb_set_configuration _usb-dev-handle _uint
  -> (retv : _int)
  -> (void (usb-check retv)))

(defusb usb_claim_interface _usb-dev-handle _uint
  -> (retv : _int)
  -> (void (usb-check retv)))
(defusb usb_release_interface _usb-dev-handle _uint
  -> (retv : _int)
  -> (void (usb-check retv)))

(defusb usb_interrupt_write _usb-dev-handle _uint _bytes _int _int
  -> (retv : _int)
  -> (void (usb-check retv)))

(defusb usb_interrupt_read _usb-dev-handle _uint _bytes _int _int
  -> (retv : _int)
  -> (usb-check retv))

;; FIXME: linux specific
(defusb usb_get_driver_np _usb-dev-handle _int _bytes _int
  -> (retv : _int)
  -> (usb-check retv))
(defusb usb_detach_kernel_driver_np _usb-dev-handle _int
  -> (retv : _int)
  -> (usb-check retv))


;; HIGHLEVEL FUNCTIONS


;; Control message send.
(define (usb-control dev requesttype request value index [buflen 255] [timeout 5000])
  (let ((buf (usb_control_msg dev requesttype request value index buflen timeout)))
    buf))
  



;; Map over linked structs.
(define (usb-map-list first-elem next-fun map-fun)
  (let loop ([elem first-elem])
    (if elem
        (cons (map-fun elem) (loop (next-fun elem)))
        '())))
(define (usb-map-busses map-fun)
  (usb-map-list (usb_get_busses) struct:usb_bus-next map-fun))
(define (usb-map-devices device map-fun)
  (usb-map-list device struct:usb_device-next map-fun))
(define (usb-map-all-devices [map-fun (lambda (x) x)])
  (apply append
         (usb-map-busses
          (lambda (bus)
            (usb-map-devices (struct:usb_bus-devices bus) map-fun)))))
(define (ids-filter vendor-id product-id)
  (lambda (device)
    (if (and
         (eq? (get-vendor-id device) vendor-id)
         (eq? (get-product-id device) product-id))
        device
        #f)))

(define (string-ids-filter manufacturer product)
  (lambda (device)
    (if (and
         (equal? (usb-device-manufacturer device) manufacturer)
         (equal? (usb-device-product device) product))
        device
        #f)))



;; Device meta data query.
(define (get-vendor-id device)  (struct:usb_device_descriptor-idVendor  (struct:usb_device-descriptor device)))
(define (get-product-id device) (struct:usb_device_descriptor-idProduct (struct:usb_device-descriptor device)))

;; Wrappers around Standard Device Requests (USB 1.1 spec p. 186)
;; (define get-descriptor (make-request 'endpoint-in 'get-descriptor
(define (type/index type index)
  (+ index (arithmetic-shift type 8)))

(define (get-descriptor-buffer device type index [langid 0])
  (usb-control device
               USB_ENDPOINT_IN
               USB_REQ_GET_DESCRIPTOR
               (type/index type index)
               langid))

(define (usb-get-string device index langid)
  (string-descriptor-buffer->string
   (get-descriptor-buffer device USB_DT_STRING index langid)))

;; Need a connectuib to get a string.
(define (string-getter id)
  (lambda (device)
    (let* ([handle (usb_open device)]
           [result (usb-get-string handle
                                   (id (struct:usb_device-descriptor device))
                                   0)])
      (usb_close handle)
      result)))
(define (value-getter id)
  (lambda (device)
    (id (struct:usb_device-descriptor device))))

;; High level query

(define usb-device-manufacturer  (string-getter struct:usb_device_descriptor-iManufacturer))
(define usb-device-product       (string-getter struct:usb_device_descriptor-iProduct))
(define usb-device-serial-number (string-getter struct:usb_device_descriptor-iSerialNumber))

(define usb-device-num-configurations (value-getter struct:usb_device_descriptor-bNumConfigurations))


(define (usb-device-list [vendor-id #f]
                         [product-id #f])
  (let ((devs (usb-map-all-devices)))
    (if vendor-id
        (filter (ids-filter vendor-id product-id) devs)
        devs)))