diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# Version [0.1.4.0](https://github.com/sorki/haskell-zre/compare/0.1.3.0...0.1.4.0) (2020-07-19) + +* Changed `zfail` type from `String -> ZRE ()` to `String -> ZRE a` +* Handles errors in user application correctly instead of silently ignoring them +* Fixed incorrect time periods for pinger + # Version [0.1.3.0](https://github.com/sorki/haskell-zre/compare/0.1.2.0...0.1.3.0) (2020-07-14) * Cabal fixes diff --git a/src/Network/ZRE.hs b/src/Network/ZRE.hs --- a/src/Network/ZRE.hs +++ b/src/Network/ZRE.hs @@ -37,6 +37,8 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM +import Control.Exception (SomeException) +import qualified Control.Exception.Lifted import Data.ByteString (ByteString) import Data.UUID @@ -143,14 +145,23 @@ Just end -> void $ async $ zgossipClient uuid end zreEndpoint (zgossipZRE outQ) (mCastAddr:_) <- toAddrInfo zreMCast - _beaconAsync <- async $ beacon mCastAddr uuid zrePort + _beaconAsync <- async $ beacon zreBeaconPeriod mCastAddr uuid zrePort _beaconRecvAsync <- async $ beaconRecv s zreMCast mapM_ (runIface s zrePort) ifaces apiAsync <- async $ api s threadDelay 500000 - _userAppAsync <- async $ runZ (app >> zquit) inQ outQ + _userAppAsync <- async + $ runZ + (app + `Control.Exception.Lifted.catch` + (\e -> do let err = show (e :: SomeException) in zfail err) + `Control.Exception.Lifted.finally` + zquit + ) + inQ + outQ wait apiAsync return () diff --git a/src/Network/ZRE/Beacon.hs b/src/Network/ZRE/Beacon.hs --- a/src/Network/ZRE/Beacon.hs +++ b/src/Network/ZRE/Beacon.hs @@ -62,8 +62,8 @@ -- | Send UDP multicast beacons periodically -beacon :: AddrInfo -> ByteString -> Port -> IO () -beacon addrInfo uuid port = do +beacon :: Float -> AddrInfo -> ByteString -> Port -> IO () +beacon seconds addrInfo uuid port = do withSocketsDo $ do bracket (getSocket addrInfo) close (talk (addrAddress addrInfo) (zreBeacon uuid port)) where @@ -75,4 +75,4 @@ talk addr msg s = forever $ do void $ sendTo s msg addr - threadDelay zreBeaconMs + threadDelay $ sec seconds diff --git a/src/Network/ZRE/Options.hs b/src/Network/ZRE/Options.hs --- a/src/Network/ZRE/Options.hs +++ b/src/Network/ZRE/Options.hs @@ -18,29 +18,29 @@ <> short 'n' <> value "" <> help "Node name")) - <*> (isec <$> option auto + <*> (option auto (long "quiet-period" <> short 'q' <> metavar "N" - <> value (sec (1.0 :: Float)) + <> value 1.0 <> help "Ping peer after N seconds")) - <*> (isec <$> option auto + <*> (option auto (long "quiet-ping-rate" <> short 'p' <> metavar "N" - <> value (sec (1.0 :: Float)) + <> value 1.0 <> help "Peer ping rate after quiet period passed")) - <*> ((*100000) <$> option auto + <*> (option auto (long "dead-period" <> short 'd' <> metavar "N" - <> value (sec (1.0 :: Float)) + <> value 5.0 <> help "Mark peer dead after N seconds")) - <*> ((*100000) <$> option auto + <*> (option auto (long "beacon-period" <> short 'b' <> metavar "N" - <> value (sec (0.9 :: Float)) + <> value 0.9 <> help "Send beacon every N seconds")) <*> ((map B.pack) <$> many (strOption (long "interface" diff --git a/src/Network/ZRE/Peer.hs b/src/Network/ZRE/Peer.hs --- a/src/Network/ZRE/Peer.hs +++ b/src/Network/ZRE/Peer.hs @@ -181,19 +181,19 @@ cfg <- atomically $ zreCfg <$> readTVar s now <- getCurrentTime - if diffUTCTime now peerLastHeard > (fromIntegral $ zreDeadPeriod cfg) + if diffUTCTime now peerLastHeard > (realToFrac $ zreDeadPeriod cfg) then do atomically $ emitdbg s $ B.unwords ["Peer over deadPeriod, destroying", bshow p] destroyPeer s peerUUID else do let tdiff = diffUTCTime now peerLastHeard - if tdiff > (fromIntegral $ zreQuietPeriod cfg) + if tdiff > (realToFrac $ zreQuietPeriod cfg) then do atomically $ emitdbg s $ B.unwords ["Peer over quietPeriod, sending hugz", bshow p] atomically $ writeTBQueue peerQueue $ Ping - threadDelay (zreQuietPingRate cfg) + threadDelay $ sec (zreQuietPingRate cfg) else do - threadDelay $ sec $ (fromIntegral $ zreQuietPeriod cfg) - tdiff + threadDelay $ sec $ (realToFrac $ zreQuietPeriod cfg) - tdiff lookupPeer :: TVar ZREState -> UUID -> STM (Maybe (TVar Peer)) lookupPeer s uuid = do diff --git a/src/Network/ZRE/Types.hs b/src/Network/ZRE/Types.hs --- a/src/Network/ZRE/Types.hs +++ b/src/Network/ZRE/Types.hs @@ -28,16 +28,12 @@ msec :: (RealFrac a) => a -> Int msec = round . (*1000) --- send beacon every 0.9 seconds -zreBeaconMs :: Int -zreBeaconMs = 900000 - data ZRECfg = ZRECfg { zreNamed :: ByteString - , zreQuietPeriod :: Int - , zreQuietPingRate :: Int - , zreDeadPeriod :: Int - , zreBeaconPeriod :: Int + , zreQuietPeriod :: Float + , zreQuietPingRate :: Float + , zreDeadPeriod :: Float + , zreBeaconPeriod :: Float , zreInterfaces :: [ByteString] , zreMCast :: Endpoint , zreZGossip :: Maybe Endpoint @@ -50,10 +46,10 @@ defaultConf :: ZRECfg defaultConf = ZRECfg { zreNamed = "zre" - , zreQuietPeriod = sec (1.0 :: Float) - , zreQuietPingRate = sec (1.0 :: Float) - , zreDeadPeriod = sec (5.0 :: Float) - , zreBeaconPeriod = sec (0.9 :: Float) + , zreQuietPeriod = 1.0 + , zreQuietPingRate = 1.0 + , zreDeadPeriod = 5.0 + , zreBeaconPeriod = 0.9 , zreInterfaces = [] , zreZGossip = Nothing , zreMCast = defMCastEndpoint @@ -193,10 +189,11 @@ zquit :: ZRE () zquit = writeZ $ DoQuit -zfail :: String -> ZRE () +zfail :: String -> ZRE a zfail errorMsg = do liftIO $ putStrLn errorMsg writeZ $ DoQuit + error errorMsg zrecv :: ZRE (Event) zrecv = readZ diff --git a/src/Network/ZRE/Utils.hs b/src/Network/ZRE/Utils.hs --- a/src/Network/ZRE/Utils.hs +++ b/src/Network/ZRE/Utils.hs @@ -61,7 +61,7 @@ getIfaceReport iname = do i <- getIface iname case i of - Nothing -> exitFail $ "Unable to get info for interace " `B.append` iname + Nothing -> exitFail $ "Unable to get info for interface " `B.append` iname (Just NetworkInterface{..}) -> return (iname, B.pack $ show ipv4, B.pack $ show ipv6) getName :: ByteString -> IO ByteString diff --git a/zre.cabal b/zre.cabal --- a/zre.cabal +++ b/zre.cabal @@ -1,5 +1,5 @@ name: zre -version: 0.1.3.0 +version: 0.1.4.0 synopsis: ZRE protocol implementation description: Peer-to-peer local area networking with reliable group messaging and automatic peer discovery. @@ -49,6 +49,7 @@ build-depends: base >= 4 && < 5 , async , lifted-async + , lifted-base , attoparsec ^>= 0.13 , cereal , data-default