module System.Modbus.TCP
( TCP_ADU(..)
, Header(..)
, FunctionCode(..)
, ExceptionCode(..)
, MB_Exception(..)
, TransactionId
, ProtocolId
, UnitId
, command
, readCoils
, readDiscreteInputs
, readHoldingRegisters
, readInputRegisters
, writeSingleCoil
, writeSingleRegister
, writeMultipleRegisters
) where
import "base" Control.Exception.Base ( Exception )
import "base" Control.Monad ( replicateM, mzero )
import "base" Data.Functor ( void )
import "base" Data.Functor.Identity ( runIdentity )
import "base" Data.Word ( Word8, Word16 )
import "base" Data.Typeable ( Typeable )
import "cereal" Data.Serialize
( Serialize, Put, put, Get, get
, encode, decode
, runPut, runGet
, putWord8, putWord16be
, getWord8, getWord16be
, getByteString
)
import "bytestring" Data.ByteString ( ByteString )
import qualified "bytestring" Data.ByteString as BS
import qualified "network" Network.Socket as S hiding ( send, recv )
import qualified "network" Network.Socket.ByteString as S ( send, recv )
import "transformers" Control.Monad.IO.Class ( liftIO )
import "transformers" Control.Monad.Trans.Except
type TransactionId = Word16
type ProtocolId = Word16
type UnitId = Word8
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 tid pid len uid) =
putWord16be tid >> putWord16be pid >> putWord16be len >> putWord8 uid
get = Header <$> getWord16be <*> getWord16be <*> getWord16be <*> 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 MB_Exception
= ExceptionResponse FunctionCode ExceptionCode
| DecodeException String
| OtherException String
deriving (Eq, Show, Typeable)
instance Exception MB_Exception
command
:: TransactionId
-> ProtocolId
-> UnitId
-> FunctionCode
-> ByteString
-> S.Socket
-> ExceptT MB_Exception IO TCP_ADU
command tid pid uid fc fdata socket = do
result <- liftIO $ do
void $ S.send socket $ encode cmd
S.recv socket 512
adu <- withExceptT DecodeException $ ExceptT $ pure $ decode result
mapExceptT (pure . runIdentity)
(checkResponse adu)
where
cmd = TCP_ADU (Header tid pid (fromIntegral $ 2 + BS.length fdata) uid)
fc
fdata
checkResponse :: TCP_ADU -> Except MB_Exception TCP_ADU
checkResponse adu@(TCP_ADU _ fc bs) =
case fc of
ExceptionCode rc ->
throwE $ either DecodeException (ExceptionResponse rc)
$ decode bs
_ -> pure adu
readCoils
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> Word16
-> S.Socket
-> ExceptT MB_Exception IO [Word8]
readCoils tid pid uid addr count socket =
withAduData tid pid uid ReadCoils socket
(putWord16be addr >> putWord16be count)
decodeW8s
readDiscreteInputs
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> Word16
-> S.Socket
-> ExceptT MB_Exception IO [Word8]
readDiscreteInputs tid pid uid addr count socket =
withAduData tid pid uid ReadDiscreteInputs socket
(putWord16be addr >> putWord16be count)
decodeW8s
readHoldingRegisters
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> Word16
-> S.Socket
-> ExceptT MB_Exception IO [Word16]
readHoldingRegisters tid pid uid addr count socket =
withAduData tid pid uid ReadHoldingRegisters socket
(putWord16be addr >> putWord16be count)
decodeW16s
readInputRegisters
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> Word16
-> S.Socket
-> ExceptT MB_Exception IO [Word16]
readInputRegisters tid pid uid addr count socket =
withAduData tid pid uid ReadInputRegisters socket
(putWord16be addr >> putWord16be count)
decodeW16s
writeSingleCoil
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> Bool
-> S.Socket
-> ExceptT MB_Exception IO ()
writeSingleCoil tid pid uid addr value socket =
void $ command tid pid uid WriteSingleCoil
(runPut $ putWord16be addr >> putWord16be value')
socket
where
value' | value = 0xFF00
| otherwise = 0x0000
writeSingleRegister
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> Word16
-> S.Socket
-> ExceptT MB_Exception IO ()
writeSingleRegister tid pid uid addr value socket =
void $ command tid pid uid WriteSingleRegister
(runPut $ putWord16be addr >> putWord16be value)
socket
writeMultipleRegisters
:: TransactionId
-> ProtocolId
-> UnitId
-> Word16
-> [Word16]
-> S.Socket
-> ExceptT MB_Exception IO Word16
writeMultipleRegisters tid pid uid addr values socket =
withAduData tid pid uid WriteMultipleRegisters socket
(do putWord16be addr
putWord16be $ fromIntegral numRegs
putWord8 $ fromIntegral numRegs
mapM_ putWord16be values
)
(getWord16be >> getWord16be)
where
numRegs :: Int
numRegs = length values
withAduData
:: TransactionId
-> ProtocolId
-> UnitId
-> FunctionCode
-> S.Socket
-> Put
-> Get a
-> ExceptT MB_Exception IO a
withAduData tid pid uid fc socket fdata parser = do
adu <- command tid pid uid fc (runPut fdata) socket
withExceptT DecodeException $ ExceptT $ pure $ runGet parser $ aduData adu
decodeW8s :: Get [Word8]
decodeW8s = do n <- getWord8
replicateM (fromIntegral n) getWord8
decodeW16s :: Get [Word16]
decodeW16s = do n <- getWord8
replicateM (fromIntegral $ n `div` 2) getWord16be