summaryrefslogtreecommitdiff
path: root/dht
diff options
context:
space:
mode:
Diffstat (limited to 'dht')
-rw-r--r--dht/Data/BitSyntax.hs7
-rw-r--r--dht/dht-client.cabal21
-rw-r--r--dht/examples/dht.hs5
-rw-r--r--dht/src/Codec/AsciiKey256.hs7
-rw-r--r--dht/src/Data/Tox/Onion.hs6
-rw-r--r--dht/src/Network/BitTorrent/MainlineDHT.hs6
-rw-r--r--dht/src/Network/Tox/Avahi.hs22
-rw-r--r--dht/src/Network/Tox/NodeId.hs27
8 files changed, 76 insertions, 25 deletions
diff --git a/dht/Data/BitSyntax.hs b/dht/Data/BitSyntax.hs
index 6d14d0c1..9ebffe73 100644
--- a/dht/Data/BitSyntax.hs
+++ b/dht/Data/BitSyntax.hs
@@ -1,5 +1,6 @@
1{-# LANGUAGE TemplateHaskell #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ForeignFunctionInterface #-} 2{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE TemplateHaskell #-}
3-- | This module contains fuctions and templates for building up and breaking 4-- | This module contains fuctions and templates for building up and breaking
4-- down packed bit structures. It's something like Erlang's bit-syntax (or, 5-- down packed bit structures. It's something like Erlang's bit-syntax (or,
5-- actually, more like Python's struct module). 6-- actually, more like Python's struct module).
@@ -278,7 +279,11 @@ readElement (stmts, inputname, tuplenames) (Context funcname) = do
278 let stmt = BindS (TupP [VarP valname, VarP restname]) 279 let stmt = BindS (TupP [VarP valname, VarP restname])
279 (AppE (AppE (VarE funcname) 280 (AppE (AppE (VarE funcname)
280 (VarE inputname)) 281 (VarE inputname))
282#if MIN_VERSION_template_haskell(2,16,0)
283 (TupE $ map (Just . VarE) $ reverse tuplenames))
284#else
281 (TupE $ map VarE $ reverse tuplenames)) 285 (TupE $ map VarE $ reverse tuplenames))
286#endif
282 287
283 return (stmt : stmts, restname, valname : tuplenames) 288 return (stmt : stmts, restname, valname : tuplenames)
284 289
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal
index 0da181df..6a449a6a 100644
--- a/dht/dht-client.cabal
+++ b/dht/dht-client.cabal
@@ -27,6 +27,10 @@ description:
27extra-source-files: ChangeLog 27extra-source-files: ChangeLog
28 cbits/*.h 28 cbits/*.h
29 29
30flag avahi
31 description: Advertise Tox node on avahi.
32 Disable to avoid an indirect dependency on lens.
33 default: True
30 34
31flag network-uri 35flag network-uri
32 description: Use network-uri package. 36 description: Use network-uri package.
@@ -207,7 +211,6 @@ library
207 , blaze-builder 211 , blaze-builder
208 , exceptions 212 , exceptions
209 , hinotify 213 , hinotify
210 , avahi >= 0.2.0
211 , dput-hslogger 214 , dput-hslogger
212 , word64-map 215 , word64-map
213 , network-addr 216 , network-addr
@@ -223,6 +226,9 @@ library
223 if impl(ghc < 8) 226 if impl(ghc < 8)
224 Build-depends: transformers 227 Build-depends: transformers
225 228
229 if flag(avahi)
230 Build-depends: avahi >= 0.2.0
231
226 if flag(no-constraint-extras) 232 if flag(no-constraint-extras)
227 build-depends: dependent-sum < 0.6 233 build-depends: dependent-sum < 0.6
228 else 234 else
@@ -282,11 +288,14 @@ library
282 build-depends: cryptonite >= 0.22 288 build-depends: cryptonite >= 0.22
283 289
284executable avahi 290executable avahi
285 hs-source-dirs: examples 291 hs-source-dirs: examples
286 main-is: avahi.hs 292 main-is: avahi.hs
287 default-language: Haskell2010 293 if flag(avahi)
288 build-depends: base-prelude, dht-client, avahi, network 294 default-language: Haskell2010
289 ghc-options: -fobject-code 295 build-depends: base-prelude, dht-client, avahi, network
296 ghc-options: -fobject-code
297 else
298 buildable: False
290 299
291executable dht 300executable dht
292 hs-source-dirs: examples 301 hs-source-dirs: examples
diff --git a/dht/examples/dht.hs b/dht/examples/dht.hs
index 3e1b1656..6615477b 100644
--- a/dht/examples/dht.hs
+++ b/dht/examples/dht.hs
@@ -1,3 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE NondecreasingIndentation #-} 2{-# LANGUAGE NondecreasingIndentation #-}
2import Control.Applicative 3import Control.Applicative
3import Control.Monad 4import Control.Monad
@@ -13,6 +14,10 @@ import System.IO
13import System.IO.Unsafe 14import System.IO.Unsafe
14import qualified Data.ByteString as B 15import qualified Data.ByteString as B
15 16
17#if MIN_VERSION_haskeline(0,8,0)
18import Control.Exception (handle)
19#endif
20
16-- | Reads one character. If it is not a digit, 21-- | Reads one character. If it is not a digit,
17-- then it is discarded and 'Nothing' is returned. 22-- then it is discarded and 'Nothing' is returned.
18hReadDigit :: Handle -> IO (Maybe Char) 23hReadDigit :: Handle -> IO (Maybe Char)
diff --git a/dht/src/Codec/AsciiKey256.hs b/dht/src/Codec/AsciiKey256.hs
index ee17b7c1..1738a368 100644
--- a/dht/src/Codec/AsciiKey256.hs
+++ b/dht/src/Codec/AsciiKey256.hs
@@ -3,6 +3,7 @@ module Codec.AsciiKey256 where
3 3
4import Control.Applicative 4import Control.Applicative
5import Control.Monad 5import Control.Monad
6import Control.Monad.Fail as MF
6import Data.Bits 7import Data.Bits
7import qualified Data.ByteArray as BA 8import qualified Data.ByteArray as BA
8 ;import Data.ByteArray as BA (ByteArrayAccess) 9 ;import Data.ByteArray as BA (ByteArrayAccess)
@@ -112,7 +113,7 @@ readsPrecKey256 publicKey str
112 | otherwise = [] 113 | otherwise = []
113 114
114 115
115parseKey256 :: (Monad m, Alternative m) => String -> m ByteString 116parseKey256 :: (MonadFail m, Alternative m) => String -> m ByteString
116parseKey256 nidstr = do 117parseKey256 nidstr = do
117 let nidbs = C8.pack nidstr 118 let nidbs = C8.pack nidstr
118 (bs,_) = Base16.decode nidbs 119 (bs,_) = Base16.decode nidbs
@@ -121,7 +122,7 @@ parseKey256 nidstr = do
121 43 -> parseToken32 nidstr 122 43 -> parseToken32 nidstr
122 _ -> Left "Wrong size of key." 123 _ -> Left "Wrong size of key."
123 idbs <- (guard (B.length bs == 32) >> return bs) 124 idbs <- (guard (B.length bs == 32) >> return bs)
124 <|> either fail return enid 125 <|> either MF.fail return enid
125 return idbs 126 return idbs
126 127
127readP_key256 :: RP.ReadP ByteString 128readP_key256 :: RP.ReadP ByteString
@@ -131,7 +132,7 @@ readP_key256 = do
131 , fmap (32,) (sequence $ replicate 52 (RP.satisfy zb32digit)) 132 , fmap (32,) (sequence $ replicate 52 (RP.satisfy zb32digit))
132 , fmap (64,) (sequence $ replicate 43 (RP.satisfy b64digit)) 133 , fmap (64,) (sequence $ replicate 43 (RP.satisfy b64digit))
133 ] 134 ]
134 let failure = fail "Bad key." 135 let failure = MF.fail "Bad key."
135 case is64 of 136 case is64 of
136 32 -> case parse32Token32 hexhash of 137 32 -> case parse32Token32 hexhash of
137 Right bs -> return bs 138 Right bs -> return bs
diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs
index 55e81069..d6f747d9 100644
--- a/dht/src/Data/Tox/Onion.hs
+++ b/dht/src/Data/Tox/Onion.hs
@@ -38,7 +38,11 @@ import Data.Function
38import Data.Functor.Contravariant 38import Data.Functor.Contravariant
39import Data.Functor.Identity 39import Data.Functor.Identity
40#if MIN_VERSION_iproute(1,7,4) 40#if MIN_VERSION_iproute(1,7,4)
41import Data.IP hiding (fromSockAddr) 41import Data.IP hiding ( fromSockAddr
42#if MIN_VERSION_iproute(1,7,8)
43 , toSockAddr
44#endif
45 )
42#else 46#else
43import Data.IP 47import Data.IP
44#endif 48#endif
diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs
index e604f5e5..fc69fedd 100644
--- a/dht/src/Network/BitTorrent/MainlineDHT.hs
+++ b/dht/src/Network/BitTorrent/MainlineDHT.hs
@@ -40,7 +40,11 @@ import Data.Digest.CRC32C
40import Data.Function (fix) 40import Data.Function (fix)
41import Data.Hashable 41import Data.Hashable
42#if MIN_VERSION_iproute(1,7,4) 42#if MIN_VERSION_iproute(1,7,4)
43import Data.IP hiding (fromSockAddr) 43import Data.IP hiding ( fromSockAddr
44#if MIN_VERSION_iproute(1,7,8)
45 , toSockAddr
46#endif
47 )
44#else 48#else
45import Data.IP 49import Data.IP
46#endif 50#endif
diff --git a/dht/src/Network/Tox/Avahi.hs b/dht/src/Network/Tox/Avahi.hs
index 635ba656..2ca6515c 100644
--- a/dht/src/Network/Tox/Avahi.hs
+++ b/dht/src/Network/Tox/Avahi.hs
@@ -1,4 +1,5 @@
1{-# OPTIONS_GHC -Wall #-} 1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE RecordWildCards #-} 3{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ViewPatterns #-} 4{-# LANGUAGE ViewPatterns #-}
4module Network.Tox.Avahi 5module Network.Tox.Avahi
@@ -10,11 +11,17 @@ module Network.Tox.Avahi
10import Control.Applicative 11import Control.Applicative
11import Data.Foldable 12import Data.Foldable
12import Network.Address 13import Network.Address
13import Network.Avahi
14import Network.BSD (getHostName) 14import Network.BSD (getHostName)
15import Network.Tox.NodeId 15import Network.Tox.NodeId
16import Text.Read 16import Text.Read
17 17
18#if defined(VERSION_avahi)
19import Network.Avahi
20#else
21data Service = Service
22#endif
23
24
18toxServiceName :: String 25toxServiceName :: String
19toxServiceName = "_tox_dht._udp" 26toxServiceName = "_tox_dht._udp"
20 27
@@ -26,7 +33,9 @@ a <.> b = a ++ "." ++ b
26 33
27toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service 34toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service
28toxService hostname (fromIntegral -> port) dhtkey toxid = 35toxService hostname (fromIntegral -> port) dhtkey toxid =
29 Service { 36 Service
37#if defined(VERSION_avahi)
38 {
30 serviceProtocol = PROTO_UNSPEC, 39 serviceProtocol = PROTO_UNSPEC,
31 serviceName = "Tox DHT @ " ++ hostname, 40 serviceName = "Tox DHT @ " ++ hostname,
32 serviceType = toxServiceName, 41 serviceType = toxServiceName,
@@ -36,10 +45,15 @@ toxService hostname (fromIntegral -> port) dhtkey toxid =
36 servicePort = port, 45 servicePort = port,
37 serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid 46 serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid
38 } 47 }
48#endif
39 49
40announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO () 50announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
51#if defined(VERSION_avahi)
41announceToxServiceWithHostname = (boobs.boobs) announce toxService 52announceToxServiceWithHostname = (boobs.boobs) announce toxService
42 where boobs = ((.).(.)) 53 where boobs = ((.).(.))
54#else
55announceToxServiceWithHostname _ _ _ _ = return ()
56#endif
43 57
44announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO () 58announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
45announceToxService a b c = do 59announceToxService a b c = do
@@ -48,6 +62,7 @@ announceToxService a b c = do
48 62
49queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO () 63queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO ()
50queryToxService cb = 64queryToxService cb =
65#if defined(VERSION_avahi)
51 browse $ 66 browse $
52 BrowseQuery 67 BrowseQuery
53 { lookupProtocol = PROTO_UNSPEC 68 { lookupProtocol = PROTO_UNSPEC
@@ -63,3 +78,6 @@ queryToxService cb =
63 addr = readMaybe =<< serviceAddress 78 addr = readMaybe =<< serviceAddress
64 p = fromIntegral servicePort 79 p = fromIntegral servicePort
65 forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both) 80 forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both)
81#else
82 return ()
83#endif
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
index d05e3697..667e7d71 100644
--- a/dht/src/Network/Tox/NodeId.hs
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -47,6 +47,7 @@ module Network.Tox.NodeId
47import Control.Applicative 47import Control.Applicative
48import Control.Arrow 48import Control.Arrow
49import Control.Monad 49import Control.Monad
50import Control.Monad.Fail as MF
50#ifdef CRYPTONITE_BACKPORT 51#ifdef CRYPTONITE_BACKPORT
51import Crypto.Error.Types (CryptoFailable (..), 52import Crypto.Error.Types (CryptoFailable (..),
52 throwCryptoError) 53 throwCryptoError)
@@ -70,7 +71,11 @@ import Data.Char
70import Data.Data 71import Data.Data
71import Data.Hashable 72import Data.Hashable
72#if MIN_VERSION_iproute(1,7,4) 73#if MIN_VERSION_iproute(1,7,4)
73import Data.IP hiding (fromSockAddr) 74import Data.IP hiding ( fromSockAddr
75#if MIN_VERSION_iproute(1,7,8)
76 , toSockAddr
77#endif
78 )
74#else 79#else
75import Data.IP 80import Data.IP
76#endif 81#endif
@@ -258,7 +263,7 @@ getIP 0x02 = IPv4 <$> S.get
258getIP 0x0a = IPv6 <$> S.get 263getIP 0x0a = IPv6 <$> S.get
259getIP 0x82 = IPv4 <$> S.get -- TODO: TCP TOX_TCP_INET 264getIP 0x82 = IPv4 <$> S.get -- TODO: TCP TOX_TCP_INET
260getIP 0x8a = IPv6 <$> S.get -- TODO: TCP TOX_TCP_INET6 265getIP 0x8a = IPv6 <$> S.get -- TODO: TCP TOX_TCP_INET6
261getIP x = fail ("unsupported address family ("++show x++")") 266getIP x = MF.fail ("unsupported address family ("++show x++")")
262 267
263instance Sized NodeInfo where 268instance Sized NodeInfo where
264 size = VarSize $ \(NodeInfo nid ip port) -> 269 size = VarSize $ \(NodeInfo nid ip port) ->
@@ -306,7 +311,7 @@ instance Read NodeInfo where
306 return (nid,addrstr) 311 return (nid,addrstr)
307 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) 312 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
308 (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of 313 (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of
309 [] -> fail "Bad address." 314 [] -> MF.fail "Bad address."
310 ((ip,port),_):_ -> return (ip,port) 315 ((ip,port),_):_ -> return (ip,port)
311 return $ NodeInfo nid ip port 316 return $ NodeInfo nid ip port
312 317
@@ -406,7 +411,7 @@ getIP 0x02 = IPv4 <$> S.get
406getIP 0x0a = IPv6 <$> S.get 411getIP 0x0a = IPv6 <$> S.get
407getIP 0x82 = IPv4 <$> S.get -- TODO: TCP 412getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
408getIP 0x8a = IPv6 <$> S.get -- TODO: TCP 413getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
409getIP x = fail ("unsupported address family ("++show x++")") 414getIP x = MF.fail ("unsupported address family ("++show x++")")
410 415
411instance S.Serialize NodeInfo where 416instance S.Serialize NodeInfo where
412 get = do 417 get = do
@@ -445,7 +450,7 @@ instance Read NodeInfo where
445 addrstr <- parseAddr 450 addrstr <- parseAddr
446 nid <- case Base16.decode $ C8.pack hexhash of 451 nid <- case Base16.decode $ C8.pack hexhash of
447 (bs,_) | B.length bs==32 -> return (PubKey bs) 452 (bs,_) | B.length bs==32 -> return (PubKey bs)
448 _ -> fail "Bad node id." 453 _ -> MF.fail "Bad node id."
449 return (nid,addrstr) 454 return (nid,addrstr)
450 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) 455 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
451 let raddr = do 456 let raddr = do
@@ -457,7 +462,7 @@ instance Read NodeInfo where
457 return (ip, port) 462 return (ip, port)
458 463
459 (ip,port) <- case RP.readP_to_S raddr addrstr of 464 (ip,port) <- case RP.readP_to_S raddr addrstr of
460 [] -> fail "Bad address." 465 [] -> MF.fail "Bad address."
461 ((ip,port),_):_ -> return (ip,port) 466 ((ip,port),_):_ -> return (ip,port)
462 return $ NodeInfo nid ip port 467 return $ NodeInfo nid ip port
463 468
@@ -518,15 +523,15 @@ instance Read NoSpam where
518 ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws 523 ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws
519 _ -> [] 524 _ -> []
520 525
521base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1) 526base64decode :: MonadFail m => t1 -> Get t -> String -> m (t, t1)
522base64decode rs getter s = 527base64decode rs getter s =
523 either fail (\a -> return (a,rs)) 528 either MF.fail (\a -> return (a,rs))
524 $ runGet getter 529 $ runGet getter
525 =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) 530 =<< Base64.decode (C8.pack $ map (nmtoken64 False) s)
526 531
527base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1) 532base16decode :: MonadFail m => t1 -> Get t -> String -> m (t, t1)
528base16decode rs getter s = 533base16decode rs getter s =
529 either fail (\a -> return (a,rs)) 534 either MF.fail (\a -> return (a,rs))
530 $ runGet getter 535 $ runGet getter
531 $ fst 536 $ fst
532 $ Base16.decode (C8.pack s) 537 $ Base16.decode (C8.pack s)
@@ -559,7 +564,7 @@ instance Show NoSpamId where
559 show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox" 564 show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox"
560 565
561instance Read NoSpamId where 566instance Read NoSpamId where
562 readsPrec d s = either fail id $ do 567 readsPrec d s = either MF.fail id $ do
563 (jid,xs) <- Right $ break isSpace s 568 (jid,xs) <- Right $ break isSpace s
564 nsid <- parseNoSpamId $ Text.pack jid 569 nsid <- parseNoSpamId $ Text.pack jid
565 return [(nsid,xs)] 570 return [(nsid,xs)]