mirror of https://github.com/voidlizard/hbs2
109 lines
3.2 KiB
Haskell
109 lines
3.2 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
module DetectGateway (detectGatewayLoop) where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Clock
|
|
import HBS2.Net.Messaging
|
|
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
|
|
-- 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.Maybe
|
|
import Data.Either
|
|
import Data.Function
|
|
|
|
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
|
|
`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
|
|
|
|
|
|
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
|
|
|
|
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
|
|
|
|
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
|
|
|
|
void $ liftIO $ waitAnyCatchCancel [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"
|
|
]
|
|
|