diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +haskell-libmodbus (1.1.1) unstable; urgency=medium + + * Use modbus_strerror for better messages in exceptions. + * Add set_error_recovery. + + -- Joey Hess Tue, 08 Oct 2019 21:20:18 -0400 + haskell-libmodbus (1.1.0) unstable; urgency=medium * Added a full working example of reading data from an epsolar charge diff --git a/System/Modbus.hsc b/System/Modbus.hsc --- a/System/Modbus.hsc +++ b/System/Modbus.hsc @@ -23,7 +23,7 @@ -- * Example -- -- | This example reads some of the registers of an Epever solar - -- charge controller. It shows how `Data.Binary` can be used + -- charge controller. It shows how the binary library can be used -- to decode the modbus registers into a haskell data structure. -- -- > import System.Modbus @@ -98,6 +98,8 @@ set_byte_timeout, get_response_timeout, set_response_timeout, + ErrorRecoveryMode(..), + set_error_recovery, -- * Accessing registers RegisterVector, @@ -188,6 +190,9 @@ 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_set_error_recovery" modbus_set_error_recovery + :: Ptr () -> Int -> IO Int + foreign import ccall unsafe "modbus.h modbus_read_registers" modbus_read_registers :: Ptr () -> Int -> Int -> Ptr Word16 -> IO Int @@ -215,6 +220,9 @@ foreign import ccall unsafe "modbus.h modbus_write_bit" modbus_write_bit :: Ptr () -> Int -> Int -> IO Int +foreign import ccall unsafe "modbus.h modbus_strerror" modbus_strerror + :: Errno -> IO (Ptr CChar) + accessVector :: Storable t => Context @@ -227,7 +235,7 @@ let (fptr, nb) = VM.unsafeToForeignPtr0 v r <- withForeignPtr fptr $ action ctx addr nb if r == -1 - then throwErrno actionname + then throwErrnoModbus actionname else if r /= nb then ioError $ IOError Nothing OtherError actionname "short read/write" Nothing Nothing @@ -270,7 +278,7 @@ ctx <- withCString f $ \cf -> modbus_new_rtu cf b pc d s if ctx == nullPtr - then throwErrno "modbus_new_rtu" + then throwErrnoModbus "modbus_new_rtu" else mkContext ctx where pc = fromIntegral $ ord $ case p of @@ -299,7 +307,7 @@ AnyAddress -> modbus_new_tcp nullPtr port if ctx == nullPtr - then throwErrno "modbus_new_tcp" + then throwErrnoModbus "modbus_new_tcp" else mkContext ctx -- | Host name or IP address to connect to. In server mode, use AnyNode @@ -326,7 +334,7 @@ AnyNode -> modbus_new_tcp_pi nullPtr cservice if ctx == nullPtr - then throwErrno "modbus_new_tcp_pi" + then throwErrnoModbus "modbus_new_tcp_pi" else mkContext ctx data SerialMode = RTU_RS232 | RTU_RS485 @@ -339,7 +347,7 @@ then return RTU_RS232 else if r == #const (MODBUS_RTU_RS485) then return RTU_RS485 - else throwErrno "modbus_rtu_get_serial_mode" + else throwErrnoModbus "modbus_rtu_get_serial_mode" rtu_set_serial_mode :: Context -> SerialMode -> IO () rtu_set_serial_mode h m = withContext h $ \ctx -> do @@ -348,7 +356,7 @@ RTU_RS485 -> #const (MODBUS_RTU_RS485) if r == 0 then return () - else throwErrno "modbus_rtu_set_serial_mode" + else throwErrnoModbus "modbus_rtu_set_serial_mode" data RTS = RTU_RTS_NONE | RTU_RTS_UP | RTU_RTS_DOWN deriving (Show, Eq) @@ -362,7 +370,7 @@ 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" + else throwErrnoModbus "modbus_rtu_get_serial_mode" rtu_set_rts :: Context -> RTS -> IO () rtu_set_rts h m = withContext h $ \ctx -> do @@ -372,21 +380,21 @@ RTU_RTS_DOWN -> #const (MODBUS_RTU_RTS_DOWN) if r == 0 then return () - else throwErrno "modbus_rtu_set_rts" + else throwErrnoModbus "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" + else throwErrnoModbus "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" + else throwErrnoModbus "modbus_rtu_set_rts_delay" -- | The address of a modbus device. newtype DeviceAddress = DeviceAddress Int @@ -402,14 +410,14 @@ r <- modbus_set_slave ctx n if r == 0 then return () - else throwErrno "modbus_set_slave" + else throwErrnoModbus "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" + else throwErrnoModbus "modbus_connect" set_debug :: Context -> Bool -> IO () set_debug h b = withContext h $ \ctx -> do @@ -419,7 +427,7 @@ else #const (FALSE) if r == 0 then return () - else throwErrno "modbus_set_debug" + else throwErrnoModbus "modbus_set_debug" data Timeout = Timeout { to_sec :: Word32 @@ -438,7 +446,7 @@ sec <- peek secp usec <- peek usecp return $ Timeout sec usec - else throwErrno actionname + else throwErrnoModbus actionname set_timeout :: (Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int) -> String -> Context -> Timeout -> IO () set_timeout action actionname h timeout = @@ -450,7 +458,7 @@ r <- action ctx secp usecp if r == 0 then return () - else throwErrno actionname + else throwErrnoModbus actionname get_byte_timeout :: Context -> IO Timeout get_byte_timeout = get_timeout @@ -472,6 +480,33 @@ modbus_set_response_timeout "modbus_set_response_timeout" +data ErrorRecoveryMode + = ErrorRecoveryNone + | ErrorRecoveryLink + -- ^ Reconnect after response timeout. + | ErrorRecoveryProtocol + -- ^ Clean up ongoing communication. + | ErrorRecoveryLinkProtocol + -- ^ Combine both. + +set_error_recovery :: Context -> ErrorRecoveryMode -> IO () +set_error_recovery h m = + withContext h $ \ctx -> do + r <- modbus_set_error_recovery ctx $ case m of + ErrorRecoveryNone -> + #const (MODBUS_ERROR_RECOVERY_NONE) + ErrorRecoveryLink -> + #const (MODBUS_ERROR_RECOVERY_LINK) + ErrorRecoveryProtocol -> + #const (MODBUS_ERROR_RECOVERY_PROTOCOL) + ErrorRecoveryLinkProtocol -> + #const (MODBUS_ERROR_RECOVERY_LINK) + .|. + #const (MODBUS_ERROR_RECOVERY_PROTOCOL) + if r == 0 + then return () + else throwErrnoModbus "modbus_set_error_recovery" + -- | An address on a modbus device. newtype Addr = Addr Int deriving (Show, Eq) @@ -554,7 +589,7 @@ 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" + then throwErrnoModbus "modbus_write_register" else return () write_and_read_registers @@ -578,7 +613,7 @@ write_addr write_nb write_ptr read_addr read_nb read_ptr if r == -1 - then throwErrno actionname + then throwErrnoModbus actionname else if r /= read_nb then ioError $ IOError Nothing OtherError actionname "short read" Nothing Nothing @@ -655,5 +690,15 @@ 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" + then throwErrnoModbus "modbus_write_bit" else return () + +-- libmodbus extends errno with its own error codes, +-- and modbus_strerror can generate more useful error messages. +throwErrnoModbus :: String -> IO a +throwErrnoModbus loc = do + errno@(Errno n) <- getErrno + -- This has a complicated mapping from standard errno to error type. + let herr = errnoToIOError loc errno Nothing Nothing + str <- modbus_strerror errno >>= peekCString + ioError $ IOError Nothing (ioe_type herr) loc str (Just n) Nothing diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,6 +1,3 @@ -* 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. diff --git a/libmodbus.cabal b/libmodbus.cabal --- a/libmodbus.cabal +++ b/libmodbus.cabal @@ -1,5 +1,5 @@ Name: libmodbus -Version: 1.1.0 +Version: 1.1.1 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess