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-03-18 12:34:31 +03:00
parent 752ce1d98a
commit c3e0f33fc7
2 changed files with 23 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
fixer-config-example.scm
View File

@ -5,10 +5,6 @@
(run "./on-my-ref2.sh") (run "./on-my-ref2.sh")
) )
(watch 30 (reflog "BKtvRLispCM9UuQqHaNxu4SEUzpQNQ3PeRNknecKGPZ6")
(run "./on-my-ref3.sh")
)
(watch 30 (lwwref "DTmSb3Au7apDTMctQn6yqs9GJ8mFW7YQXzgVqZpmkTtf") (watch 30 (lwwref "DTmSb3Au7apDTMctQn6yqs9GJ8mFW7YQXzgVqZpmkTtf")
(run "./on-my-ref4.sh") (run "./on-my-ref4.sh")
) )

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

@ -196,7 +196,7 @@ mainLoop = forever $ do
next ConfWatch next ConfWatch
ConfWatch{} -> do ConfWatch{} -> do
pause @'Seconds 10 pause @'Seconds 30
next ConfRead next ConfRead
-- poll reflogs -- poll reflogs
@ -204,14 +204,23 @@ mainLoop = forever $ do
api <- asks _refLogAPI api <- asks _refLogAPI
rlo <- pure $ asks _onRefLog olds <- asks _refLogLast
>>= readTVarIO
<&> HM.toList rlo <- pure $ asks _onRefLog >>= keysToListen
<&> \x -> [ (a,b) | (a, (b,_)) <- x ]
polling (Polling 1 1) rlo $ \ref -> do polling (Polling 1 1) rlo $ \ref -> do
debug $ red "POLL REFLOG" <+> pretty ref debug $ red "POLL REFLOG" <+> pretty ref
liftIO $ oneSec $ void $ callService @RpcRefLogFetch api (fromRefLogKey ref) liftIO $ oneSec $ void $ callService @RpcRefLogFetch api (fromRefLogKey ref)
liftIO (oneSec $ callService @RpcRefLogGet api (fromRefLogKey ref)) >>= \case
Right (Right (Just v)) -> do
old <- readTVarIO olds <&> HM.lookup ref
unless (old == Just v) do
debug $ green "CHANGED" <+> pretty ref <+> pretty v
atomically $ modifyTVar olds (HM.insert ref v)
_ -> pure ()
pure () pure ()
pure () pure ()
@ -222,10 +231,7 @@ mainLoop = forever $ do
api <- asks _lwwAPI api <- asks _lwwAPI
olds <- asks _lwwLast olds <- asks _lwwLast
lww <- pure $ asks _onLww lww <- pure $ asks _onLww >>= keysToListen
>>= readTVarIO
<&> HM.toList
<&> \x -> [ (a,b) | (a, (b,_)) <- x ]
polling (Polling 1 1) lww $ \ref -> do polling (Polling 1 1) lww $ \ref -> do
debug $ red "POLL LWWREF" <+> pretty ref debug $ red "POLL LWWREF" <+> pretty ref
@ -243,6 +249,12 @@ mainLoop = forever $ do
forever $ pause @'Seconds 60 forever $ pause @'Seconds 60
where
keysToListen what =
readTVarIO what
<&> HM.toList
<&> \x -> [ (a,b) | (a, (b,_)) <- x ]
oneSec :: MonadUnliftIO m => m b -> m (Either () b) oneSec :: MonadUnliftIO m => m b -> m (Either () b)
oneSec = race (pause @'Seconds 1) oneSec = race (pause @'Seconds 1)
@ -273,13 +285,13 @@ updateFromConfig conf = do
case rt of case rt of
"lwwref" -> do "lwwref" -> do
let k' = fromStringMay @RLWW (Text.unpack r) let k' = fromStringMay @RLWW (Text.unpack r)
debug $ red $ "SET LWWREF WATCHER" <+> pretty sec <+> pretty k' <+> pretty what trace $ red "SET LWWREF WATCHER" <+> pretty sec <+> pretty k' <+> pretty what
for_ k' $ \k -> do for_ k' $ \k -> do
liftIO $ void $ oneSec $ callService @RpcPollAdd peerAPI (fromLwwRefKey k, "lwwref", 60 * fromIntegral sec) liftIO $ void $ oneSec $ callService @RpcPollAdd peerAPI (fromLwwRefKey k, "lwwref", 60 * fromIntegral sec)
S.yield $ modifyTVar lww (HM.insert k (fromIntegral sec, mempty)) S.yield $ modifyTVar lww (HM.insert k (fromIntegral sec, mempty))
"reflog" -> do "reflog" -> do
let k' = fromStringMay @RRefLog (Text.unpack r) let k' = fromStringMay @RRefLog (Text.unpack r)
debug $ red $ "SET LWWREF WATCHER" <+> pretty sec <+> pretty k' <+> pretty what trace $ red "SET LWWREF WATCHER" <+> pretty sec <+> pretty k' <+> pretty what
for_ k' $ \k -> do for_ k' $ \k -> do
liftIO $ void $ oneSec $ callService @RpcPollAdd peerAPI (fromRefLogKey k, "reflog", 60 * fromIntegral sec) liftIO $ void $ oneSec $ callService @RpcPollAdd peerAPI (fromRefLogKey k, "reflog", 60 * fromIntegral sec)
S.yield $ modifyTVar rlo (HM.insert k (fromIntegral sec, mempty)) S.yield $ modifyTVar rlo (HM.insert k (fromIntegral sec, mempty))