module System.FTDI.Internal where
import Control.Applicative ( Applicative, (<$>), Alternative )
import Control.Exception ( Exception, bracket, throwIO )
import Control.Monad ( Functor
, Monad, (>>=), (>>), (=<<), return, fail
, liftM
, MonadPlus
)
import Control.Monad.Fix ( MonadFix )
import Data.Bool ( Bool, otherwise )
import Data.Bits ( Bits, (.|.)
, setBit, shiftL, shiftR, testBit
)
import Data.Data ( Data )
import Data.Eq ( Eq, (==) )
import Data.Function ( ($), on )
import Data.Int ( Int )
import Data.List ( foldr, head, minimumBy, partition, zip )
import Data.Maybe ( Maybe(Just, Nothing), maybe )
import Data.Ord ( Ord, (<), (>), compare )
import Data.Tuple ( fst, snd )
import Data.Typeable ( Typeable )
import Data.Word ( Word8, Word16 )
import Prelude ( Enum, succ
, Bounded, minBound, maxBound
, Num, (+), (), Integral, (^)
, Fractional, Real, RealFrac
, Double, Integer
, fromEnum, fromInteger, fromIntegral
, realToFrac, floor, ceiling
, div, error
)
import System.IO ( IO )
import Text.Read ( Read )
import Text.Show ( Show )
import Data.Eq.Unicode ( (≡) )
import Data.Function.Unicode ( (∘) )
import Data.Monoid.Unicode ( (⊕) )
import Prelude.Unicode ( (⋅), (÷) )
import qualified Data.ByteString as BS ( drop, length, null, splitAt, unpack )
#ifdef __HADDOCK__
import qualified Data.ByteString as BS ( empty )
#endif
import Data.ByteString ( ByteString )
import System.FTDI.Utils ( divRndUp, clamp, genFromEnum, orBits )
import Safe ( atMay, headMay )
import Control.Monad.Trans ( MonadTrans, MonadIO, liftIO )
import Control.Monad.Trans.State ( StateT, get, put, runStateT )
import qualified System.USB as USB
data FTDIException = InterfaceNotFound deriving (Show, Data, Typeable)
instance Exception FTDIException
type RequestCode = Word8
type RequestValue = Word16
reqReset ∷ RequestCode
reqSetModemCtrl ∷ RequestCode
reqSetFlowCtrl ∷ RequestCode
reqSetBaudRate ∷ RequestCode
reqSetData ∷ RequestCode
reqPollModemStatus ∷ RequestCode
reqSetEventChar ∷ RequestCode
reqSetErrorChar ∷ RequestCode
reqSetLatencyTimer ∷ RequestCode
reqGetLatencyTimer ∷ RequestCode
reqSetBitMode ∷ RequestCode
reqReadPins ∷ RequestCode
reqReadEEPROM ∷ RequestCode
reqWriteEEPROM ∷ RequestCode
reqEraseEEPROM ∷ RequestCode
reqReset = 0x00
reqSetModemCtrl = 0x01
reqSetFlowCtrl = 0x02
reqSetBaudRate = 0x03
reqSetData = 0x04
reqPollModemStatus = 0x05
reqSetEventChar = 0x06
reqSetErrorChar = 0x07
reqSetLatencyTimer = 0x09
reqGetLatencyTimer = 0x0A
reqSetBitMode = 0x0B
reqReadPins = 0x0C
reqReadEEPROM = 0x90
reqWriteEEPROM = 0x91
reqEraseEEPROM = 0x92
valResetSIO ∷ RequestValue
valPurgeReadBuffer ∷ RequestValue
valPurgeWriteBuffer ∷ RequestValue
valResetSIO = 0
valPurgeReadBuffer = 1
valPurgeWriteBuffer = 2
valSetDTRHigh ∷ RequestValue
valSetDTRLow ∷ RequestValue
valSetRTSHigh ∷ RequestValue
valSetRTSLow ∷ RequestValue
valSetDTRHigh = 0x0101
valSetDTRLow = 0x0100
valSetRTSHigh = 0x0202
valSetRTSLow = 0x0200
defaultTimeout ∷ Int
defaultTimeout = 5000
data Device = Device
{ devUSB ∷ USB.Device
, devUSBConf ∷ USB.ConfigDesc
, devChipType ∷ ChipType
}
data ChipType = ChipType_AM
| ChipType_BM
| ChipType_2232C
| ChipType_R
| ChipType_2232H
| ChipType_4232H
deriving (Enum, Eq, Ord, Show, Data, Typeable)
getChipType ∷ Device → ChipType
getChipType = devChipType
setChipType ∷ Device → ChipType → Device
setChipType dev ct = dev {devChipType = ct}
fromUSBDevice ∷ USB.Device
→ ChipType
→ Device
fromUSBDevice dev chip =
Device { devUSB = dev
, devUSBConf = head ∘ USB.deviceConfigs $ USB.deviceDesc dev
, devChipType = chip
}
guessChipType ∷ USB.DeviceDesc → Maybe ChipType
guessChipType desc = case USB.deviceReleaseNumber desc of
(0,2,0,0) | USB.deviceSerialNumberStrIx desc ≡ 0
→ Just ChipType_BM
| otherwise → Just ChipType_AM
(0,4,0,0) → Just ChipType_BM
(0,5,0,0) → Just ChipType_2232C
(0,6,0,0) → Just ChipType_R
(0,7,0,0) → Just ChipType_2232H
(0,8,0,0) → Just ChipType_4232H
_ → Nothing
data Interface = Interface_A
| Interface_B
| Interface_C
| Interface_D
deriving (Enum, Eq, Ord, Show, Data, Typeable)
interfaceIndex ∷ Interface → Word16
interfaceIndex = succ ∘ genFromEnum
interfaceToUSB ∷ Interface → USB.InterfaceNumber
interfaceToUSB = genFromEnum
interfaceEndPointIn ∷ Interface → USB.EndpointAddress
interfaceEndPointIn i =
USB.EndpointAddress { USB.endpointNumber = 1 + 2 â‹… genFromEnum i
, USB.transferDirection = USB.In
}
interfaceEndPointOut ∷ Interface → USB.EndpointAddress
interfaceEndPointOut i =
USB.EndpointAddress { USB.endpointNumber = 2 + 2 â‹… genFromEnum i
, USB.transferDirection = USB.Out
}
data DeviceHandle = DeviceHandle
{ devHndUSB ∷ USB.DeviceHandle
, devHndDev ∷ Device
, devHndTimeout ∷ Int
}
resetUSB ∷ DeviceHandle → IO ()
resetUSB = USB.resetDevice ∘ devHndUSB
getTimeout ∷ DeviceHandle → Int
getTimeout = devHndTimeout
setTimeout ∷ DeviceHandle → Int → DeviceHandle
setTimeout devHnd timeout = devHnd {devHndTimeout = timeout}
openDevice ∷ Device → IO DeviceHandle
openDevice dev = do
handle ↠USB.openDevice $ devUSB dev
USB.setConfig handle $ USB.configValue $ devUSBConf dev
return DeviceHandle { devHndUSB = handle
, devHndDev = dev
, devHndTimeout = defaultTimeout
}
closeDevice ∷ DeviceHandle → IO ()
closeDevice = USB.closeDevice ∘ devHndUSB
withDeviceHandle ∷ Device → (DeviceHandle → IO α) → IO α
withDeviceHandle dev = bracket (openDevice dev) closeDevice
data InterfaceHandle = InterfaceHandle
{ ifHndDevHnd ∷ DeviceHandle
, ifHndInterface ∷ Interface
, ifHndInEPDesc ∷ USB.EndpointDesc
, ifHndOutEPDesc ∷ USB.EndpointDesc
}
getDeviceHandle ∷ InterfaceHandle → DeviceHandle
getDeviceHandle = ifHndDevHnd
getInterface ∷ InterfaceHandle → Interface
getInterface = ifHndInterface
openInterface ∷ DeviceHandle → Interface → IO InterfaceHandle
openInterface devHnd i =
let conf = devUSBConf $ devHndDev devHnd
ifIx = fromEnum i
mIfDesc = headMay =<< USB.configInterfaces conf `atMay` ifIx
mInOutEps = partition ((USB.In ≡) ∘ USB.transferDirection ∘ USB.endpointAddress)
∘ USB.interfaceEndpoints
<$> mIfDesc
mInEp = headMay ∘ fst =<< mInOutEps
mOutEp = headMay ∘ snd =<< mInOutEps
in maybe (throwIO InterfaceNotFound)
( \ifHnd → do USB.claimInterface (devHndUSB devHnd) (interfaceToUSB i)
return ifHnd
)
$ do inEp ↠mInEp
outEp ↠mOutEp
return InterfaceHandle
{ ifHndDevHnd = devHnd
, ifHndInterface = i
, ifHndInEPDesc = inEp
, ifHndOutEPDesc = outEp
}
closeInterface ∷ InterfaceHandle → IO ()
closeInterface ifHnd =
USB.releaseInterface (devHndUSB $ ifHndDevHnd ifHnd)
(interfaceToUSB $ ifHndInterface ifHnd)
withInterfaceHandle ∷ DeviceHandle → Interface → (InterfaceHandle → IO α) → IO α
withInterfaceHandle h i = bracket (openInterface h i) closeInterface
newtype ChunkedReaderT m α = ChunkedReaderT {unCR ∷ StateT ByteString m α}
deriving ( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, MonadTrans
, MonadIO
, MonadFix
)
runChunkedReaderT ∷ ChunkedReaderT m α → ByteString → m (α, ByteString)
runChunkedReaderT = runStateT ∘ unCR
readData ∷ ∀ m. MonadIO m ⇒ InterfaceHandle → Int → ChunkedReaderT m [ByteString]
readData ifHnd numBytes = ChunkedReaderT $
do prevRest ↠get
let readNumBytes = numBytes BS.length prevRest
if readNumBytes > 0
then do chunks ↠readLoop readNumBytes
return $ if BS.null prevRest
then chunks
else prevRest : chunks
else let (bs, newRest) = BS.splitAt numBytes prevRest
in put newRest >> return [bs]
where
readLoop ∷ Int → StateT ByteString m [ByteString]
readLoop readNumBytes = do
let reqSize = packetSize â‹… reqPackets
reqPackets = readNumBytes `divRndUp` packetDataSize
(bytes, _) ↠liftIO $ readBulk ifHnd reqSize
let receivedDataBytes = receivedBytes receivedHeaderBytes
receivedBytes = BS.length bytes
receivedHeaderBytes = packetHeaderSize â‹… receivedPackets
receivedPackets = receivedBytes `divRndUp` packetSize
if receivedDataBytes < readNumBytes
then let xs = splitPackets bytes
in liftM (xs ⊕) (readLoop $ readNumBytes receivedDataBytes)
else
let (bs, newRest) = BS.splitAt (splitIndex readNumBytes) bytes
in put newRest >> return (splitPackets bs)
splitIndex n = p â‹… packetSize + packetHeaderSize
+ (n p â‹… packetDataSize)
where p = n `div` packetDataSize
packetDataSize = packetSize packetHeaderSize
packetHeaderSize = 2
packetSize = USB.maxPacketSize
∘ USB.endpointMaxPacketSize
$ ifHndInEPDesc ifHnd
splitPackets xs | BS.null xs = []
| otherwise = case BS.splitAt packetSize xs of
(a, b) → BS.drop 2 a : splitPackets b
readBulk ∷ InterfaceHandle
→ Int
→ IO (ByteString, Bool)
readBulk ifHnd numBytes =
USB.readBulk (devHndUSB $ ifHndDevHnd ifHnd)
(interfaceEndPointIn $ ifHndInterface ifHnd)
(devHndTimeout $ ifHndDevHnd ifHnd)
numBytes
writeBulk ∷ InterfaceHandle
→ ByteString
→ IO (Int, Bool)
writeBulk ifHnd bs =
USB.writeBulk (devHndUSB $ ifHndDevHnd ifHnd)
(interfaceEndPointOut $ ifHndInterface ifHnd)
(devHndTimeout $ ifHndDevHnd ifHnd)
bs
type USBControl α = USB.DeviceHandle
→ USB.RequestType
→ USB.Recipient
→ RequestCode
→ RequestValue
→ Word16
→ USB.Timeout
→ α
genControl ∷ USBControl α
→ Word16
→ InterfaceHandle
→ RequestCode
→ RequestValue
→ α
genControl usbCtrl index ifHnd request value =
usbCtrl usbHnd
USB.Vendor
USB.ToDevice
request
value
(index .|. (interfaceIndex $ ifHndInterface ifHnd))
(devHndTimeout devHnd)
where devHnd = ifHndDevHnd ifHnd
usbHnd = devHndUSB devHnd
control ∷ InterfaceHandle → RequestCode → Word16 → IO ()
control = genControl USB.control 0
readControl ∷ InterfaceHandle → RequestCode → Word16 → USB.Size → IO (ByteString, Bool)
readControl = genControl USB.readControl 0
writeControl ∷ InterfaceHandle → RequestCode → Word16 → ByteString → IO (USB.Size, Bool)
writeControl = genControl USB.writeControl 0
reset ∷ InterfaceHandle → IO ()
reset ifHnd = control ifHnd reqReset valResetSIO
purgeReadBuffer ∷ InterfaceHandle → IO ()
purgeReadBuffer ifHnd = control ifHnd reqReset valPurgeReadBuffer
purgeWriteBuffer ∷ InterfaceHandle → IO ()
purgeWriteBuffer ifHnd = control ifHnd reqReset valPurgeWriteBuffer
getLatencyTimer ∷ InterfaceHandle → IO Word8
getLatencyTimer ifHnd = do
(bs, _) ↠readControl ifHnd reqGetLatencyTimer 0 1
case BS.unpack bs of
[b] → return b
_ → error "System.FTDI.getLatencyTimer: failed"
setLatencyTimer ∷ InterfaceHandle → Word8 → IO ()
setLatencyTimer ifHnd latency = control ifHnd reqSetLatencyTimer
$ fromIntegral latency
data BitMode =
BitMode_Reset
| BitMode_BitBang
| BitMode_MPSSE
| BitMode_SyncBitBang
| BitMode_MCU
| BitMode_Opto
| BitMode_CBus
| BitMode_SyncFIFO
deriving (Eq, Ord, Show, Data, Typeable)
marshalBitMode ∷ BitMode → Word8
marshalBitMode bm = case bm of
BitMode_Reset → 0x00
BitMode_BitBang → 0x01
BitMode_MPSSE → 0x02
BitMode_SyncBitBang → 0x04
BitMode_MCU → 0x08
BitMode_Opto → 0x10
BitMode_CBus → 0x20
BitMode_SyncFIFO → 0x40
setBitMode ∷ InterfaceHandle → Word8 → BitMode → IO ()
setBitMode ifHnd bitMask bitMode = control ifHnd reqSetBitMode value
where bitMask' = fromIntegral bitMask
bitMode' = fromIntegral $ marshalBitMode bitMode
value = bitMask' .|. shiftL bitMode' 8
setBaudRate ∷ RealFrac α ⇒ InterfaceHandle → BaudRate α → IO (BaudRate α)
setBaudRate ifHnd baudRate =
do genControl USB.control ix ifHnd reqSetBaudRate val
return b
where
(val, ix) = encodeBaudRateDivisors chip d s
(d, s, b) = calcBaudRateDivisors chip baudRate
chip = devChipType $ devHndDev $ ifHndDevHnd ifHnd
data Parity =
Parity_Odd
| Parity_Even
| Parity_Mark
| Parity_Space
deriving (Enum, Eq, Ord, Show, Data, Typeable)
data BitDataFormat = Bits_7
| Bits_8
data StopBits = StopBit_1
| StopBit_15
| StopBit_2
deriving (Enum)
setLineProperty ∷ InterfaceHandle
→ BitDataFormat
→ StopBits
→ Maybe Parity
→ Bool
→ IO ()
setLineProperty ifHnd bitDataFormat stopBits parity break' =
control ifHnd
reqSetData
$ orBits [ case bitDataFormat of
Bits_7 → 7
Bits_8 → 8
, maybe 0 (\p → (1 + genFromEnum p) `shiftL` 8) parity
, genFromEnum stopBits `shiftL` 11
, genFromEnum break' `shiftL` 14
]
data ModemStatus = ModemStatus
{
msClearToSend ∷ Bool
, msDataSetReady ∷ Bool
, msRingIndicator ∷ Bool
, msReceiveLineSignalDetect ∷ Bool
, msDataReady ∷ Bool
, msOverrunError ∷ Bool
, msParityError ∷ Bool
, msFramingError ∷ Bool
, msBreakInterrupt ∷ Bool
, msTransmitterHoldingRegister ∷ Bool
, msTransmitterEmpty ∷ Bool
, msErrorInReceiverFIFO ∷ Bool
} deriving (Eq, Ord, Show, Data, Typeable)
marshalModemStatus ∷ ModemStatus → (Word8, Word8)
marshalModemStatus ms = (a, b)
where
a = mkByte $ zip [4..]
[ msClearToSend
, msDataSetReady
, msRingIndicator
, msReceiveLineSignalDetect
]
b = mkByte $ zip [0..]
[ msDataReady
, msOverrunError
, msParityError
, msFramingError
, msBreakInterrupt
, msTransmitterHoldingRegister
, msTransmitterEmpty
, msErrorInReceiverFIFO
]
mkByte ∷ [(Int, ModemStatus → Bool)] → Word8
mkByte ts = foldr (\(n, f) x → if f ms then setBit x n else x)
0
ts
unmarshalModemStatus ∷ Word8 → Word8 → ModemStatus
unmarshalModemStatus a b =
ModemStatus { msClearToSend = testBit a 4
, msDataSetReady = testBit a 5
, msRingIndicator = testBit a 6
, msReceiveLineSignalDetect = testBit a 7
, msDataReady = testBit b 0
, msOverrunError = testBit b 1
, msParityError = testBit b 2
, msFramingError = testBit b 3
, msBreakInterrupt = testBit b 4
, msTransmitterHoldingRegister = testBit b 5
, msTransmitterEmpty = testBit b 6
, msErrorInReceiverFIFO = testBit b 7
}
pollModemStatus ∷ InterfaceHandle → IO ModemStatus
pollModemStatus ifHnd = do
(bs, _) ↠readControl ifHnd reqPollModemStatus 0 2
case BS.unpack bs of
[x,y] → return $ unmarshalModemStatus x y
_ → error "System.FTDI.pollModemStatus: failed"
data FlowCtrl = RTS_CTS
| DTR_DSR
| XOnXOff
marshalFlowControl ∷ FlowCtrl → Word16
marshalFlowControl f = case f of
RTS_CTS → 0x0100
DTR_DSR → 0x0200
XOnXOff → 0x0400
setFlowControl ∷ InterfaceHandle → Maybe FlowCtrl → IO ()
setFlowControl ifHnd mFC = genControl USB.control
(maybe 0 marshalFlowControl mFC)
ifHnd
reqSetFlowCtrl
0
setDTR ∷ InterfaceHandle → Bool → IO ()
setDTR ifHnd b = control ifHnd reqSetModemCtrl
$ if b then valSetDTRHigh else valSetDTRLow
setRTS ∷ InterfaceHandle → Bool → IO ()
setRTS ifHnd b = control ifHnd reqSetModemCtrl
$ if b then valSetRTSHigh else valSetRTSLow
genSetCharacter ∷ RequestCode → InterfaceHandle → Maybe Word8 → IO ()
genSetCharacter req ifHnd mEC =
control ifHnd req $ maybe 0 (\c → setBit (fromIntegral c) 8) mEC
setEventCharacter ∷ InterfaceHandle → Maybe Word8 → IO ()
setEventCharacter = genSetCharacter reqSetEventChar
setErrorCharacter ∷ InterfaceHandle → Maybe Word8 → IO ()
setErrorCharacter = genSetCharacter reqSetErrorChar
newtype BRDiv α = BRDiv {unBRDiv ∷ α}
deriving ( Eq, Ord, Show, Read, Enum, Num, Integral
, Real, Fractional, RealFrac
)
instance Num α ⇒ Bounded (BRDiv α) where
minBound = 0
maxBound = 2 ^ (14 ∷ Int) 1
newtype BRSubDiv α = BRSubDiv {unBRSubDiv ∷ α}
deriving ( Eq, Ord, Show, Read, Enum, Num, Integral
, Real, Fractional, RealFrac
)
instance Num α ⇒ Bounded (BRSubDiv α) where
minBound = 0
maxBound = 7
newtype BaudRate α = BaudRate {unBaudRate ∷ α}
deriving ( Eq, Ord, Show, Read, Enum, Num, Integral
, Real, Fractional, RealFrac
)
instance Num α ⇒ Bounded (BaudRate α) where
minBound = fromIntegral
$ (ceiling ∷ BaudRate Double → BaudRate Integer)
$ calcBaudRate maxBound maxBound
maxBound = BaudRate 3000000
encodeBaudRateDivisors ∷ ChipType → BRDiv Int → BRSubDiv Int → (Word16, Word16)
encodeBaudRateDivisors chip d s = (v, i)
where
v = fromIntegral d .|. shiftL s' 14
i | ChipType_2232C ↠chip = shiftL (shiftR s' 2) 8
| otherwise = shiftR s' 2
s' = fromIntegral $ encodeSubDiv s ∷ Word16
encodeSubDiv ∷ BRSubDiv Int → Int
encodeSubDiv n =
case n of
0 → 0
4 → 1
2 → 2
1 → 3
3 → 4
5 → 5
6 → 6
7 → 7
_ → error "Illegal subdivisor"
nearestBaudRate ∷ RealFrac α ⇒ ChipType → BaudRate α → BaudRate α
nearestBaudRate chip baudRate = b
where (_, _, b) = calcBaudRateDivisors chip baudRate
calcBaudRateDivisors ∷ ∀ α. RealFrac α
⇒ ChipType
→ BaudRate α
→ (BRDiv Int, BRSubDiv Int, BaudRate α)
calcBaudRateDivisors _ 3000000 = (0, 0, 0)
calcBaudRateDivisors _ 2000000 = (1, 0, 0)
calcBaudRateDivisors chip baudRate =
minimumBy (compare `on` (\(_,_,x) → x))
[ (d, s, b')
| s ↠chipSubDivisors chip
, let s' = fromIntegral s ÷ 8
d = divisor baudRate s'
b' = calcBaudRate d s'
]
where
divisor ∷ Integral β ⇒ BaudRate α → BRSubDiv α → BRDiv β
divisor br s = clamp $ floor $ (maxBound br ⋅ s') ÷ br
where s' = BaudRate $ unBRSubDiv s
chipSubDivisors ∷ ChipType → [BRSubDiv Int]
chipSubDivisors ChipType_AM = [0, 1, 2, 4]
chipSubDivisors _ = [0..7]
calcBaudRate ∷ Fractional α ⇒ BRDiv Int → BRSubDiv α → BaudRate α
calcBaudRate 0 0 = maxBound
calcBaudRate 1 0 = 2000000
calcBaudRate d s = maxBound ÷ BaudRate (realToFrac d + unBRSubDiv s)