diff --git a/hbs2-peer/app/DetectGateway.hs b/hbs2-peer/app/DetectGateway.hs index 2d84a560..f8edeb2e 100644 --- a/hbs2-peer/app/DetectGateway.hs +++ b/hbs2-peer/app/DetectGateway.hs @@ -4,12 +4,15 @@ 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.Events +import HBS2.Net.IP.Addr import HBS2.System.Logger.Simple +import PeerTypes +import Data.Char (isSpace) import Data.Attoparsec.Text as Atto import Data.Functor import Control.Concurrent.Async @@ -19,10 +22,33 @@ 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 +import Data.Either +import Data.Function -detectGatewayLoop :: forall m . (MonadIO m) => m () +checkHTTPHead :: Text -> Bool +checkHTTPHead s = parseOnly pHead s & fromRight False + +checkIGDString :: Text -> Bool +checkIGDString s = parseOnly pIGD s & fromRight False + +pHead :: Parser Bool +pHead = do + void $ string "HTTP/" + skipWhile (not . isSpace) -- >> skipWhile isSpace + void skipSpace + void $ string "200" + pure True + +pIGD :: Parser Bool +pIGD = do + -- ST: urn:schemas-upnp-org:device:InternetGatewayDevice:1 + void $ string "ST:" + void skipSpace + void $ string "urn:schemas-upnp-org:device:InternetGatewayDevice:1" + pure True + +detectGatewayLoop :: forall e m . (MonadIO m, EventEmitter e (UPnPGatewayDetect e) m) => m () detectGatewayLoop = do mlisten <- newMessagingUDPMulticast upnpMulticast @@ -36,34 +62,39 @@ detectGatewayLoop = do udpMessListen <- liftIO $ async $ runMessagingUDP mlisten - reqLoop <- liftIO $ async $ forever do - sendTo mlisten (To upaddr) (From upaddr) gwDetectMsg - pause @'Seconds 10 + let waitIGDAnswer = liftIO $ race (pause @'Seconds 5 >> pure Nothing) $ + fix \next -> do + answ <- receive @_ @UDP @ByteString mlisten (To upaddr) + gwAddrs <- forM answ $ \(From sa,msg) -> do + let txt = T.lines $ T.decodeUtf8 $ LBS.toStrict msg + trace $ "ANSW:" <+> pretty txt + let isAnsw = headMay txt <&> checkHTTPHead + let isIGD = or $ fmap checkIGDString txt + if isAnsw == Just True && isIGD then + pure (Just sa) + else + pure Nothing - forever $ do + let gwAddr = headMay $ catMaybes gwAddrs + + -- TODO: what-if-more-than-one-gateway + maybe1 gwAddr next $ \gwa -> do + pure (Just gwa) + + forever do debug "detectGatewayLoop" + sendTo mlisten (To upaddr) (From upaddr) gwDetectMsg + mbGwa <- waitIGDAnswer <&> fromRight Nothing - answ <- receive @_ @UDP @ByteString mlisten (To upaddr) + maybe1 mbGwa (pause @'Seconds 60) $ \gwa -> do + let wa = pause @'Seconds 1200 + let a = getHostPort (T.pack $ show $ pretty gwa) + maybe1 a wa $ \(s,_) -> do + debug $ "found some gateway:" <+> pretty s + emit @e UPnPGatewayDetectKey (UPnPGatewayDetect s) + wa - 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] + void $ liftIO $ waitAnyCatchCancel [udpMessListen] where upnpMulticast = "239.255.255.250:1900" diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index b6e9407c..9bd1ce7e 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -538,7 +538,7 @@ runPeer opts = Exception.handle myException $ do debug "sending local peer announce" request localMulticast (PeerAnnounce @e pnonce) - peerThread detectGatewayLoop + peerThread (detectGatewayLoop @e) peerThread (checkMetrics metrics) diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index adcc8d59..d3824177 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -64,6 +64,27 @@ instance EventType ( Event e (DownloadReq e) ) where instance Expires (EventKey e (DownloadReq e)) where expiresIn = const Nothing +data UPnPGatewayDetect e + +data instance EventKey e (UPnPGatewayDetect e) = + UPnPGatewayDetectKey + deriving (Generic,Typeable,Eq) + +newtype instance Event e (UPnPGatewayDetect e) = + UPnPGatewayDetect String + deriving (Typeable) + +instance Typeable (UPnPGatewayDetect e) => Hashable (EventKey e (UPnPGatewayDetect e)) where + hashWithSalt salt _ = hashWithSalt salt (someTypeRep p) + where + p = Proxy @DownloadReq + +instance EventType ( Event e (UPnPGatewayDetect e) ) where + isPersistent = True + +instance Expires (EventKey e (UPnPGatewayDetect e)) where + expiresIn = const Nothing + type DownloadFromPeerStuff e m = ( MyPeer e , MonadIO m , Request e (BlockInfo e) m