module System.Modbus.TCP
(
Session
, runSession
, Connection(..)
, TCP_ADU(..)
, Header(..)
, FunctionCode(..)
, ExceptionCode(..)
, ModbusException(..)
, TransactionId(..)
, ProtocolId(..)
, UnitId(..)
, RegAddress(..)
, RetryPredicate
, command
, readCoils
, readDiscreteInputs
, readHoldingRegisters
, readInputRegisters
, writeSingleCoil
, writeSingleRegister
, writeMultipleRegisters
) where
import "base" Control.Exception.Base ( Exception )
import "base" Control.Monad ( replicateM, mzero )
import "base" Control.Monad.IO.Class ( MonadIO, liftIO )
import "base" Data.Bool ( bool )
import "base" Data.Functor ( void )
import "base" Data.Word ( Word8, Word16 )
import "base" Data.Typeable ( Typeable )
import "base" System.Timeout ( timeout )
import qualified "cereal" Data.Serialize as Cereal ( encode, decode )
import "cereal" Data.Serialize
( Serialize, Put, put, Get, get
, runPut, runGet
, putWord8, putWord16be
, getWord8, getWord16be
, getByteString
)
import "bytestring" Data.ByteString ( ByteString )
import qualified "bytestring" Data.ByteString as BS
import "mtl" Control.Monad.Reader ( MonadReader, ask )
import "mtl" Control.Monad.Except ( MonadError, throwError, catchError )
import "transformers" Control.Monad.Trans.Class ( lift )
import "transformers" Control.Monad.Trans.Except
( ExceptT(ExceptT), withExceptT )
import "transformers" Control.Monad.Trans.Reader
( ReaderT, runReaderT )
newtype TransactionId
= TransactionId { unTransactionId :: Word16 }
deriving (Eq, Num, Ord, Read, Show)
newtype ProtocolId
= ProtocolId { unProtocolId :: Word16 }
deriving (Eq, Num, Ord, Read, Show)
newtype UnitId
= UnitId { unUnitId :: Word8 }
deriving (Bounded, Enum, Eq, Num, Ord, Read, Show)
newtype RegAddress
= RegAddress { unRegAddress :: Word16 }
deriving (Bounded, Enum, Eq, Num, Ord, Read, Show)
type RetryPredicate
= Int
-> ModbusException
-> Bool
data Connection
= Connection
{ connWrite :: !(BS.ByteString -> IO Int)
, connRead :: !(Int -> IO BS.ByteString)
, connCommandTimeout :: !Int
, connRetryWhen :: !RetryPredicate
}
newtype Session a
= Session
{ runSession' :: ReaderT Connection (ExceptT ModbusException IO) a
} deriving ( Functor
, Applicative
, Monad
, MonadError ModbusException
, MonadReader Connection
, MonadIO
)
runSession :: Connection -> Session a -> ExceptT ModbusException IO a
runSession conn session = runReaderT (runSession' session) conn
data TCP_ADU
= TCP_ADU
{ aduHeader :: !Header
, aduFunction :: !FunctionCode
, aduData :: !ByteString
} deriving (Eq, Show)
instance Serialize TCP_ADU where
put (TCP_ADU header fc ws) = do
put header
put fc
mapM_ putWord8 (BS.unpack ws)
get = do
header <- get
fc <- get
ws <- getByteString $ fromIntegral (hdrLength header) 2
return $ TCP_ADU header fc ws
data Header
= Header
{ hdrTransactionId :: !TransactionId
, hdrProtocolId :: !ProtocolId
, hdrLength :: !Word16
, hdrUnitId :: !UnitId
} deriving (Eq, Show)
instance Serialize Header where
put (Header (TransactionId tid) (ProtocolId pid) len (UnitId uid)) =
putWord16be tid >> putWord16be pid >> putWord16be len >> putWord8 uid
get = Header
<$> (TransactionId <$> getWord16be)
<*> (ProtocolId <$> getWord16be)
<*> getWord16be
<*> (UnitId <$> getWord8)
data FunctionCode
=
ReadCoils
| ReadDiscreteInputs
| ReadHoldingRegisters
| ReadInputRegisters
| WriteSingleCoil
| WriteSingleRegister
| ReadExceptionStatus
| Diagnostics
| GetCommEventCounter
| GetCommEventLog
| WriteMultipleCoils
| WriteMultipleRegisters
| ReportSlaveID
| ReadFileRecord
| WriteFileRecord
| MaskWriteRegister
| ReadWriteMultipleRegisters
| ReadFIFOQueue
| EncapsulatedInterfaceTransport
| UserDefinedCode Word8
| ReservedCode Word8
| OtherCode Word8
| ExceptionCode FunctionCode
deriving (Eq, Show)
instance Serialize FunctionCode where
put = putWord8 . enc
where
enc :: FunctionCode -> Word8
enc ReadCoils = 0x01
enc ReadDiscreteInputs = 0x02
enc ReadHoldingRegisters = 0x03
enc ReadInputRegisters = 0x04
enc WriteSingleCoil = 0x05
enc WriteSingleRegister = 0x06
enc ReadExceptionStatus = 0x07
enc Diagnostics = 0x08
enc GetCommEventCounter = 0x0B
enc GetCommEventLog = 0x0C
enc WriteMultipleCoils = 0x0F
enc WriteMultipleRegisters = 0x10
enc ReportSlaveID = 0x11
enc ReadFileRecord = 0x14
enc WriteFileRecord = 0x15
enc MaskWriteRegister = 0x16
enc ReadWriteMultipleRegisters = 0x17
enc ReadFIFOQueue = 0x18
enc EncapsulatedInterfaceTransport = 0x2B
enc (UserDefinedCode code) = code
enc (ReservedCode code) = code
enc (OtherCode code) = code
enc (ExceptionCode fc) = 0x80 + enc fc
get = getWord8 >>= return . dec
where
dec :: Word8 -> FunctionCode
dec 0x01 = ReadCoils
dec 0x02 = ReadDiscreteInputs
dec 0x03 = ReadHoldingRegisters
dec 0x04 = ReadInputRegisters
dec 0x05 = WriteSingleCoil
dec 0x06 = WriteSingleRegister
dec 0x07 = ReadExceptionStatus
dec 0x08 = Diagnostics
dec 0x0B = GetCommEventCounter
dec 0x0C = GetCommEventLog
dec 0x0F = WriteMultipleCoils
dec 0x10 = WriteMultipleRegisters
dec 0x11 = ReportSlaveID
dec 0x14 = ReadFileRecord
dec 0x15 = WriteFileRecord
dec 0x16 = MaskWriteRegister
dec 0x17 = ReadWriteMultipleRegisters
dec 0x18 = ReadFIFOQueue
dec 0x2B = EncapsulatedInterfaceTransport
dec code | (code >= 65 && code <= 72)
|| (code >= 100 && code <= 110) = UserDefinedCode code
| code `elem` [9, 10, 13, 14, 41, 42, 90, 91, 125, 126, 127]
= ReservedCode code
| code >= 0x80 = ExceptionCode $ dec $ code 0x80
| otherwise = OtherCode code
data ExceptionCode
=
IllegalFunction
| IllegalDataAddress
| IllegalDataValue
| SlaveDeviceFailure
| Acknowledge
| SlaveDeviceBusy
| MemoryParityError
| GatewayPathUnavailable
| GatewayTargetDeviceFailedToRespond
deriving (Eq, Show)
instance Serialize ExceptionCode where
put = putWord8 . enc
where
enc IllegalFunction = 0x01
enc IllegalDataAddress = 0x02
enc IllegalDataValue = 0x03
enc SlaveDeviceFailure = 0x04
enc Acknowledge = 0x05
enc SlaveDeviceBusy = 0x06
enc MemoryParityError = 0x08
enc GatewayPathUnavailable = 0x0A
enc GatewayTargetDeviceFailedToRespond = 0x0B
get = getWord8 >>= dec
where
dec 0x01 = return IllegalFunction
dec 0x02 = return IllegalDataAddress
dec 0x03 = return IllegalDataValue
dec 0x04 = return SlaveDeviceFailure
dec 0x05 = return Acknowledge
dec 0x06 = return SlaveDeviceBusy
dec 0x08 = return MemoryParityError
dec 0x0A = return GatewayPathUnavailable
dec 0x0B = return GatewayTargetDeviceFailedToRespond
dec _ = mzero
data ModbusException
= ExceptionResponse !FunctionCode !ExceptionCode
| DecodeException !String
| CommandTimeout
| OtherException !String
deriving (Eq, Show, Typeable)
instance Exception ModbusException
command
:: TransactionId
-> ProtocolId
-> UnitId
-> FunctionCode
-> ByteString
-> Session TCP_ADU
command tid pid uid fc fdata = do
conn <- ask
Session $ lift $ withConn conn
where
withConn :: Connection -> ExceptT ModbusException IO TCP_ADU
withConn conn = go 1
where
go :: Int -> ExceptT ModbusException IO TCP_ADU
go !tries =
catchError
(command' conn tid pid uid fc fdata)
(\err ->
bool (throwError err)
(go $ tries + 1)
(connRetryWhen conn tries err)
)
command'
:: Connection
-> TransactionId
-> ProtocolId
-> UnitId
-> FunctionCode
-> ByteString
-> ExceptT ModbusException IO TCP_ADU
command' conn tid pid uid fc fdata = do
mbResult <- liftIO $ timeout (connCommandTimeout conn) $ do
void $ connWrite conn (Cereal.encode cmd)
connRead conn 512
result <- maybe (throwError CommandTimeout) pure mbResult
adu <- withExceptT DecodeException $ ExceptT $ pure $ Cereal.decode result
case aduFunction adu of
ExceptionCode rc ->
throwError
$ either DecodeException (ExceptionResponse rc)
$ Cereal.decode (aduData adu)
_ -> pure adu
where
cmd = TCP_ADU (Header tid pid (fromIntegral $ 2 + BS.length fdata) uid)
fc
fdata
readCoils
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> Word16
-> Session [Word8]
readCoils tid pid uid addr count =
withAduData tid pid uid ReadCoils
(putRegAddress addr >> putWord16be count)
decodeW8s
readDiscreteInputs
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> Word16
-> Session [Word8]
readDiscreteInputs tid pid uid addr count =
withAduData tid pid uid ReadDiscreteInputs
(putRegAddress addr >> putWord16be count)
decodeW8s
readHoldingRegisters
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> Word16
-> Session [Word16]
readHoldingRegisters tid pid uid addr count =
withAduData tid pid uid ReadHoldingRegisters
(putRegAddress addr >> putWord16be count)
decodeW16s
readInputRegisters
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> Word16
-> Session [Word16]
readInputRegisters tid pid uid addr count =
withAduData tid pid uid ReadInputRegisters
(putRegAddress addr >> putWord16be count)
decodeW16s
writeSingleCoil
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> Bool
-> Session ()
writeSingleCoil tid pid uid addr value =
void $ command tid pid uid WriteSingleCoil
(runPut $ putRegAddress addr >> putWord16be value')
where
value' | value = 0xFF00
| otherwise = 0x0000
writeSingleRegister
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> Word16
-> Session ()
writeSingleRegister tid pid uid addr value =
void $ command tid pid uid WriteSingleRegister
(runPut $ putRegAddress addr >> putWord16be value)
writeMultipleRegisters
:: TransactionId
-> ProtocolId
-> UnitId
-> RegAddress
-> [Word16]
-> Session Word16
writeMultipleRegisters tid pid uid addr values =
withAduData tid pid uid WriteMultipleRegisters
(do putRegAddress addr
putWord16be $ fromIntegral numRegs
putWord8 $ fromIntegral numRegs
mapM_ putWord16be values
)
(getWord16be >> getWord16be)
where
numRegs :: Int
numRegs = length values
withAduData
:: TransactionId
-> ProtocolId
-> UnitId
-> FunctionCode
-> Put
-> Get a
-> Session a
withAduData tid pid uid fc fdata parser = do
adu <- command tid pid uid fc (runPut fdata)
Session $ lift $ withExceptT DecodeException $ ExceptT $ pure $ runGet parser $ aduData adu
putRegAddress :: RegAddress -> Put
putRegAddress = putWord16be . unRegAddress
decodeW8s :: Get [Word8]
decodeW8s = do n <- getWord8
replicateM (fromIntegral n) getWord8
decodeW16s :: Get [Word16]
decodeW16s = do n <- getWord8
replicateM (fromIntegral $ n `div` 2) getWord16be