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

HttpWorker exceptions

This commit is contained in:
voidlizard 2024-11-01 16:44:38 +03:00
parent 5fe3fb7a1b
commit cba74369c4
2 changed files with 38 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
hbs2-core/lib/HBS2/Net/Messaging/TCP.hs
View File

@ -22,7 +22,7 @@ import HBS2.System.Logger.Simple
import HBS2.Misc.PrettyStuff import HBS2.Misc.PrettyStuff
import Control.Concurrent.STM (flushTQueue) import Control.Concurrent.STM (flushTQueue)
import Control.Monad import Control.Monad.Trans.Maybe
import Data.Bits import Data.Bits
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy qualified as LBS import Data.ByteString.Lazy qualified as LBS
@ -228,7 +228,7 @@ spawnConnection tp env@MessagingTCP{..} so sa = liftIO do
debug $ "USED:" <+> viaShow tp <+> pretty own <+> pretty used debug $ "USED:" <+> viaShow tp <+> pretty own <+> pretty used
when ( used <= 2 ) do -- when ( used <= 2 ) do
atomically $ modifyTVar (view tcpPeerConn env) (HashMap.insert newP connId) atomically $ modifyTVar (view tcpPeerConn env) (HashMap.insert newP connId)
when (used == 1) do when (used == 1) do
@ -427,7 +427,11 @@ runMessagingTCP env@MessagingTCP{..} = liftIO do
dePips <- readTVarIO defs <&> HashMap.keys dePips <- readTVarIO defs <&> HashMap.keys
forM_ dePips $ \pip -> do forM_ dePips $ \pip -> void $ runMaybeT do
-- FIXME: make-sure-it-is-correct
already <- readTVarIO _tcpPeerXp <&> HashMap.member pip
msgs <- readTVarIO defs <&> HashMap.findWithDefault mempty pip msgs <- readTVarIO defs <&> HashMap.findWithDefault mempty pip
unless (L.null msgs) do unless (L.null msgs) do
@ -442,9 +446,9 @@ runMessagingTCP env@MessagingTCP{..} = liftIO do
co' <- atomically $ readTVar (view tcpPeerConn env) <&> HashMap.lookup pip co' <- atomically $ readTVar (view tcpPeerConn env) <&> HashMap.lookup pip
when (isNothing co') do when (isNothing co') do
debug $ red "No session for" <+> pretty pip trace $ red "No session for" <+> pretty pip
maybe1 co' (void $ fireTCP env pip (connectPeerTCP env pip)) $ \co -> do lift $ maybe1 co' (void $ fireTCP env pip (connectPeerTCP env pip)) $ \co -> do
q' <- atomically $ readTVar (view tcpConnQ env) <&> HashMap.lookup co q' <- atomically $ readTVar (view tcpConnQ env) <&> HashMap.lookup co
maybe1 q' none $ \q -> do maybe1 q' none $ \q -> do
atomically do atomically do

24
hbs2-peer/app/HttpWorker.hs
View File

@ -102,12 +102,16 @@ httpWorker (PeerConfig syn) pmeta e = do
get "/size/:hash" do get "/size/:hash" do
what <- param @String "hash" <&> fromString void $ flip runContT pure do
what <- lift (param @String "hash")
<&> fromStringMay
>>= orElse (status status404)
size <- liftIO $ hasBlock sto what size <- liftIO $ hasBlock sto what
case size of case size of
Nothing -> status status404 Nothing -> lift $ status status404
Just n -> do Just n -> do
json n lift $ json n
-- TODO: key-to-disable-tree-streaming -- TODO: key-to-disable-tree-streaming
@ -131,11 +135,19 @@ httpWorker (PeerConfig syn) pmeta e = do
-- TODO: define-parsable-instance-for-our-types -- TODO: define-parsable-instance-for-our-types
get "/tree/:hash" do get "/tree/:hash" do
what <- param @String "hash" <&> fromString void $ flip runContT pure do
getTreeHash sto what what <- lift (param @String "hash")
<&> fromStringMay
>>= orElse (status status404)
lift $ getTreeHash sto what
get "/cat/:hash" do get "/cat/:hash" do
what <- param @String "hash" <&> fromString void $ flip runContT pure do
what <- lift (param @String "hash")
<&> fromStringMay
>>= orElse (status status404)
lift do
blob <- liftIO $ getBlock sto what blob <- liftIO $ getBlock sto what
case blob of case blob of
Nothing -> status status404 Nothing -> status status404