libmodbus (empty) → 1.0.0

raw patch · 6 files changed

+644/−0 lines, 6 filesdep +basedep +data-defaultdep +vectorsetup-changed

Dependencies added: base, data-default, vector

Files

• CHANGELOG +5/−0
• LICENSE +25/−0
• Setup.hs +5/−0
• System/Modbus.hsc +570/−0
• TODO +7/−0
• libmodbus.cabal +32/−0

@@ -0,0 +1,5 @@+haskell-libmodbus (1.0.0) unstable; urgency=medium++  * Initial release.++ -- Joey Hess <id@joeyh.name>  Tue, 20 Aug 2019 21:41:55 -0400

@@ -0,0 +1,25 @@+BSD 2-Clause License++Copyright (c) 2019, Joey Hess+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,5 @@+{- cabal setup file -}++import Distribution.Simple++main = defaultMain

@@ -0,0 +1,570 @@+{- | Haskell bindings to the C modbus library https://libmodbus.org/ -}++{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, CPP #-}++module System.Modbus (+	-- * Equivilance to the C library+	-- | Functions in this module are named the same as those in the C+	-- library, but without the leading "modbus_". You may wish to import+	-- this module qualified as Modbus to make the names match up.+	--+	-- See the C library documentation for details about the use+	-- of any function. https://libmodbus.org/documentation/+	--+	-- When a function in the C library returns a special value on+	-- error, this module will instead throw an exception.+	--+	-- This module has been tested with version 3.1.4 of the C library.+	-- It may also work with other versions.++	-- * Quick example+	-- +	-- | This example dumps some of the registers of an Epever solar +	-- charge controller.+	-- +	-- > import System.Modbus+	-- > import qualified Data.Vector.Storable as V+	-- > main = do+	-- > 	mb <- new_rtu "/dev/ttyS1" (Baud 115200) ParityNone (DataBits 8) (StopBits 1)+	-- >	set_slave mb (DeviceAddress 1)+	-- >	connect mb+	-- >	regs <- mkRegisterVector 10+	-- >	read_input_registers mb (Addr 0x3100) regs+	-- >	print =<< V.freeze regs++	-- * Contexts+	Context,++	-- * RTU Context+	Baud(..),+	Parity(..),+	DataBits(..),+	StopBits(..),+	new_rtu,+	SerialMode(..),+	rtu_get_serial_mode,+	rtu_set_serial_mode,+	RTS(..),+	rtu_get_rts,+	rtu_set_rts,+	rtu_get_rts_delay,+	rtu_set_rts_delay,++	-- * TCP (IPv4) Context+	IPAddress(..),+	Port(..),+	new_tcp,++	-- * TCP PI (IPv4 and IPv6) Context+	Node(..),+	Service(..),+	new_tcp_pi,++	-- * Configuration+	DeviceAddress(..),+	broadcastAddress,+	set_slave,+	connect,+	set_debug,+	Timeout(..),+	get_byte_timeout,+	set_byte_timeout,+	get_response_timeout,+	set_response_timeout,++	-- * Accessing registers+	Addr(..),+	RegisterVector,+	mkRegisterVector,+	read_registers,+	read_input_registers,+	write_registers,+	write_register,+	write_and_read_registers,++	-- * Accessing bits/coils+	BitVector,+	mkBitVector,+	Bit,+	boolBit,+	bitBool,+	read_bits,+	read_input_bits,+	write_bits,+	write_bit,+) where++#include <modbus/modbus.h>++import Foreign+import Foreign.C+import Data.Char+import Data.Default+import qualified Data.Vector.Storable.Mutable as V++foreign import ccall unsafe "modbus.h &modbus_close" modbus_close+	:: FunPtr (Ptr () -> IO ())++foreign import ccall unsafe "modbus.h &modbus_free" modbus_free+	:: FunPtr (Ptr () -> IO ())++foreign import ccall unsafe "modbus.h modbus_new_rtu" modbus_new_rtu+	:: CString -> Int -> CChar -> Int -> Int -> IO (Ptr ())++foreign import ccall unsafe "modbus.h modbus_rtu_get_serial_mode" modbus_rtu_get_serial_mode+	:: Ptr () -> IO Int++foreign import ccall unsafe "modbus.h modbus_rtu_set_serial_mode" modbus_rtu_set_serial_mode+	:: Ptr () -> Int -> IO Int++foreign import ccall unsafe "modbus.h modbus_rtu_get_rts" modbus_rtu_get_rts+	:: Ptr () -> IO Int++foreign import ccall unsafe "modbus.h modbus_rtu_set_rts" modbus_rtu_set_rts+	:: Ptr () -> Int -> IO Int++foreign import ccall unsafe "modbus.h modbus_rtu_get_rts_delay" modbus_rtu_get_rts_delay+	:: Ptr () -> IO Int++foreign import ccall unsafe "modbus.h modbus_rtu_set_rts_delay" modbus_rtu_set_rts_delay+	:: Ptr () -> Int -> IO Int++foreign import ccall unsafe "modbus.h modbus_new_tcp" modbus_new_tcp+	:: CString -> Int -> IO (Ptr ())++foreign import ccall unsafe "modbus.h modbus_new_tcp" modbus_new_tcp_pi+	:: CString -> CString -> IO (Ptr ())++foreign import ccall unsafe "modbus.h modbus_set_slave" modbus_set_slave+	:: Ptr () -> Int -> IO Int++foreign import ccall unsafe "modbus.h modbus_connect" modbus_connect+	:: Ptr () -> IO Int++foreign import ccall unsafe "modbus.h modbus_set_debug" modbus_set_debug+	:: Ptr () -> Int -> IO Int++foreign import ccall unsafe "modbus.h modbus_get_byte_timeout" modbus_get_byte_timeout+	:: Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int++foreign import ccall unsafe "modbus.h modbus_set_byte_timeout" modbus_set_byte_timeout+	:: Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int++foreign import ccall unsafe "modbus.h modbus_get_response_timeout" modbus_get_response_timeout+	:: Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int++foreign import ccall unsafe "modbus.h modbus_set_response_timeout" modbus_set_response_timeout+	:: Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int++foreign import ccall unsafe "modbus.h modbus_read_registers" modbus_read_registers+	:: Ptr () -> Int -> Int -> Ptr Word16 -> IO Int++foreign import ccall unsafe "modbus.h modbus_read_input_registers" modbus_read_input_registers+	:: Ptr () -> Int -> Int -> Ptr Word16 -> IO Int++foreign import ccall unsafe "modbus.h modbus_write_registers" modbus_write_registers+	:: Ptr () -> Int -> Int -> Ptr Word16 -> IO Int++foreign import ccall unsafe "modbus.h modbus_write_register" modbus_write_register+	:: Ptr () -> Int -> Word16 -> IO Int++foreign import ccall unsafe "modbus.h modbus_write_and_read_registers" modbus_write_and_read_registers+	:: Ptr () -> Int -> Int -> Ptr Word16 -> Int -> Int -> Ptr Word16 -> IO Int++foreign import ccall unsafe "modbus.h modbus_read_bits" modbus_read_bits+	:: Ptr () -> Int -> Int -> Ptr Word8 -> IO Int++foreign import ccall unsafe "modbus.h modbus_read_input_bits" modbus_read_input_bits+	:: Ptr () -> Int -> Int -> Ptr Word8 -> IO Int++foreign import ccall unsafe "modbus.h modbus_write_bits" modbus_write_bits+	:: Ptr () -> Int -> Int -> Ptr Word8 -> IO Int++foreign import ccall unsafe "modbus.h modbus_write_bit" modbus_write_bit+	:: Ptr () -> Int -> Int -> IO Int++accessVector+	:: Storable t+	=> Context+	-> Addr+	-> V.IOVector t+	-> (Ptr () -> Int -> Int -> Ptr t -> IO Int)+	-> String+	-> IO Int+accessVector h (Addr addr) v action actionname = withContext h $ \ctx -> do+	let (fptr, nb) = V.unsafeToForeignPtr0 v+	r <- withForeignPtr fptr $ action ctx addr nb+	if r == -1+		then throwErrno actionname+		else return r++-- | A modbus device context.+--+-- The context will automatically be closed and freed when it is+-- garbage collected.+data Context = Context (ForeignPtr ())++mkContext :: Ptr () -> IO Context+mkContext ctx = do+	ptr <- newForeignPtr_ ctx+	addForeignPtrFinalizer modbus_free ptr+	-- this will run before modbus_free+	addForeignPtrFinalizer modbus_close ptr+	return (Context ptr)++withContext :: Context -> (Ptr () -> IO a) -> IO a+withContext (Context ptr) = withForeignPtr ptr++newtype Baud = Baud Int+	deriving (Show, Eq)+ +data Parity = ParityNone | ParityEven | ParityOdd+	deriving (Show, Eq)++newtype DataBits = DataBits Int+	deriving (Show, Eq)++newtype StopBits = StopBits Int+	deriving (Show, Eq)++-- | Create a modbus Remote Terminal Unit context.+-- +-- The FilePath is the serial device to connect to.+new_rtu :: FilePath -> Baud -> Parity -> DataBits -> StopBits -> IO Context+new_rtu f (Baud b) p (DataBits d) (StopBits s) = do+	ctx <- withCString f $ \cf ->+		modbus_new_rtu cf b pc d s+	if ctx == nullPtr+		then throwErrno "modbus_new_rtu"+		else mkContext ctx+  where+	pc = fromIntegral $ ord $ case p of+		ParityNone -> 'N'+		ParityEven -> 'E'+		ParityOdd -> 'O'++-- | IPv4 address to connect to. In server mode, use AnyAddress to listen+-- to any addresses.+data IPAddress = IPAddress String | AnyAddress+	deriving (Show, Eq)++newtype Port = Port Int+	deriving (Show, Eq)++instance Default Port where+	def = Port #const (MODBUS_TCP_DEFAULT_PORT)++-- | Create a modbus TCP/IPv4 context.+new_tcp :: IPAddress -> Port -> IO Context+new_tcp ipaddr (Port port) = do+	ctx <- case ipaddr of+		IPAddress s ->+			withCString s $ \cipaddr ->+				modbus_new_tcp cipaddr port+		AnyAddress ->+			modbus_new_tcp nullPtr port+	if ctx == nullPtr+		then throwErrno "modbus_new_tcp"+		else mkContext ctx++-- | Host name or IP address to connect to. In server mode, use AnyNode+-- to listen to any addresses.+data Node = Node String | AnyNode+	deriving (Show, Eq)++-- | Service name/port number to connect to.+newtype Service = Service String+	deriving (Show, Eq)++instance Default Service where+	def = Service (show p)+	  where+		p :: Int+		p = #const (MODBUS_TCP_DEFAULT_PORT)++new_tcp_pi :: Node -> Service -> IO Context+new_tcp_pi node (Service service) = withCString service $ \cservice -> do+	ctx <- case node of+		Node s ->+			withCString s $ \cnode ->+				modbus_new_tcp_pi cnode cservice+		AnyNode ->+			modbus_new_tcp_pi nullPtr cservice+	if ctx == nullPtr+		then throwErrno "modbus_new_tcp_pi"+		else mkContext ctx++data SerialMode = RTU_RS232 | RTU_RS485+	deriving (Show, Eq)++rtu_get_serial_mode :: Context -> IO SerialMode+rtu_get_serial_mode h = withContext h $ \ctx -> do+	r <- modbus_rtu_get_serial_mode ctx+	if r == #const (MODBUS_RTU_RS232)+		then return RTU_RS232+		else if r == #const (MODBUS_RTU_RS485)+			then return RTU_RS485+			else throwErrno "modbus_rtu_get_serial_mode"++rtu_set_serial_mode :: Context -> SerialMode -> IO ()+rtu_set_serial_mode h m = withContext h $ \ctx -> do+	r <- modbus_rtu_set_serial_mode ctx $ case m of+		RTU_RS232 -> #const (MODBUS_RTU_RS232)+		RTU_RS485 -> #const (MODBUS_RTU_RS485)+	if r == 0+		then return ()+		else throwErrno "modbus_rtu_set_serial_mode"++data RTS = RTU_RTS_NONE | RTU_RTS_UP | RTU_RTS_DOWN+	deriving (Show, Eq)++rtu_get_rts :: Context -> IO RTS+rtu_get_rts h = withContext h $ \ctx -> do+	r <- modbus_rtu_get_rts ctx+	if r == #const (MODBUS_RTU_RTS_NONE)+		then return RTU_RTS_NONE+		else if r == #const (MODBUS_RTU_RTS_UP)+			then return RTU_RTS_UP+			else if r == #const (MODBUS_RTU_RTS_DOWN)+				then return RTU_RTS_DOWN+				else throwErrno "modbus_rtu_get_serial_mode"++rtu_set_rts :: Context -> RTS -> IO ()+rtu_set_rts h m = withContext h $ \ctx -> do+	r <- modbus_rtu_set_rts ctx $ case m of+		RTU_RTS_NONE -> #const (MODBUS_RTU_RTS_NONE)+		RTU_RTS_UP -> #const (MODBUS_RTU_RTS_UP)+		RTU_RTS_DOWN -> #const (MODBUS_RTU_RTS_DOWN)+	if r == 0+		then return ()+		else throwErrno "modbus_rtu_set_rts"++rtu_get_rts_delay :: Context -> IO Int+rtu_get_rts_delay h = withContext h $ \ctx -> do+	r <- modbus_rtu_get_rts_delay ctx+	if r /= -1+		then return r+		else throwErrno "modbus_rtu_get_rts_delay"++rtu_set_rts_delay :: Context -> Int -> IO ()+rtu_set_rts_delay h n = withContext h $ \ctx -> do+	r <- modbus_rtu_set_rts_delay ctx n+	if r == 0+		then return ()+		else throwErrno "modbus_rtu_set_rts_delay"++-- | The address of a modbus device.+newtype DeviceAddress = DeviceAddress Int+	deriving (Show, Eq)++broadcastAddress :: DeviceAddress+broadcastAddress = DeviceAddress #const (MODBUS_BROADCAST_ADDRESS)++-- | Set the address of the modbus device that the Context should+-- communicate with.+set_slave :: Context -> DeviceAddress -> IO ()+set_slave h (DeviceAddress n) = withContext h $ \ctx -> do+	r <- modbus_set_slave ctx n+	if r == 0+		then return ()+		else throwErrno "modbus_set_slave"++connect :: Context -> IO ()+connect h = withContext h $ \ctx -> do+	r <- modbus_connect ctx+	if r == 0+		then return ()+		else throwErrno "modbus_connect"++set_debug :: Context -> Bool -> IO ()+set_debug h b = withContext h $ \ctx -> do+	r <- modbus_set_debug ctx $ +		if b +			then #const (TRUE)+			else #const (FALSE)+	if r == 0+		then return ()+		else throwErrno "modbus_set_debug"++data Timeout = Timeout+	{ to_sec :: Word32+	, to_usec :: Word32+	}+	deriving (Eq, Show)++get_timeout ::(Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int) -> String -> Context -> IO Timeout+get_timeout action actionname h =+	withContext h $ \ctx ->+		alloca $ \secp ->+			alloca $ \usecp -> do+				r <- action ctx secp usecp+				if r == 0+					then do+						sec <- peek secp+						usec <- peek usecp+						return $ Timeout sec usec+					else throwErrno actionname++set_timeout :: (Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int) -> String -> Context -> Timeout -> IO ()+set_timeout action actionname h timeout =+	withContext h $ \ctx ->+		alloca $ \secp ->+			alloca $ \usecp -> do+				poke secp (to_sec timeout)+				poke usecp (to_usec timeout)+				r <- action ctx secp usecp+				if r == 0+					then return ()+					else throwErrno actionname++get_byte_timeout :: Context -> IO Timeout+get_byte_timeout = get_timeout+	modbus_get_byte_timeout+	"modbus_get_byte_timeout"++set_byte_timeout :: Context -> Timeout -> IO ()+set_byte_timeout = set_timeout+	modbus_set_byte_timeout+	"modbus_set_byte_timeout"++get_response_timeout :: Context -> IO Timeout+get_response_timeout = get_timeout+	modbus_get_response_timeout+	"modbus_get_response_timeout"++set_response_timeout :: Context -> Timeout -> IO ()+set_response_timeout = set_timeout+	modbus_set_response_timeout+	"modbus_set_response_timeout"++-- | An address on a modbus device.+newtype Addr = Addr Int+	deriving (Show, Eq)++-- | A vector that is used to read or write registers of a modbus device.+--+-- Use functions from `Data.Vector.Storable.Mutable` to access and modify+-- the values stored in the vector.+type RegisterVector = V.IOVector Word16++-- | Allocates a vector holding the specified number of registers.+--+-- The registers are initialized to 0 to start.+mkRegisterVector :: Int -> IO RegisterVector+mkRegisterVector sz = V.replicate sz 0+ +-- | Reads the holding registers from the modbus device, starting at+-- the Addr. The RegisterVector is modified to contain the values read.+--+-- Returns the number of registers that were read.+read_registers :: Context -> Addr -> RegisterVector -> IO Int+read_registers h addr v = +	accessVector h addr v+		modbus_read_registers+		"modbus_read_registers"++-- | Reads the input registers from the modbus device, starting at+-- the Addr. The RegisterVector is modified to contain the values read.+--+-- Returns the number of registers that were read.+read_input_registers :: Context -> Addr -> RegisterVector -> IO Int+read_input_registers h addr v = +	accessVector h addr v+		modbus_read_input_registers+		"modbus_read_input_registers"++-- | Writes the registers to the modbus device, starting at+-- the Addr.+--+-- Returns the number of written registers.+write_registers :: Context -> Addr -> RegisterVector -> IO Int+write_registers h addr v =+	accessVector h addr v+		modbus_write_registers+		"modbus_write_registers"++write_register :: Context -> Addr -> Word16 -> IO ()+write_register h (Addr addr) val = withContext h $ \ctx -> do+	r <- modbus_write_register ctx addr val+	if r == -1+		then throwErrno "modbus_write_register"+		else return ()++write_and_read_registers+	:: Context+	-> Addr+	-- ^ address to write to+	-> RegisterVector+	-- ^ data to write+	-> Addr+	-- ^ address to read from+	-> RegisterVector+	-- ^ data to read+	-> IO Int+write_and_read_registers h (Addr write_addr) write_v (Addr read_addr) read_v =+	withContext h $ \ctx -> do+		let (write_fptr, write_nb) = V.unsafeToForeignPtr0 write_v+		let (read_fptr, read_nb) = V.unsafeToForeignPtr0 read_v+		r <- withForeignPtr write_fptr $ \write_ptr ->+			withForeignPtr read_fptr $ \read_ptr ->+				modbus_write_and_read_registers ctx+					write_addr write_nb write_ptr+					read_addr read_nb read_ptr+		if r == -1+			then throwErrno "modbus_write_and_read_registers"+			else return r++-- | A vector that is used to read or write bits of a modbus device.+--+-- Use functions from `Data.Vector.Storable.Mutable` to access and modify+-- the values stored in the vector.+type BitVector = V.IOVector Bit++type Bit = Word8++boolBit :: Bit -> Bool+boolBit b = b == #const (TRUE)++bitBool :: Bool -> Bit+bitBool True = #const (TRUE)+bitBool False = #const (FALSE)++-- | Allocates a vector holding the specified number of bits.+--+-- The bits are initialized to true to start.+mkBitVector :: Int -> IO BitVector+mkBitVector sz = V.replicate sz #const (TRUE)++-- | Reads the bits (coils) from the modbus device, starting at+-- the Addr. The BitVector is modified to contain the values read.+--+-- Returns the number of bits that were read.+read_bits :: Context -> Addr -> BitVector -> IO Int+read_bits h addr v = accessVector h addr v+	modbus_read_bits+	"modbus_read_bits"++-- | Reads the input bits from the modbus device, starting at+-- the Addr. The BitVector is modified to contain the values read.+--+-- Returns the number of bits that were read.+read_input_bits :: Context -> Addr -> BitVector -> IO Int+read_input_bits h addr v = accessVector h addr v+	modbus_read_input_bits+	"modbus_read_input_bits"++-- | Writes the bits (coils) of the modbus device, starting at+-- the Addr.+--+-- Returns the number of written bits.+write_bits :: Context -> Addr -> BitVector -> IO Int+write_bits h addr v = accessVector h addr v+	modbus_write_bits+	"modbus_write_bits"++write_bit :: Context -> Addr -> Bit -> IO ()+write_bit h (Addr addr) val = withContext h $ \ctx -> do+	r <- modbus_write_bit ctx addr (fromIntegral val)+	if r == -1+		then throwErrno "modbus_write_bit"+		else return ()

@@ -0,0 +1,7 @@+* modbus_set_error_recovery binding+* Use modbus_strerror when throwing exceptions to generate better error+  messages.+* Perhaps some of the float conversion functions and other data+  manipulation stuff. Although it's not hard to write that in pure haskell+  as needed.+* Bindings to the server support functions.

@@ -0,0 +1,32 @@+Name: libmodbus+Version: 1.0.0+Cabal-Version: >= 1.8+License: BSD2+Maintainer: Joey Hess <id@joeyh.name>+Author: Joey Hess+Stability: Stable+Copyright: 2019 Joey Hess+License-File: LICENSE+Build-Type: Simple+Category: System+Synopsis: Haskell bindings to the C modbus library+Description:+ This library supports Modbus communication over both TCP and serial ports.+ .+ It is a FFI to the C modbus library from https://libmodbus.org/+Extra-Source-Files:+ CHANGELOG+ TODO++Library+  GHC-Options: -Wall -fno-warn-tabs+  Extra-Libraries: modbus+  Exposed-Modules: System.Modbus+  Build-Depends:+    base >= 4.5 && < 5,+    vector >= 0.12 && <= 0.13, +    data-default >= 0.7 && <= 0.8++source-repository head+  type: git+  location: git://git.joeyh.name/haskell-libmodbus.git