voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-04-10 08:36:41 +03:00
parent 91bdc03515
commit 73049bcd03
2 changed files with 18 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
hbs2-core/lib/HBS2/Net/Messaging/Unix.hs
View File

@ -4,6 +4,7 @@ module HBS2.Net.Messaging.Unix
( module HBS2.Net.Messaging.Unix ( module HBS2.Net.Messaging.Unix
, module HBS2.Net.Messaging , module HBS2.Net.Messaging
, module HBS2.Net.Proto.Types , module HBS2.Net.Proto.Types
, SocketClosedException
) where ) where
import HBS2.Prelude.Plated import HBS2.Prelude.Plated
@ -220,12 +221,23 @@ runMessagingUnix env = do
atomically $ writeTVar seen now atomically $ writeTVar seen now
next next
clientLoop m = fix \next -> do
m
if not (MUDontRetry `elem` msgUnixOpts env) then do
debug "LOOP!"
next
else do
debug "LOOP EXIT"
handleClient | MUDontRetry `elem` msgUnixOpts env = \_ w -> handleAny throwStopped w handleClient | MUDontRetry `elem` msgUnixOpts env = \_ w -> handleAny throwStopped w
| otherwise = handleAny | otherwise = handleAny
throwStopped _ = throwIO UnixMessagingStopped throwStopped _ = throwIO UnixMessagingStopped
runClient = liftIO $ forever $ handleClient logAndRetry $ flip runContT pure $ do runClient = liftIO $ clientLoop $ handleClient logAndRetry $ flip runContT pure $ do
debug "HERE WE GO AGAIN!"
let sa = SockAddrUnix (msgUnixSockPath env) let sa = SockAddrUnix (msgUnixSockPath env)
let p = msgUnixSockPath env let p = msgUnixSockPath env
@ -335,6 +347,7 @@ runMessagingUnix env = do
pause (msgUnixRetryTime env) pause (msgUnixRetryTime env)
logAndRetry :: SomeException -> IO () logAndRetry :: SomeException -> IO ()
logAndRetry e = do logAndRetry e = do
warn $ "MessagingUnix. runClient failed, probably server is gone. Retrying:" <+> pretty (msgUnixSelf env) warn $ "MessagingUnix. runClient failed, probably server is gone. Retrying:" <+> pretty (msgUnixSelf env)

6
hbs2-fixer/app/Main.hs
View File

@ -168,7 +168,7 @@ withApp cfgPath action = do
client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname)
>>= orThrowUser ("can't connect to" <+> pretty soname) >>= orThrowUser ("can't connect to" <+> pretty soname)
mess <- ContT $ bracket (async $ runMessagingUnix client) $ \_ -> error "FUCK!" >> liftIO exitFailure mess <- ContT $ withAsync $ runMessagingUnix client
link mess link mess
@ -185,10 +185,10 @@ withApp cfgPath action = do
void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
let o = [MUWatchdog 20] let o = [MUWatchdog 20,MUDontRetry]
clientN <- newMessagingUnixOpts o False 1.0 soname clientN <- newMessagingUnixOpts o False 1.0 soname
notif <- ContT $ bracket (async $ runMessagingUnix clientN) (\_ -> error "FUCK2" >> liftIO exitFailure) notif <- ContT $ withAsync (runMessagingUnix clientN)
link notif link notif