wip

hbs2-core/lib/HBS2/Net/IP/Addr.hs

@@ -129,3 +129,4 @@ pHostName = do
   pure (host, Text.pack (show port))
 
 
+

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

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

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"
+      ]
+

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)

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