summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Avahi.hs
blob: ba5138bc1b6709718775fb030f380c2f7aaa2c34 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns    #-}
module Network.Tox.Avahi
  ( module Network.Tox.Avahi
  , NodeInfo(..)
  , NodeId(..)
  ) where
import           Data.Foldable
import           GHC.Conc.Sync
import           GHC.Word           (Word16)
import           Network.Address
import           Network.Avahi
import           Network.Avahi
import           Network.Socket
import           Network.Tox.NodeId
import           Text.Read

toxServiceName :: String
toxServiceName = "_tox_dht._udp"

toxServiceDomain :: String
toxServiceDomain = "local"

(<.>) :: String -> String -> String
a <.> b = a ++ "." ++ b

toxService :: String -> PortNumber -> NodeId -> Service
toxService hostname (fromIntegral -> port) (show -> extra) =
  Service {
    serviceProtocol = PROTO_UNSPEC,
    serviceName     = "Tox DHT @ " ++ hostname,
    serviceType     = toxServiceName,
    serviceDomain   = toxServiceDomain,
    serviceHost     = if null hostname then "" else hostname <.> toxServiceDomain,
    serviceAddress  = Nothing,
    servicePort     = port,
    serviceText     = extra
  }

announceToxService :: String -> PortNumber -> NodeId -> IO ThreadId
announceToxService = ((.).(.).(.)) (forkIO . announce) toxService

queryToxService :: (NodeInfo -> IO ()) -> IO ThreadId
queryToxService cb =
  forkIO $
  browse $
  BrowseQuery
  { lookupProtocol    = PROTO_UNSPEC
  , lookupServiceName = toxServiceName
  , lookupDomain      = toxServiceDomain
  , lookupCallback    = runCallback
  }
  where
    runCallback x@Service {..} = do
      let nid = readMaybe serviceText
          addr = readMaybe =<< serviceAddress
          p = fromIntegral servicePort
      forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p)