diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,11 @@ # Changelog for net-mqtt +## 0.6.2.1 + +Added function to get original connection ACK response packet. + +- connACK (in IO) and connACKSTM + ## 0.6.2.0 Added low-level support for correlated responses. diff --git a/app/mqtt-watch/Main.hs b/app/mqtt-watch/Main.hs --- a/app/mqtt-watch/Main.hs +++ b/app/mqtt-watch/Main.hs @@ -9,13 +9,15 @@ import Control.Concurrent.STM (TChan, atomically, newTChanIO, readTChan, writeTChan) import Control.Exception (Handler (..), IOException, catches) -import Control.Monad (forever, void, when) +import Control.Monad (forever, when) import qualified Data.ByteString.Lazy as BL import Data.Maybe (fromJust) import qualified Data.Text.IO as TIO +import Data.Word (Word32) import Network.MQTT.Client +import Network.MQTT.Types (ConnACKFlags (..)) import Network.URI -import Options.Applicative (Parser, argument, execParser, +import Options.Applicative (Parser, argument, auto, execParser, fullDesc, help, helper, info, long, maybeReader, metavar, option, progDesc, short, showDefault, some, @@ -25,15 +27,19 @@ data Msg = Msg Topic BL.ByteString [Property] data Options = Options { - optUri :: URI - , optHideProps :: Bool - , optTopics :: [Topic] + optUri :: URI + , optHideProps :: Bool + , optSessionTime :: Word32 + , optVerbose :: Bool + , optTopics :: [Topic] } options :: Parser Options options = Options <$> option (maybeReader parseURI) (long "mqtt-uri" <> short 'u' <> showDefault <> value (fromJust $ parseURI "mqtt://localhost/") <> help "mqtt broker URI") <*> switch (short 'p' <> help "hide properties") + <*> option auto (long "session-timeout" <> showDefault <> value 0 <> help "mqtt session timeout (0 == clean)") + <*> switch (short 'v' <> long "verbose" <> help "enable debug logging") <*> some (argument str (metavar "topics...")) printer :: TChan Msg -> Bool -> IO () @@ -55,13 +61,19 @@ where go ch = do mc <- connectURI mqttConfig{_msgCB=SimpleCallback (showme ch), _protocol=Protocol50, + _cleanSession=optSessionTime == 0, _connProps=[PropReceiveMaximum 65535, PropTopicAliasMaximum 10, + PropSessionExpiryInterval optSessionTime, PropRequestResponseInformation 1, PropRequestProblemInformation 1]} optUri - void $ subscribe mc [(t, subOptions) | t <- optTopics] mempty + (ConnACKFlags sp _ props) <- connACK mc + when optVerbose $ putStrLn (if sp then "" else "") + when optVerbose $ putStrLn ("Properties: " <> show props) + subres <- subscribe mc [(t, subOptions) | t <- optTopics] mempty + when optVerbose $ print subres print =<< waitForClient mc diff --git a/net-mqtt.cabal b/net-mqtt.cabal --- a/net-mqtt.cabal +++ b/net-mqtt.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 5602a18bc959d07604ceba74369d151f6f3296000f0673b64a4539234b49d3e5 +-- hash: c2a4b0d05fac2cbfd290e0b0b8b6c2d564370d3b63f467144979056c4f492ed1 name: net-mqtt -version: 0.6.2.0 +version: 0.6.2.1 synopsis: An MQTT Protocol Implementation. description: Please see the README on GitHub at category: Network diff --git a/src/Network/MQTT/Client.hs b/src/Network/MQTT/Client.hs --- a/src/Network/MQTT/Client.hs +++ b/src/Network/MQTT/Client.hs @@ -29,9 +29,9 @@ disconnect, normalDisconnect, -- * General client interactions. subscribe, unsubscribe, publish, publishq, pubAliased, - svrProps, MQTTException(..), + svrProps, connACK, MQTTException(..), -- * Low-level bits - runMQTTConduit, MQTTConduit, isConnectedSTM, + runMQTTConduit, MQTTConduit, isConnectedSTM, connACKSTM, registerCorrelated, unregisterCorrelated ) where @@ -101,16 +101,16 @@ -- -- See 'connectURI' for the most straightforward example. data MQTTClient = MQTTClient { - _ch :: TChan MQTTPkt - , _pktID :: TVar Word16 - , _cb :: MessageCallback - , _acks :: TVar (Map (DispatchType,Word16) (TChan MQTTPkt)) - , _st :: TVar ConnState - , _ct :: TVar (Async ()) - , _outA :: TVar (Map Topic Word16) - , _inA :: TVar (Map Word16 Topic) - , _svrProps :: TVar [Property] - , _corr :: TVar (Map BL.ByteString MessageCallback) + _ch :: TChan MQTTPkt + , _pktID :: TVar Word16 + , _cb :: MessageCallback + , _acks :: TVar (Map (DispatchType,Word16) (TChan MQTTPkt)) + , _st :: TVar ConnState + , _ct :: TVar (Async ()) + , _outA :: TVar (Map Topic Word16) + , _inA :: TVar (Map Word16 Topic) + , _connACKFlags :: TVar ConnACKFlags + , _corr :: TVar (Map BL.ByteString MessageCallback) } -- | Configuration for setting up an MQTT client. @@ -289,7 +289,7 @@ _ct <- newTVarIO undefined _outA <- newTVarIO mempty _inA <- newTVarIO mempty - _svrProps <- newTVarIO mempty + _connACKFlags <- newTVarIO (ConnACKFlags False ConnUnspecifiedError mempty) _corr <- newTVarIO mempty let _cb = _msgCB cli = MQTTClient{..} @@ -405,14 +405,14 @@ PongPkt -> atomically . writeTChan pch $ True x -> print x - where connACKd connr@(ConnACKFlags _ val props) = case val of - ConnAccepted -> atomically $ do - writeTVar _svrProps props - writeTVar _st Connected - _ -> do - t <- readTVarIO _ct - atomically $ writeTVar _st (ConnErr connr) - cancelWith t (MQTTException $ show connr) + where connACKd connr@(ConnACKFlags _ val _) = case val of + ConnAccepted -> atomically $ do + writeTVar _connACKFlags connr + writeTVar _st Connected + _ -> do + t <- readTVarIO _ct + atomically $ writeTVar _st (ConnErr connr) + cancelWith t (MQTTException $ show connr) delegate dt pid = atomically $ do m <- readTVar _acks @@ -640,10 +640,19 @@ -- | Get the list of properties that were sent from the broker at connect time. svrProps :: MQTTClient -> IO [Property] -svrProps MQTTClient{..} = readTVarIO _svrProps +svrProps mc = p <$> atomically (connACKSTM mc) + where p (ConnACKFlags _ _ props) = props +-- | Get the complete connection ACK packet from the beginning of this session. +connACKSTM :: MQTTClient -> STM ConnACKFlags +connACKSTM MQTTClient{_connACKFlags} = readTVar _connACKFlags + +-- | Get the complete connection aCK packet from the beginning of this session. +connACK :: MQTTClient -> IO ConnACKFlags +connACK = atomically . connACKSTM + maxAliases :: MQTTClient -> IO Word16 -maxAliases MQTTClient{..} = foldr f 0 <$> readTVarIO _svrProps +maxAliases mc = foldr f 0 <$> svrProps mc where f (PropTopicAliasMaximum n) _ = n f _ o = o