diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index e2e691b7..b6be314e 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -20,6 +20,7 @@ common shared-properties ghc-options: -Wall -fno-warn-type-defaults + -- -prof -fprof-auto -- -fno-warn-unused-matches -- -fno-warn-unused-do-bind -- -Werror=missing-methods diff --git a/hbs2-core/lib/HBS2/Merkle.hs b/hbs2-core/lib/HBS2/Merkle.hs index 2af873ea..b95f15d0 100644 --- a/hbs2-core/lib/HBS2/Merkle.hs +++ b/hbs2-core/lib/HBS2/Merkle.hs @@ -5,7 +5,7 @@ module HBS2.Merkle where import HBS2.Prelude import HBS2.Hash -import Codec.Serialise +import Codec.Serialise (serialise, deserialiseOrFail) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS @@ -165,7 +165,8 @@ walkMerkle' :: (Serialise (MTree a), Monad m) walkMerkle' root flookup sink = go root where go hash = do - t <- (deserialise <$>) <$> flookup hash + -- t <- (either (error . show) id . deserialiseOrFail <$>) <$> flookup hash + t <- ((either (const Nothing) Just . deserialiseOrFail) =<<) <$> flookup hash case t of Just n@(MLeaf _) -> sink (Right n) Just n@(MNode _ hashes) -> sink (Right n) >> traverse_ go hashes diff --git a/hbs2-core/lib/HBS2/Net/IP/Addr.hs b/hbs2-core/lib/HBS2/Net/IP/Addr.hs index 3a389d26..2108dddf 100644 --- a/hbs2-core/lib/HBS2/Net/IP/Addr.hs +++ b/hbs2-core/lib/HBS2/Net/IP/Addr.hs @@ -61,7 +61,8 @@ instance Pretty (IPAddrPort e) where instance IsString (IPAddrPort e) where fromString s = IPAddrPort (read h, fromIntegral p) where - (h,p) = fromMaybe (error "no parse IPAddrPort") (getHostPort (Text.pack s)) + (h,p) = fromMaybe (error $ "no parse IPAddrPort: " <> show s) + (getHostPort (Text.pack s)) instance FromStringMaybe (IPAddrPort e) where fromStringMay x = IPAddrPort <$> ( (,) <$> ip <*> fmap fromIntegral po) @@ -74,7 +75,7 @@ getHostPort :: Text -> Maybe (String, PortNumber) getHostPort s = parseOnly p s & either (const Nothing) Just where p = do - (h, p) <- pAddr + (h, p) <- pAddr <|> tcppAddr pure (Text.unpack h, read (Text.unpack p)) @@ -94,6 +95,9 @@ parseAddr tp s = fromMaybe mempty <$> runMaybeT do where udp = defaultHints { addrSocketType = tp } +tcppAddr :: Parser (Text, Text) +tcppAddr = "tcp://" *> pAddr + pAddr :: Parser (Text, Text) pAddr = pIP6 <|> pIP4 <|> pHostName diff --git a/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs b/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs index 2a0ceb47..520e18d7 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/PeerMeta.hs @@ -61,7 +61,7 @@ newtype instance Event e (PeerMetaProto e) newtype PeerMeta = PeerMeta { unPeerMeta :: [(Text, ByteString)] } deriving stock (Generic) - deriving newtype (Semigroup, Monoid) + deriving newtype (Semigroup, Monoid, Show) instance Serialise PeerMeta diff --git a/hbs2-peer/app/BlockHttpDownload.hs b/hbs2-peer/app/BlockHttpDownload.hs index 02236260..fcc8423a 100644 --- a/hbs2-peer/app/BlockHttpDownload.hs +++ b/hbs2-peer/app/BlockHttpDownload.hs @@ -55,6 +55,7 @@ import Streaming.Prelude qualified as S import System.Random (randomRIO) import System.Random.Shuffle (shuffleM) import Text.InterpolatedString.Perl6 (qc) +import UnliftIO.Exception blockHttpDownloadLoop :: forall e m . ( m ~ PeerM e IO @@ -212,18 +213,25 @@ fillPeerMeta = do lift do peerHttpApiAddr <- show . pretty <$> replacePort p port - -- check peerHttpApiAddr - r <- liftIO $ race ( pause defBlockWaitMax ) do - req <- liftIO $ parseRequest [qc|http://{peerHttpApiAddr}/metadata|] - resp <- httpLbs req - case statusCode (getResponseStatus resp) of - 200 -> pure True - _ -> pure False - liftIO $ atomically $ writeTVar (_peerHttpApiAddress pinfo) $ Right $ - case r of - Right True -> Just peerHttpApiAddr - _ -> Nothing + + r :: Maybe () <- runMaybeT do + resp <- MaybeT (liftIO $ fmap eitherToMaybe + $ race ( pause defBlockWaitMax ) + (do + req <- liftIO $ parseRequest [qc|http://{peerHttpApiAddr}/metadata|] + httpLbs req + ) + `catch` (\(e :: SomeException) -> debug (viaShow e) >> pure (Left ())) + ) + MaybeT . pure $ case statusCode (getResponseStatus resp) of + 200 -> Just () + _ -> Nothing + + liftIO $ atomically $ writeTVar (_peerHttpApiAddress pinfo) $ Right $ peerHttpApiAddr <$ r + mapM_ (liftIO . atomically . writeTVar (_peerMeta pinfo) . Just) $ peerMeta <$ r + debug $ "Got peer meta from" <+> pretty p <+> ":" <+> viaShow peerMeta + _ -> do liftIO $ atomically $ writeTVar (_peerHttpApiAddress pinfo) $ Right Nothing diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index cfd60914..815eab02 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -750,7 +750,7 @@ runPeer opts = Exception.handle myException $ do when useHttpDownload do peerThread "blockHttpDownloadLoop " (blockHttpDownloadLoop denv) - peerThread "postponedLoop" (postponedLoop denv) + -- peerThread "postponedLoop" (postponedLoop denv) peerThread "downloadQueue" (downloadQueue conf denv) diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 61ce3a11..aeb24650 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -226,7 +226,7 @@ runCat opts ss = do walk (fromHashRef h) AnnRef h -> do - let lnk = deserialise @AnnotatedHashRef obj + let lnk = _ $ deserialiseOrFail @AnnotatedHashRef obj let mbHead = headMay [ h | HashRefMerkle (HashRefObject (HashRef h) _) <- universeBi lnk ] @@ -353,6 +353,7 @@ runDumpACB :: Maybe FilePath -> IO () runDumpACB inFile = do inf <- maybe (pure stdin) (`openFile` ReadMode) inFile acb <- LBS.hGetContents inf <&> deserialise @(ACBSimple HBS2Basic) + -- acb <- LBS.hGetContents inf <&> (either (error . show) id . deserialiseOrFail @(ACBSimple HBS2Basic)) print $ pretty (AsSyntax (DefineACB "a1" acb)) ---