#lang scheme/base

;; 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
 (all-defined-out)  ;; lazyness..

;;  usb-init
;;  usb-find-busses
;;  usb-find-devices

;;  usb-device-descriptor
;;  usb-device-descriptor-product-id
;;  usb-strerror
;;  usb-get-busses
;;  usb-open
;;  usb-device
;;  usb-close
;;  usb-control-msg
;;  usb-get-string
;;  usb-map-busses
;;  usb-map-devices
;;  usb-map-all-devices
 
;;  get-vendor-id
;;  get-product-id
;;  ids-filter
;;  string-ids-filter

)

;; PLATFORM

(define libusb 
  (case (system-type)
    [(macosx)
     (ffi-lib "/System/Libraries/IOKit.framework/IOKit")
     (ffi-lib "/opt/local/lib/libusb") ]
    [(unix)
     (ffi-lib "libusb")]
    [(windows)
     (ffi-lib "libusb0")]))

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


;; TYPES

(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-cstruct _usb-descriptor
  ([length _uint8]
   [type _uint8]))

(define-cstruct (_usb-hid-descriptor _usb-descriptor)
  ())

(define-cstruct (_usb-endpoint-descriptor _usb-descriptor)
  ())

(define-cstruct (_usb-interface-descriptor _usb-descriptor)
  ())

(define-cstruct (_usb-config-descriptor _usb-descriptor)
  ())

(define-cstruct (_usb-device-descriptor _usb-descriptor)
  ([usbMajor           _uint8]
   [usbMinor           _uint8]
   [device-class       _uint8]
   [device-subclass    _uint8]
   [device-protocol    _uint8]
   [max-packet-size-0  _uint8]
   [vendor-id          _uint16]
   [product-id         _uint16]
   [deviceMajor        _uint8]
   [deviceMinor        _uint8]
   [manufacturer       _uint8]
   [product            _uint8]
   [serial-number      _uint8]
   [num-configurations _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 _usb-string-descriptor _usb-descriptor
  #f
  (lambda (ptr)
    (string-descriptor-buffer->string
     (cptr->descriptor-buffer ptr))))

(define _usb-bus-pointer-dummy _pointer)

(define-cstruct _usb-device
  ([next         _usb-device-pointer/null]
   [prev         _usb-device-pointer/null]
   [filename     _path-type]
   [bus          _usb-bus-pointer-dummy]
   [descriptor   _usb-device-descriptor]
   [config       (_cpointer _usb-config-descriptor)]
   [dev          _pointer]
   [devnum       _uint8]
   [num_children _uint8]
   [children     (_cpointer _usb-device-pointer)]))

(define-cstruct _usb-bus
  ([next         _usb-bus-pointer/null]
   [prev         _usb-bus-pointer/null]
   [dirname      _path-type]
   [devices      _usb-device-pointer/null]
   [location     _uint32]
   [root-dev     _usb-device-pointer/null]))

(set! _usb-bus-pointer-dummy _usb-bus-pointer)

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


;; FFI FUNCTIONS

(define-syntax defusb
  (syntax-rules ()
    [(_ name type ...)
     (define name
       (get-ffi-obj (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 -> _usb-bus-pointer)


(defusb usb-open
  _usb-device-pointer -> _usb-dev-handle)
(defusb usb-device
  _usb-dev-handle -> _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) usb-bus-next map-fun))
(define (usb-map-devices device map-fun)
  (usb-map-list device 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 (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)
  (usb-device-descriptor-vendor-id (usb-device-descriptor device)))
(define (get-product-id device)
  (usb-device-descriptor-product-id (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 (usb-device-descriptor device))
                                   0)])
      (usb-close handle)
      result)))
(define (value-getter id)
  (lambda (device)
    (id (usb-device-descriptor device))))

;; High level query

(define usb-device-manufacturer  (string-getter usb-device-descriptor-manufacturer))
(define usb-device-product       (string-getter usb-device-descriptor-product))
(define usb-device-serial-number (string-getter usb-device-descriptor-serial-number))

(define usb-device-num-configurations (value-getter usb-device-descriptor-num-configurations))


(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)))