diff --git a/hbs2-core/lib/HBS2/Net/IP/Addr.hs b/hbs2-core/lib/HBS2/Net/IP/Addr.hs index 650948de..ba18d3ff 100644 --- a/hbs2-core/lib/HBS2/Net/IP/Addr.hs +++ b/hbs2-core/lib/HBS2/Net/IP/Addr.hs @@ -129,3 +129,4 @@ pHostName = do pure (host, Text.pack (show port)) + diff --git a/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs b/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs index 4bcd3cee..6c7881b8 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/UDP.hs @@ -184,3 +184,12 @@ instance Messaging MessagingUDP UDP ByteString where liftIO $ atomically $ Q0.readTQueue (sink bus) <&> L.singleton + +parsePeerAddr :: MonadIO m => String -> m (Maybe (Peer UDP)) +parsePeerAddr s = do + ai <- liftIO $ parseAddr (fromString s) <&> listToMaybe + let sa = fmap addrAddress ai + pure $ PeerUDP <$> sa + + + diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 5a01a3e7..0833c496 100644 --- a/hbs2-core/lib/HBS2/OrDie.hs +++ b/hbs2-core/lib/HBS2/OrDie.hs @@ -8,10 +8,10 @@ class OrDie m a where type family OrDieResult a :: Type orDie :: m a -> String -> m (OrDieResult a) -instance OrDie IO (Maybe a) where +instance MonadIO m => OrDie m (Maybe a) where type instance OrDieResult (Maybe a) = a orDie mv err = mv >>= \case - Nothing -> die err + Nothing -> liftIO $ die err Just x -> pure x instance MonadIO m => OrDie m ExitCode where diff --git a/hbs2-peer/app/DetectGateway.hs b/hbs2-peer/app/DetectGateway.hs new file mode 100644 index 00000000..2d84a560 --- /dev/null +++ b/hbs2-peer/app/DetectGateway.hs @@ -0,0 +1,77 @@ +{-# Language AllowAmbiguousTypes #-} +module DetectGateway (detectGatewayLoop) where + +import HBS2.Prelude.Plated +import HBS2.Clock +import HBS2.Net.Messaging +import HBS2.Net.Proto.Types +import HBS2.OrDie +import HBS2.Net.Messaging.UDP + +import HBS2.System.Logger.Simple + +import Data.Attoparsec.Text as Atto +import Data.Functor +import Control.Concurrent.Async +-- import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy.Char8 qualified as LBS +import Data.ByteString.Lazy.Char8 (ByteString) +import Control.Monad +import Data.Text.Encoding qualified as T +import Data.Text as T +import Data.List qualified as List +import Data.Maybe + +detectGatewayLoop :: forall m . (MonadIO m) => m () +detectGatewayLoop = do + + mlisten <- newMessagingUDPMulticast upnpMulticast + `orDie` "Can't start UPnP protocol" + + trace $ "UPnP listen:" <+> pretty (listenAddr mlisten) + + upaddr <- parsePeerAddr upnpMulticast + `orDie` "Can't parse upnp address" + + udpMessListen <- liftIO $ async $ runMessagingUDP mlisten + + + reqLoop <- liftIO $ async $ forever do + sendTo mlisten (To upaddr) (From upaddr) gwDetectMsg + pause @'Seconds 10 + + forever $ do + debug "detectGatewayLoop" + + answ <- receive @_ @UDP @ByteString mlisten (To upaddr) + + gwAddrs <- forM answ $ \(From sa,msg) -> do + let txt = foldMap T.words $ T.lines $ T.decodeUtf8 $ LBS.toStrict msg + debug $ pretty sa <+> pretty (show msg) + pure Nothing + -- maybe1 (List.find (== "urn:schemas-upnp-org:device:InternetGatewayDevice:1") txt) + -- (pure Nothing) + -- (const $ pure $ Just sa) + + pure () + -- let gwAddr = headMay $ catMaybes gwAddrs + + -- TODO: what-if-more-than-one-gateway + -- maybe1 gwAddr none $ \gwa -> do + -- debug $ "FOUND FIRST GATEWAY:" <+> pretty gwa + + -- FIXME: remove-debug-hardcode + -- pause @'Seconds 30 + + -- void $ liftIO $ waitAnyCatchCancel [udpMessSend] -- , udpMessListen] + + where + upnpMulticast = "239.255.255.250:1900" + gwDetectMsg = LBS.intercalate "\r\n" + [ "M-SEARCH * HTTP/1.1" + , "HOST: 239.255.255.250:1900" + , "MAN: \"ssdp:discover\"" + , "MX: 2" + , "ST: urn:schemas-upnp-org:device:InternetGatewayDevice:1" + ] + diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 9233996c..b6e9407c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -36,6 +36,7 @@ import PeerInfo import PeerConfig import Bootstrap import CheckMetrics +import DetectGateway import Data.Text qualified as Text import Data.Foldable (for_) @@ -537,6 +538,8 @@ runPeer opts = Exception.handle myException $ do debug "sending local peer announce" request localMulticast (PeerAnnounce @e pnonce) + peerThread detectGatewayLoop + peerThread (checkMetrics metrics) peerThread (peerPingLoop @e) diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index a02f6dcc..cc19669c 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -20,6 +20,7 @@ common common-deps build-depends: base, hbs2-core, hbs2-storage-simple , async + , attoparsec , bytestring , cache , containers @@ -114,6 +115,7 @@ executable hbs2-peer , PeerTypes , PeerConfig , CheckMetrics + , DetectGateway -- other-extensions: build-depends: base