(module usb mzscheme
  (require (lib "foreign.ss")
           (lib "etc.ss"))
  (unsafe!)

  (define libusb #f)

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

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

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

  (define _usb-descriptor-type
    (_enum '(device = #x01 config string interface endpoint
                    hid = #x21 report physical hub = #x29)))

  (define standard-usb-requests
    (let loop ([symbols '(get-status
                          clear-feature
                          set-feature = #x03
                          set-address = #x05
                          get-descriptor
                          set-descriptor
                          get-configuration
                          set-configuration
                          get-interface
                          set-interface
                          synch-frame)]
               [index 0])
      (unless (null? symbols)
        (when (and (pair? (cdr symbols))
                   (eq? '= (cadr symbols))
                   (pair? (cddr symbols)))
          (set! index (caddr symbols))
          (set-cdr! symbols (cdddr symbols)))
        (set-car! symbols (cons (car symbols) index))
        (loop (cdr symbols) (add1 index)))
      symbols))

  (define _usb-request-type
    (_bitmask '(endpoint-out = #x00
                endpoint-in   = #x80
                standard      = #x00
                class         = #x20
                vendor        = #x40
                reserved      = #x60)))
  
  (define _usb-request
    (make-ctype _uint
                (lambda (value)
                  (cond
                   [(and (symbol? value)
                         (assq value standard-usb-requests)) => cdr]
                   [(number? value) value]
                   [else #f]))
                #f))

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

  (define (bytes->string/utf-16le buffer)
    (let*-values ([(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 (string-descriptor->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"))
      (bytes->string/utf-16le (subbytes buffer 2 (+ length 2)))))

  (define-cpointer-type _usb-string-descriptor _usb-descriptor
    #f
    (lambda (ptr)
      (let ([length (- (ptr-ref ptr _uint8) 2)]
            [type (ptr-ref ptr _usb-descriptor-type 1)])
        (unless (eq? type 'string)
          (error 'string-descriptor "not a string descriptor"))
        (let ([v (make-bytes length)])
          (let loop ([i 0])
            (unless (= i length)
              (bytes-set! v i (ptr-ref ptr _uint8 'abs i))
              (loop (add1 i))))
          (string-descriptor->string v)))))

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

  (provide usb-device-descriptor usb-device-descriptor-product-id)

  (define _path-type
    (make-ctype (make-cstruct-type (build-list (/ usb-max-path-len 8)
                                               (lambda (i) _uint64)))
                #f
                (lambda (ptr)
                  (let ([v (make-bytes usb-max-path-len)]
                        [length #f])
                    (let loop ([i 0])
                      (let ([value (ptr-ref ptr _uint8 'abs i)])
                        (if (or (= i usb-max-path-len) (= value 0)) (set! length i)
                            (begin
                              (bytes-set! v i value)
                              (loop (add1 i))))))
                    (subbytes v 0 length)))))

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

  (provide usb-strerror)
  (defusb usb-strerror -> (message : _bytes)
    -> (bytes->string/latin-1 message))

  (provide usb-init usb-find-busses usb-find-devices usb-get-busses)
  (defusb usb-init -> _void)
  (defusb usb-find-busses -> _int)
  (defusb usb-find-devices -> _int)

  (defusb usb-get-busses -> _usb-bus-pointer)

  (provide usb-open usb-device usb-close)
  (defusb usb-open
    _usb-device-pointer -> _usb-dev-handle)
  (defusb usb-device
    _usb-dev-handle -> _usb-device)
  (defusb usb-close
    _usb-dev-handle -> _int)

  (provide usb-control-msg)
  (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) 
    -> (if (>= recvlen 0) (subbytes buffer 0 recvlen)
           (error (usb-strerror))))

  (provide usb-get-string)
  (define (usb-get-string device index langid)
    (string-descriptor->string
     (usb-control-msg device
                      'endpoint-in
                      'get-descriptor
                      (+ (arithmetic-shift 3 8) index)
                      langid
                      255
                      5000)))

  (define (usb-map-list first-elem next-fun map-fun)
    (let loop ([elem first-elem]
               [results '()])
      (if (not elem) (reverse! results)
          (let ([result (map-fun elem)])
            (loop (next-fun elem)
                  (if result
                      (cons result results)
                      results))))))

  (provide usb-map-busses usb-map-devices usb-map-all-devices)
  (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)
    (apply append
           (usb-map-busses
            (lambda (bus)
              (usb-map-devices (usb-bus-devices bus)
                               map-fun)))))

  (provide get-vendor-id get-product-id
           get-manufacturer-string get-product-string)
  (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)))

  (define (get-manufacturer-string device)
    (let* ([handle (usb-open device)]
           [result (usb-get-string handle
                                   (usb-device-descriptor-manufacturer
                                    (usb-device-descriptor device))
                                   0)])
      (usb-close handle)
      result))

  (define (get-product-string device)
    (let* ([handle (usb-open device)]
           [result (usb-get-string handle
                                   (usb-device-descriptor-product
                                    (usb-device-descriptor device))
                                   0)])
      (usb-close handle)
      result))

  (provide ids-filter string-ids-filter)
  (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? (get-manufacturer-string device) manufacturer)
           (equal? (get-product-string device) product))
          device
          #f)))
)