wip

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

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

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
 

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
 

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
+
+                          r :: Maybe () <- runMaybeT do
+                              resp <- MaybeT (liftIO $ fmap eitherToMaybe
+                                        $ race ( pause defBlockWaitMax )
+                                        (do
                                             req  <- liftIO $ parseRequest [qc|http://{peerHttpApiAddr}/metadata|]
-                                resp <- httpLbs req
+                                            httpLbs req
-                                case statusCode (getResponseStatus resp) of
+                                         )
-                                  200 -> pure True
+                                          `catch` (\(e :: SomeException) -> debug (viaShow e) >> pure (Left ()))
-                                  _   -> pure False
+                                    )
-                          liftIO $ atomically $ writeTVar (_peerHttpApiAddress pinfo) $ Right $
+                              MaybeT . pure $ case statusCode (getResponseStatus resp) of
-                            case r of
+                                  200 -> Just ()
-                                  Right True -> Just peerHttpApiAddr
                                   _   -> 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
 

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)
 

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))
 
 ---