-
Notifications
You must be signed in to change notification settings - Fork 13
/
Base.hs
2284 lines (1827 loc) · 86.8 KB
/
Base.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE CPP
, UnicodeSyntax
, NoImplicitPrelude
, DeriveDataTypeable
, BangPatterns
#-}
#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Unsafe #-}
#endif
#ifdef HAS_EVENT_MANAGER
{-# LANGUAGE PatternGuards #-}
#endif
#ifdef GENERICS
{-# LANGUAGE DeriveGeneric #-}
#endif
module System.USB.Base where
--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------
-- from base:
import Prelude ( Num, (+), (-), (*), Integral, fromIntegral, div
, Enum, fromEnum, error, String, ($!), seq
)
import Foreign.C.Types ( CUChar, CInt, CUInt )
import Foreign.C.String ( CStringLen )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( allocaArray )
import Foreign.Storable ( peek, peekElemOff )
import Foreign.Ptr ( Ptr, castPtr, plusPtr, nullPtr )
import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, touchForeignPtr )
import Control.Exception ( Exception, throwIO, bracket, bracket_, onException, assert )
import Control.Monad ( (=<<), return, when )
import Control.Arrow ( (&&&) )
import Data.Function ( ($), (.), on )
import Data.Data ( Data )
import Data.Typeable ( Typeable )
import Data.Maybe ( Maybe(Nothing, Just), maybe, fromMaybe )
import Data.List ( lookup, (++) )
import Data.Int ( Int )
import Data.Word ( Word8, Word16 )
import Data.Eq ( Eq, (==), (/=) )
import Data.Ord ( Ord, (<), (>) )
import Data.Bool ( Bool(False, True), not, otherwise, (&&) )
import Data.Bits ( Bits, (.|.), setBit, testBit, shiftL, shiftR )
import System.IO ( IO )
import System.IO.Unsafe ( unsafePerformIO )
import Text.Show ( Show, show )
import Text.Read ( Read )
import Text.Printf ( printf )
#if MIN_VERSION_base(4,2,0)
import Data.Functor ( fmap, (<$>) )
#else
import Control.Monad ( fmap )
import Control.Applicative ( (<$>) )
#endif
#if __GLASGOW_HASKELL__ < 700
import Prelude ( fromInteger, negate )
import Control.Monad ( (>>), fail )
#endif
-- from bytestring:
import qualified Data.ByteString as B ( ByteString, packCStringLen, drop, length )
import qualified Data.ByteString.Internal as BI ( createAndTrim, createAndTrim' )
import qualified Data.ByteString.Unsafe as BU ( unsafeUseAsCStringLen )
-- from text:
import Data.Text ( Text )
import qualified Data.Text.Encoding as TE ( decodeUtf16LE )
-- from vector:
import Data.Vector ( Vector )
import qualified Data.Vector.Generic as VG ( convert, map )
-- from bindings-libusb:
import Bindings.Libusb
-- from usb (this package):
import Utils ( bits, between, genToEnum, genFromEnum, peekVector, mapPeekArray
, allocaPeek, ifM, uncons
)
--------------------------------------------------------------------------------
#ifdef HAS_EVENT_MANAGER
-- from base:
import Prelude ( undefined )
import Foreign.C.Types ( CShort, CChar )
import Foreign.Marshal.Alloc ( allocaBytes, free )
import Foreign.Marshal.Array ( peekArray0, copyArray, advancePtr )
import Foreign.Storable ( sizeOf, poke )
import Foreign.Ptr ( nullFunPtr, freeHaskellFunPtr )
import Control.Monad ( (>>=), mapM_, forM )
import Data.IORef ( newIORef, atomicModifyIORef, readIORef )
import System.Posix.Types ( Fd(Fd) )
import Control.Exception ( uninterruptibleMask_ )
import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar, putMVar )
import System.IO ( hPutStrLn, stderr )
#if MIN_VERSION_base(4,4,0)
import GHC.Event
#else
import System.Event
#endif
( FdKey
, registerFd, unregisterFd
, registerTimeout, unregisterTimeout
#if MIN_VERSION_base(4,7,0)
, getSystemTimerManager
#endif
)
-- from containers:
import Data.IntMap ( IntMap, fromList, insert, updateLookupWithKey, elems )
-- from bytestring:
import qualified Data.ByteString.Internal as BI ( create )
--from vector:
import qualified Data.Vector.Unboxed as Unboxed ( Vector )
import qualified Data.Vector.Storable as Storable ( Vector )
import qualified Data.Vector.Generic as VG ( empty, length, sum, foldM_, unsafeFreeze)
import qualified Data.Vector.Generic.Mutable as VGM ( unsafeNew, unsafeWrite )
-- from usb (this package):
import Timeval ( withTimeval )
import qualified Poll ( toEvent )
import SystemEventManager ( getSystemEventManager )
import Utils ( pokeVector )
#endif
#if defined(HAS_EVENT_MANAGER) || defined(mingw32_HOST_OS)
import qualified Foreign.Concurrent as FC ( newForeignPtr )
#endif
#if !defined(mingw32_HOST_OS)
import Foreign.ForeignPtr ( newForeignPtr )
#endif
--------------------------------------------------------------------------------
#ifdef GENERICS
import GHC.Generics ( Generic )
#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable, Generic
#else
#define COMMON_INSTANCES Show, Read, Eq, Data, Typeable
#endif
--------------------------------------------------------------------------------
#if MIN_VERSION_base(4,3,0)
import Control.Exception ( mask, mask_ )
#else
import Control.Exception ( blocked, block, unblock )
import Data.Function ( id )
mask ∷ ((IO α → IO α) → IO β) → IO β
mask io = do
b ← blocked
if b
then io id
else block $ io unblock
mask_ ∷ IO α → IO α
mask_ = block
#endif
--------------------------------------------------------------------------------
-- * Initialization
--------------------------------------------------------------------------------
{-| Abstract type representing a USB session.
The concept of individual sessions allows your program to use multiple threads
that can independently use this library without interfering with eachother.
Sessions are created and initialized by 'newCtx' and are automatically closed
when they are garbage collected.
The only functions that receive a @Ctx@ are 'setDebug' and 'getDevices'.
-}
data Ctx = Ctx
{
#ifdef HAS_EVENT_MANAGER
ctxGetWait ∷ !(Maybe Wait),
#endif
getCtxFrgnPtr ∷ !(ForeignPtr C'libusb_context)
} deriving Typeable
instance Eq Ctx where (==) = (==) `on` getCtxFrgnPtr
withCtxPtr ∷ Ctx → (Ptr C'libusb_context → IO α) → IO α
withCtxPtr = withForeignPtr . getCtxFrgnPtr
libusb_init ∷ IO (Ptr C'libusb_context)
libusb_init = alloca $ \ctxPtrPtr → do
handleUSBException $ c'libusb_init ctxPtrPtr
peek ctxPtrPtr
newCtxNoEventManager ∷ (ForeignPtr C'libusb_context → Ctx) → IO Ctx
newCtxNoEventManager ctx = mask_ $ do
ctxPtr ← libusb_init
#ifdef mingw32_HOST_OS
ctx <$> FC.newForeignPtr ctxPtr
(c'libusb_exit ctxPtr)
#else
ctx <$> newForeignPtr p'libusb_exit ctxPtr
#endif
#ifndef HAS_EVENT_MANAGER
-- | Create and initialize a new USB context.
--
-- This function may throw 'USBException's.
newCtx ∷ IO Ctx
newCtx = newCtxNoEventManager Ctx
#else
--------------------------------------------------------------------------------
-- | A function to wait for the termination of a submitted transfer.
type Wait = Timeout → Lock → Ptr C'libusb_transfer → IO ()
{-| Create and initialize a new USB context.
This function may throw 'USBException's.
Note that the internal @libusb@ event handling can return errors. These errors
occur in the thread that is executing the event handling loop. 'newCtx' will
print these errors to 'stderr'. If you need to handle the errors yourself (for
example log them in an application specific way) please use 'newCtx''.
-}
newCtx ∷ IO Ctx
newCtx = newCtx' $ \e → hPutStrLn stderr $
thisModule ++ ": libusb_handle_events_timeout returned error: " ++ show e
-- | Like 'newCtx' but enables you to specify the way errors should be handled
-- that occur while handling @libusb@ events.
newCtx' ∷ (USBException → IO ()) → IO Ctx
newCtx' handleError = do
mbEvtMgr ← getSystemEventManager
case mbEvtMgr of
Nothing → newCtxNoEventManager $ Ctx Nothing
Just evtMgr → mask_ $ do
ctxPtr ← libusb_init
let handleEvents = do
err ← withTimeval noTimeout $
c'libusb_handle_events_timeout ctxPtr
when (err /= c'LIBUSB_SUCCESS) $
if err == c'LIBUSB_ERROR_INTERRUPTED
then handleEvents
else handleError $ convertUSBException err
register ∷ CInt → CShort → IO FdKey
register fd evt = registerFd evtMgr (\_ _ → handleEvents)
(Fd fd) (Poll.toEvent evt)
-- Register initial libusb file descriptors with the event manager:
pollFdPtrLst ← c'libusb_get_pollfds ctxPtr
pollFdPtrs ← peekArray0 nullPtr pollFdPtrLst
fdKeys ← forM pollFdPtrs $ \pollFdPtr → do
C'libusb_pollfd fd evt ← peek pollFdPtr
fdKey ← register fd evt
return (fromIntegral fd, fdKey)
fdKeyMapRef ← newIORef $! (fromList fdKeys ∷ IntMap FdKey)
free pollFdPtrLst
-- Be notified when libusb file descriptors are added or removed:
aFP ← mk'libusb_pollfd_added_cb $ \fd evt _ → mask_ $ do
fdKey ← register fd evt
newFdKeyMap ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →
let newFdKeyMap = insert (fromIntegral fd) fdKey fdKeyMap
in (newFdKeyMap, newFdKeyMap)
newFdKeyMap `seq` return ()
rFP ← mk'libusb_pollfd_removed_cb $ \fd _ → mask_ $ do
(newFdKeyMap, fdKey) ← atomicModifyIORef fdKeyMapRef $ \fdKeyMap →
let (Just fdKey, newFdKeyMap) =
updateLookupWithKey (\_ _ → Nothing)
(fromIntegral fd)
fdKeyMap
in (newFdKeyMap, (newFdKeyMap, fdKey))
newFdKeyMap `seq` unregisterFd evtMgr fdKey
c'libusb_set_pollfd_notifiers ctxPtr aFP rFP nullPtr
-- Check if we have to do our own timeout handling and construct the
-- appropriate Wait function:
r ← c'libusb_pollfds_handle_timeouts ctxPtr
#if MIN_VERSION_base(4,7,0)
timerMgr <- getSystemTimerManager
#else
let timerMgr = evtMgr
#endif
let wait ∷ Wait
!wait | r == 0 = manualTimeout
| otherwise = \_ → autoTimeout
manualTimeout timeout lock transPtr
| timeout == noTimeout = autoTimeout lock transPtr
| otherwise = do
tk ← registerTimeout timerMgr (timeout * 1000) handleEvents
acquire lock
`onException`
(uninterruptibleMask_ $ do
unregisterTimeout timerMgr tk
_err ← c'libusb_cancel_transfer transPtr
acquire lock)
autoTimeout lock transPtr =
acquire lock
`onException`
(uninterruptibleMask_ $ do
_err ← c'libusb_cancel_transfer transPtr
acquire lock)
fmap (Ctx (Just wait)) $ FC.newForeignPtr ctxPtr $ do
-- Remove notifiers after which we can safely free the FunPtrs:
c'libusb_set_pollfd_notifiers ctxPtr nullFunPtr nullFunPtr nullPtr
freeHaskellFunPtr aFP
freeHaskellFunPtr rFP
-- Unregister all registered file descriptors from the event manager:
readIORef fdKeyMapRef >>= mapM_ (unregisterFd evtMgr) . elems
-- Finally deinitialize libusb:
c'libusb_exit ctxPtr
-- | Checks if the system supports asynchronous I\/O.
--
-- * 'Nothing' means asynchronous I\/O is not supported so synchronous I\/O should
-- be used instead.
--
-- * @'Just' wait@ means that asynchronous I\/O is supported. The @wait@
-- function can be used to wait for submitted transfers.
getWait ∷ DeviceHandle → Maybe Wait
getWait = ctxGetWait . getCtx . getDevice
#endif
--------------------------------------------------------------------------------
{-| Set message verbosity.
The default level is 'PrintNothing'. This means no messages are ever
printed. If you choose to increase the message verbosity level you must ensure
that your application does not close the @stdout@/@stderr@ file descriptors.
You are advised to set the debug level to 'PrintWarnings'. Libusb is
conservative with its message logging. Most of the time it will only log
messages that explain error conditions and other oddities. This will help you
debug your software.
The LIBUSB_DEBUG environment variable overrules the debug level set by this
function. The message verbosity is fixed to the value in the environment
variable if it is defined.
If @libusb@ was compiled without any message logging, this function does nothing:
you'll never get any messages.
If @libusb@ was compiled with verbose debug message logging, this function does
nothing: you'll always get messages from all levels.
-}
setDebug ∷ Ctx → Verbosity → IO ()
setDebug ctx verbosity = withCtxPtr ctx $ \ctxPtr →
c'libusb_set_debug ctxPtr $ genFromEnum verbosity
-- | Message verbosity
data Verbosity =
PrintNothing -- ^ No messages are ever printed by the library
| PrintErrors -- ^ Error messages are printed to stderr
| PrintWarnings -- ^ Warning and error messages are printed to stderr
| PrintInfo -- ^ Informational messages are printed to stdout,
-- warning and error messages are printed to stderr
deriving (Enum, Ord, COMMON_INSTANCES)
--------------------------------------------------------------------------------
-- * Enumeration
--------------------------------------------------------------------------------
{-| Abstract type representing a USB device detected on the system.
You can only obtain a USB device from the 'getDevices' function.
Certain operations can be performed on a device, but in order to do any I/O you
will have to first obtain a 'DeviceHandle' using 'openDevice'.
Just because you have a reference to a device does not mean it is necessarily
usable. The device may have been unplugged, you may not have permission to
operate such device or another process or driver may be using the device.
To get additional information about a device you can retrieve its descriptor
using 'getDeviceDesc'.
-}
data Device = Device
{ getCtx ∷ !Ctx -- ^ This reference to the 'Ctx' is needed so that it won't
-- gets garbage collected. The finalizer @libusb_exit@ is
-- run only when all references to 'Devices' are gone.
, getDevFrgnPtr ∷ !(ForeignPtr C'libusb_device)
} deriving Typeable
instance Eq Device where (==) = (==) `on` getDevFrgnPtr
-- | Devices are shown as: @Bus \<'busNumber'\> Device \<'deviceAddress'\>@
instance Show Device where
show d = printf "Bus %03d Device %03d" (busNumber d) (deviceAddress d)
withDevicePtr ∷ Device → (Ptr C'libusb_device → IO α) → IO α
withDevicePtr (Device ctx devFP ) f = do
x ← withForeignPtr devFP f
touchForeignPtr $ getCtxFrgnPtr ctx
return x
{-| Returns a vector of USB devices currently attached to the system.
This is your entry point into finding a USB device.
Exceptions:
* 'NoMemException' on a memory allocation failure.
-}
{-
Visual description of the 'devPtrArrayPtr':
D
^ D
D │ ^
^ │ │
│ │ │
devPtrArrayPtr: ┏━┷━┳━┷━┳━━━┳━━━┳━┷━┓
P ───> ┃ P ┃ P ┃ P ┃ P ┃ P ┃
┗━━━┻━━━┻━┯━┻━┯━┻━━━┛
│ │
P = pointer v │
D = device structure D │
v
D
-}
getDevices ∷ Ctx → IO (Vector Device)
getDevices ctx =
withCtxPtr ctx $ \ctxPtr →
alloca $ \devPtrArrayPtr → mask $ \restore → do
numDevs ← checkUSBException $ c'libusb_get_device_list ctxPtr
devPtrArrayPtr
devPtrArray ← peek devPtrArrayPtr
let freeDevPtrArray = c'libusb_free_device_list devPtrArray 0
devs ← restore (mapPeekArray mkDev numDevs devPtrArray)
`onException` freeDevPtrArray
freeDevPtrArray
return devs
where
mkDev ∷ Ptr C'libusb_device → IO Device
mkDev devPtr = Device ctx <$>
#ifdef mingw32_HOST_OS
FC.newForeignPtr devPtr
(c'libusb_unref_device devPtr)
#else
newForeignPtr p'libusb_unref_device devPtr
#endif
-- Both of the following numbers are static variables in the libusb device
-- structure. It's therefore safe to use unsafePerformIO:
-- | The number of the bus that a device is connected to.
busNumber ∷ Device → Word8
busNumber dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_bus_number
-- | The address of the device on the bus it is connected to.
deviceAddress ∷ Device → Word8
deviceAddress dev = unsafePerformIO $ withDevicePtr dev c'libusb_get_device_address
--------------------------------------------------------------------------------
-- * Device handling
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- ** Opening & closing devices
--------------------------------------------------------------------------------
{-| Abstract type representing a handle of a USB device.
You can acquire a handle from 'openDevice'.
A device handle is used to perform I/O and other operations. When finished with
a device handle you should close it by applying 'closeDevice' to it.
-}
data DeviceHandle = DeviceHandle
{ getDevice ∷ !Device -- This reference is needed for keeping the 'Device'
-- and therefor the 'Ctx' alive.
-- ^ Retrieve the 'Device' from the 'DeviceHandle'.
, getDevHndlPtr ∷ !(Ptr C'libusb_device_handle)
} deriving Typeable
instance Eq DeviceHandle where (==) = (==) `on` getDevHndlPtr
instance Show DeviceHandle where
show devHndl = "{USB device handle to: " ++ show (getDevice devHndl) ++ "}"
withDevHndlPtr ∷ DeviceHandle → (Ptr C'libusb_device_handle → IO α) → IO α
withDevHndlPtr (DeviceHandle (Device ctx devFrgnPtr) devHndlPtr) f = do
x ← f devHndlPtr
touchForeignPtr devFrgnPtr
touchForeignPtr $ getCtxFrgnPtr ctx
return x
{-| Open a device and obtain a device handle.
A handle allows you to perform I/O on the device in question.
This is a non-blocking function; no requests are sent over the bus.
It is advisable to use 'withDeviceHandle' because it automatically closes the
device when the computation terminates.
Exceptions:
* 'NoMemException' if there is a memory allocation failure.
* 'AccessException' if the user has insufficient permissions.
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
openDevice ∷ Device → IO DeviceHandle
openDevice dev = withDevicePtr dev $ \devPtr →
alloca $ \devHndlPtrPtr → do
handleUSBException $ c'libusb_open devPtr devHndlPtrPtr
DeviceHandle dev <$> peek devHndlPtrPtr
{-| Close a device handle.
Should be called on all open handles before your application exits.
This is a non-blocking function; no requests are sent over the bus.
-}
closeDevice ∷ DeviceHandle → IO ()
closeDevice devHndl = withDevHndlPtr devHndl c'libusb_close
{-| @withDeviceHandle dev act@ opens the 'Device' @dev@ and passes
the resulting handle to the computation @act@. The handle will be closed on exit
from @withDeviceHandle@ whether by normal termination or by raising an
exception.
-}
withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α
withDeviceHandle dev = bracket (openDevice dev) closeDevice
--------------------------------------------------------------------------------
-- ** Getting & setting the configuration
--------------------------------------------------------------------------------
-- | Identifier for configurations.
--
-- Can be retrieved by 'getConfig' or by 'configValue'.
type ConfigValue = Word8
{-| Determine the value of the currently active configuration.
You could formulate your own control request to obtain this information, but
this function has the advantage that it may be able to retrieve the information
from operating system caches (no I/O involved).
If the OS does not cache this information, then this function will block while
a control transfer is submitted to retrieve the information.
This function returns 'Nothing' if the device is in unconfigured state.
Exceptions:
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
getConfig ∷ DeviceHandle → IO (Maybe ConfigValue)
getConfig devHndl =
alloca $ \configPtr → do
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_get_configuration devHndlPtr configPtr
unmarshal <$> peek configPtr
where
unmarshal 0 = Nothing
unmarshal n = Just $ fromIntegral n
{-| Set the active configuration for a device.
The operating system may or may not have already set an active configuration on
the device. It is up to your application to ensure the correct configuration is
selected before you attempt to claim interfaces and perform other operations.
If you call this function on a device already configured with the selected
configuration, then this function will act as a lightweight device reset: it
will issue a SET_CONFIGURATION request using the current configuration, causing
most USB-related device state to be reset (altsetting reset to zero, endpoint
halts cleared, toggles reset).
You cannot change/reset configuration if your application has claimed interfaces
- you should free them with 'releaseInterface' first. You cannot change/reset
configuration if other applications or drivers have claimed interfaces.
A configuration value of 'Nothing' will put the device in an unconfigured
state. The USB specification states that a configuration value of 0 does this,
however buggy devices exist which actually have a configuration 0.
You should always use this function rather than formulating your own
SET_CONFIGURATION control request. This is because the underlying operating
system needs to know when such changes happen.
This is a blocking function.
Exceptions:
* 'NotFoundException' if the requested configuration does not exist.
* 'BusyException' if interfaces are currently claimed.
* 'NoDeviceException' if the device has been disconnected
* Another 'USBException'.
-}
setConfig ∷ DeviceHandle → Maybe ConfigValue → IO ()
setConfig devHndl config =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_set_configuration devHndlPtr $
marshal config
where
marshal = maybe (-1) fromIntegral
--------------------------------------------------------------------------------
-- ** Claiming & releasing interfaces
--------------------------------------------------------------------------------
{-| Identifier for interfaces.
Can be retrieved by 'interfaceNumber'.
-}
type InterfaceNumber = Word8
{-| Claim an interface on a given device handle.
You must claim the interface you wish to use before you can perform I/O on any
of its endpoints.
It is legal to attempt to claim an already-claimed interface, in which case this
function just returns without doing anything.
Claiming of interfaces is a purely logical operation; it does not cause any
requests to be sent over the bus. Interface claiming is used to instruct the
underlying operating system that your application wishes to take ownership of
the interface.
This is a non-blocking function.
Exceptions:
* 'NotFoundException' if the requested interface does not exist.
* 'BusyException' if the interface is already claimed.
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
claimInterface ∷ DeviceHandle → InterfaceNumber → IO ()
claimInterface devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_claim_interface devHndlPtr
(fromIntegral ifNum)
{-| Release an interface previously claimed with 'claimInterface'.
You should release all claimed interfaces before closing a device handle.
This is a blocking function. A SET_INTERFACE control request will be sent to the
device, resetting interface state to the first alternate setting.
Exceptions:
* 'NotFoundException' if the interface was not claimed.
* 'NoDeviceException' if the device has been disconnected
* Another 'USBException'.
-}
releaseInterface ∷ DeviceHandle → InterfaceNumber → IO ()
releaseInterface devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_release_interface devHndlPtr
(fromIntegral ifNum)
{-| @withClaimedInterface@ claims the interface on the given device handle then
executes the given computation. On exit from @withClaimedInterface@, the
interface is released whether by normal termination or by raising an exception.
-}
withClaimedInterface ∷ DeviceHandle → InterfaceNumber → IO α → IO α
withClaimedInterface devHndl ifNum = bracket_ (claimInterface devHndl ifNum)
(releaseInterface devHndl ifNum)
--------------------------------------------------------------------------------
-- ** Setting interface alternate settings
--------------------------------------------------------------------------------
-- | Identifier for interface alternate settings.
--
-- Can be retrieved by 'interfaceAltSetting'.
type InterfaceAltSetting = Word8
{-| Activate an alternate setting for an interface.
The interface must have been previously claimed with 'claimInterface'.
You should always use this function rather than formulating your own
SET_INTERFACE control request. This is because the underlying operating system
needs to know when such changes happen.
This is a blocking function.
Exceptions:
* 'NotFoundException' if the interface was not claimed or the requested
alternate setting does not exist.
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
setInterfaceAltSetting ∷ DeviceHandle
→ InterfaceNumber
→ InterfaceAltSetting
→ IO ()
setInterfaceAltSetting devHndl ifNum alternateSetting =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $
c'libusb_set_interface_alt_setting devHndlPtr
(fromIntegral ifNum)
(fromIntegral alternateSetting)
--------------------------------------------------------------------------------
-- ** Clearing & Resetting devices
--------------------------------------------------------------------------------
{-| Clear the halt/stall condition for an endpoint.
Endpoints with halt status are unable to receive or transmit data until the halt
condition is stalled.
You should cancel all pending transfers before attempting to clear the halt
condition.
This is a blocking function.
Exceptions:
* 'NotFoundException' if the endpoint does not exist.
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
clearHalt ∷ DeviceHandle → EndpointAddress → IO ()
clearHalt devHndl endpointAddr =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $
c'libusb_clear_halt devHndlPtr (marshalEndpointAddress endpointAddr)
{-| Perform a USB port reset to reinitialize a device.
The system will attempt to restore the previous configuration and alternate
settings after the reset has completed.
If the reset fails, the descriptors change, or the previous state cannot be
restored, the device will appear to be disconnected and reconnected. This means
that the device handle is no longer valid (you should close it) and rediscover
the device. A 'NotFoundException' is raised to indicate that this is the
case.
This is a blocking function which usually incurs a noticeable delay.
Exceptions:
* 'NotFoundException' if re-enumeration is required, or if the
device has been disconnected.
* Another 'USBException'.
-}
resetDevice ∷ DeviceHandle → IO ()
resetDevice devHndl = withDevHndlPtr devHndl $
handleUSBException . c'libusb_reset_device
--------------------------------------------------------------------------------
-- ** USB kernel drivers
--------------------------------------------------------------------------------
{-| Determine if a kernel driver is active on an interface.
If a kernel driver is active, you cannot claim the interface, and libusb will be
unable to perform I/O.
Exceptions:
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
kernelDriverActive ∷ DeviceHandle → InterfaceNumber → IO Bool
kernelDriverActive devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr → do
r ← c'libusb_kernel_driver_active devHndlPtr (fromIntegral ifNum)
case r of
0 → return False
1 → return True
_ → throwIO $ convertUSBException r
{-| Detach a kernel driver from an interface.
If successful, you will then be able to claim the interface and perform I/O.
Exceptions:
* 'NotFoundException' if no kernel driver was active.
* 'InvalidParamException' if the interface does not exist.
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
detachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()
detachKernelDriver devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_detach_kernel_driver devHndlPtr
(fromIntegral ifNum)
{-| Re-attach an interface's kernel driver, which was previously
detached using 'detachKernelDriver'.
Exceptions:
* 'NotFoundException' if no kernel driver was active.
* 'InvalidParamException' if the interface does not exist.
* 'NoDeviceException' if the device has been disconnected.
* 'BusyException' if the driver cannot be attached because the interface
is claimed by a program or driver.
* Another 'USBException'.
-}
attachKernelDriver ∷ DeviceHandle → InterfaceNumber → IO ()
attachKernelDriver devHndl ifNum =
withDevHndlPtr devHndl $ \devHndlPtr →
handleUSBException $ c'libusb_attach_kernel_driver devHndlPtr
(fromIntegral ifNum)
{-| If a kernel driver is active on the specified interface the driver is
detached and the given action is executed. If the action terminates, whether by
normal termination or by raising an exception, the kernel driver is attached
again. If a kernel driver is not active on the specified interface the action is
just executed.
Exceptions:
* 'NoDeviceException' if the device has been disconnected.
* Another 'USBException'.
-}
withDetachedKernelDriver ∷ DeviceHandle → InterfaceNumber → IO α → IO α
withDetachedKernelDriver devHndl ifNum action =
ifM (kernelDriverActive devHndl ifNum)
(bracket_ (detachKernelDriver devHndl ifNum)
(attachKernelDriver devHndl ifNum)
action)
action
--------------------------------------------------------------------------------
-- * Descriptors
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- ** Device descriptor
--------------------------------------------------------------------------------
{-| A structure representing the standard USB device descriptor.
This descriptor is documented in section 9.6.1 of the USB 2.0 specification.
This structure can be retrieved by 'deviceDesc'.
-}
data DeviceDesc = DeviceDesc
{ -- | USB specification release number.
deviceUSBSpecReleaseNumber ∷ !ReleaseNumber
-- | USB-IF class code for the device.
, deviceClass ∷ !Word8
-- | USB-IF subclass code for the device, qualified by the 'deviceClass'
-- value.
, deviceSubClass ∷ !Word8
-- | USB-IF protocol code for the device, qualified by the 'deviceClass'
-- and 'deviceSubClass' values.
, deviceProtocol ∷ !Word8
-- | Maximum packet size for endpoint 0.
, deviceMaxPacketSize0 ∷ !Word8
-- | USB-IF vendor ID.
, deviceVendorId ∷ !VendorId
-- | USB-IF product ID.
, deviceProductId ∷ !ProductId
-- | Device release number.
, deviceReleaseNumber ∷ !ReleaseNumber
-- | Optional index of string descriptor describing manufacturer.
, deviceManufacturerStrIx ∷ !(Maybe StrIx)
-- | Optional index of string descriptor describing product.
, deviceProductStrIx ∷ !(Maybe StrIx)
-- | Optional index of string descriptor containing device serial number.
, deviceSerialNumberStrIx ∷ !(Maybe StrIx)
-- | Number of possible configurations.
, deviceNumConfigs ∷ !Word8
} deriving (COMMON_INSTANCES)
type ReleaseNumber = (Int, Int, Int, Int)
type VendorId = Word16
type ProductId = Word16
--------------------------------------------------------------------------------
-- ** Configuration descriptor
--------------------------------------------------------------------------------
{-| A structure representing the standard USB configuration descriptor.
This descriptor is documented in section 9.6.3 of the USB 2.0 specification.
This structure can be retrieved by 'getConfigDesc'.
-}
data ConfigDesc = ConfigDesc
{ -- | Identifier value for the configuration.
configValue ∷ !ConfigValue
-- | Optional index of string descriptor describing the configuration.
, configStrIx ∷ !(Maybe StrIx)
-- | Configuration characteristics.
, configAttribs ∷ !ConfigAttribs
-- | Maximum power consumption of the USB device from the bus in the
-- configuration when the device is fully operational. Expressed in 2 mA
-- units (i.e., 50 = 100 mA).
, configMaxPower ∷ !Word8
-- | Vector of interfaces supported by the configuration.
, configInterfaces ∷ !(Vector Interface)
-- | Extra descriptors. If @libusb@ encounters unknown configuration
-- descriptors, it will store them here, should you wish to parse them.
, configExtra ∷ !B.ByteString
} deriving (COMMON_INSTANCES)
--------------------------------------------------------------------------------
-- *** Configuration attributes
--------------------------------------------------------------------------------
-- | The USB 2.0 specification specifies that the configuration attributes only
-- describe the device status.
type ConfigAttribs = DeviceStatus
data DeviceStatus = DeviceStatus
{ remoteWakeup ∷ !Bool -- ^ The Remote Wakeup field indicates whether the
-- device is currently enabled to request remote
-- wakeup. The default mode for devices that
-- support remote wakeup is disabled.
, selfPowered ∷ !Bool -- ^ The Self Powered field indicates whether the
-- device is currently self-powered
} deriving (COMMON_INSTANCES)
--------------------------------------------------------------------------------
-- ** Interface descriptor
--------------------------------------------------------------------------------
-- | An interface is represented as a vector of alternate interface settings.
type Interface = Vector InterfaceDesc