upnp gateway detection

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"

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)
 

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