HttpWorker exceptions

hbs2-core/lib/HBS2/Net/Messaging/TCP.hs

@@ -22,7 +22,7 @@ import HBS2.System.Logger.Simple
 import HBS2.Misc.PrettyStuff
 
 import Control.Concurrent.STM (flushTQueue)
-import Control.Monad
+import Control.Monad.Trans.Maybe
 import Data.Bits
 import Data.ByteString.Lazy (ByteString)
 import Data.ByteString.Lazy qualified as LBS
@@ -228,8 +228,8 @@ spawnConnection tp env@MessagingTCP{..} so sa = liftIO do
 
     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
 
@@ -427,7 +427,11 @@ runMessagingTCP env@MessagingTCP{..} = liftIO do
       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
 
         unless (L.null msgs) do
@@ -442,9 +446,9 @@ runMessagingTCP env@MessagingTCP{..} = liftIO do
           co' <- atomically $ readTVar (view tcpPeerConn env) <&> HashMap.lookup pip
 
           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
             maybe1 q' none $ \q -> do
               atomically do

hbs2-peer/app/HttpWorker.hs

@@ -102,12 +102,16 @@ httpWorker (PeerConfig syn) pmeta e = do
 
       get "/size/:hash" do
 
-        what <- param @String "hash" <&> fromString
+        void $ flip runContT pure do
-        size <- liftIO $ hasBlock sto what
+          what <- lift (param @String "hash")
-        case size of
+                    <&> fromStringMay
-          Nothing -> status status404
+                    >>= orElse (status status404)
-          Just n -> do
+
-            json n
+          size <- liftIO $ hasBlock sto what
+          case size of
+            Nothing -> lift $ status status404
+            Just n -> do
+              lift $ json n
 
       -- TODO: key-to-disable-tree-streaming
 
@@ -131,18 +135,26 @@ httpWorker (PeerConfig syn) pmeta e = do
 
       -- TODO: define-parsable-instance-for-our-types
       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
-        what <- param @String "hash" <&> fromString
+        void $ flip runContT pure do
-        blob <- liftIO $ getBlock sto what
+          what <- lift (param @String "hash")
-        case blob of
+                    <&> fromStringMay
-          Nothing -> status status404
+                    >>= orElse (status status404)
-          Just lbs -> do
+          lift do
-            addHeader "content-type" "application/octet-stream"
+            blob <- liftIO $ getBlock sto what
-            addHeader "content-length" [qc|{LBS.length lbs}|]
+            case blob of
-            raw lbs
+              Nothing -> status status404
+              Just lbs -> do
+                addHeader "content-type" "application/octet-stream"
+                addHeader "content-length" [qc|{LBS.length lbs}|]
+                raw lbs
 
       get "/reflog/:ref" do
         re <- param @String "ref" <&> fromStringMay