diff options
author | joe <joe@jerkface.net> | 2017-07-28 04:55:29 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-07-28 04:55:29 -0400 |
commit | 7f7ede57388ed29e0fbaab9aac6b9211f67ee3e2 (patch) | |
tree | 139be949fcc1c7d8e0d5030079a779fdda3f5883 /src | |
parent | d197a423e664ca20d7aec9cacb883cbc5af1493f (diff) |
Fixed cabal build.
Diffstat (limited to 'src')
-rw-r--r-- | src/Data/Torrent.hs | 1 | ||||
-rw-r--r-- | src/Network/Address.hs | 190 | ||||
-rw-r--r-- | src/Network/BitTorrent/DHT/Search.hs | 1 | ||||
-rw-r--r-- | src/Network/DatagramServer/Types.hs | 412 |
4 files changed, 173 insertions, 431 deletions
diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs index 004369ce..55b34f98 100644 --- a/src/Data/Torrent.hs +++ b/src/Data/Torrent.hs | |||
@@ -196,7 +196,6 @@ import System.Posix.Types | |||
196 | 196 | ||
197 | import Network.Address | 197 | import Network.Address |
198 | import Network.DHT.Routing | 198 | import Network.DHT.Routing |
199 | import Network.DatagramServer.Mainline | ||
200 | 199 | ||
201 | 200 | ||
202 | {----------------------------------------------------------------------- | 201 | {----------------------------------------------------------------------- |
diff --git a/src/Network/Address.hs b/src/Network/Address.hs index 9ecd89a3..8715a82d 100644 --- a/src/Network/Address.hs +++ b/src/Network/Address.hs | |||
@@ -59,18 +59,13 @@ module Network.Address | |||
59 | , peerSocket | 59 | , peerSocket |
60 | 60 | ||
61 | -- * Node | 61 | -- * Node |
62 | , NodeAddr (..) | ||
63 | |||
62 | -- ** Id | 64 | -- ** Id |
63 | , NodeId | ||
64 | , testIdBit | 65 | , testIdBit |
65 | , genNodeId | ||
66 | , bucketRange | 66 | , bucketRange |
67 | , genBucketSample | 67 | , genBucketSample |
68 | 68 | , genBucketSample' | |
69 | -- ** Info | ||
70 | , NodeAddr (..) | ||
71 | , NodeInfo (..) | ||
72 | , mapAddress | ||
73 | , traverseAddress | ||
74 | 69 | ||
75 | -- * Fingerprint | 70 | -- * Fingerprint |
76 | -- $fingerprint | 71 | -- $fingerprint |
@@ -126,7 +121,6 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) | |||
126 | import System.Locale (defaultTimeLocale) | 121 | import System.Locale (defaultTimeLocale) |
127 | #endif | 122 | #endif |
128 | import System.Entropy | 123 | import System.Entropy |
129 | import Network.DatagramServer.Types as RPC | ||
130 | 124 | ||
131 | -- import Paths_bittorrent (version) | 125 | -- import Paths_bittorrent (version) |
132 | 126 | ||
@@ -147,9 +141,82 @@ sockAddrPort (SockAddrInet6 p _ _ _) = Just p | |||
147 | sockAddrPort _ = Nothing | 141 | sockAddrPort _ = Nothing |
148 | {-# INLINE sockAddrPort #-} | 142 | {-# INLINE sockAddrPort #-} |
149 | 143 | ||
150 | instance Address a => Address (NodeAddr a) where | 144 | class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) |
151 | toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost | 145 | => Address a where |
152 | fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> sockAddrPort sa | 146 | toSockAddr :: a -> SockAddr |
147 | fromSockAddr :: SockAddr -> Maybe a | ||
148 | |||
149 | fromAddr :: (Address a, Address b) => a -> Maybe b | ||
150 | fromAddr = fromSockAddr . toSockAddr | ||
151 | |||
152 | -- | Note that port is zeroed. | ||
153 | instance Address IPv4 where | ||
154 | toSockAddr = SockAddrInet 0 . toHostAddress | ||
155 | fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) | ||
156 | fromSockAddr _ = Nothing | ||
157 | |||
158 | -- | Note that port is zeroed. | ||
159 | instance Address IPv6 where | ||
160 | toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 | ||
161 | fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) | ||
162 | fromSockAddr _ = Nothing | ||
163 | |||
164 | -- | Note that port is zeroed. | ||
165 | instance Address IP where | ||
166 | toSockAddr (IPv4 h) = toSockAddr h | ||
167 | toSockAddr (IPv6 h) = toSockAddr h | ||
168 | fromSockAddr sa = | ||
169 | IPv4 <$> fromSockAddr sa | ||
170 | <|> IPv6 <$> fromSockAddr sa | ||
171 | |||
172 | data NodeAddr a = NodeAddr | ||
173 | { nodeHost :: !a | ||
174 | , nodePort :: {-# UNPACK #-} !PortNumber | ||
175 | } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable) | ||
176 | |||
177 | instance Show a => Show (NodeAddr a) where | ||
178 | showsPrec i NodeAddr {..} | ||
179 | = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort | ||
180 | |||
181 | instance Read (NodeAddr IPv4) where | ||
182 | readsPrec i = RP.readP_to_S $ do | ||
183 | ipv4 <- RP.readS_to_P (readsPrec i) | ||
184 | _ <- RP.char ':' | ||
185 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
186 | return $ NodeAddr ipv4 port | ||
187 | |||
188 | -- | @127.0.0.1:6882@ | ||
189 | instance Default (NodeAddr IPv4) where | ||
190 | def = "127.0.0.1:6882" | ||
191 | |||
192 | -- | KRPC compatible encoding. | ||
193 | instance Serialize a => Serialize (NodeAddr a) where | ||
194 | get = NodeAddr <$> get <*> get | ||
195 | {-# INLINE get #-} | ||
196 | put NodeAddr {..} = put nodeHost >> put nodePort | ||
197 | {-# INLINE put #-} | ||
198 | |||
199 | -- | Example: | ||
200 | -- | ||
201 | -- @nodePort \"127.0.0.1:6881\" == 6881@ | ||
202 | -- | ||
203 | instance IsString (NodeAddr IPv4) where | ||
204 | fromString str | ||
205 | | [hostAddrStr, portStr] <- splitWhen (== ':') str | ||
206 | , Just hostAddr <- readMaybe hostAddrStr | ||
207 | , Just portNum <- toEnum <$> readMaybe portStr | ||
208 | = NodeAddr hostAddr portNum | ||
209 | | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str | ||
210 | |||
211 | |||
212 | instance Hashable a => Hashable (NodeAddr a) where | ||
213 | hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) | ||
214 | {-# INLINE hashWithSalt #-} | ||
215 | |||
216 | instance Pretty ip => Pretty (NodeAddr ip) where | ||
217 | pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort | ||
218 | |||
219 | |||
153 | 220 | ||
154 | instance Address PeerAddr where | 221 | instance Address PeerAddr where |
155 | toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost | 222 | toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost |
@@ -552,6 +619,37 @@ testIdBit :: FiniteBits bs => bs -> Word -> Bool | |||
552 | testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i)) | 619 | testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i)) |
553 | {-# INLINE testIdBit #-} | 620 | {-# INLINE testIdBit #-} |
554 | 621 | ||
622 | -- | Generate a random 'NodeId' within a range suitable for a bucket. To | ||
623 | -- obtain a sample for bucket number /index/ where /is_last/ indicates if this | ||
624 | -- is for the current deepest bucket in our routing table: | ||
625 | -- | ||
626 | -- > sample <- genBucketSample nid (bucketRange index is_last) | ||
627 | genBucketSample :: ( FiniteBits nid | ||
628 | , Serialize nid | ||
629 | ) => nid -> (Int,Word8,Word8) -> IO nid | ||
630 | genBucketSample n qmb = genBucketSample' getEntropy n qmb | ||
631 | |||
632 | -- | Generalizion of 'genBucketSample' that accepts a byte generator | ||
633 | -- function to use instead of the system entropy. | ||
634 | genBucketSample' :: forall m dht nid. | ||
635 | ( Applicative m | ||
636 | , FiniteBits nid | ||
637 | , Serialize nid | ||
638 | ) => | ||
639 | (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid | ||
640 | genBucketSample' gen self (q,m,b) | ||
641 | | q <= 0 = either error id . S.decode <$> gen nodeIdSize | ||
642 | | q >= nodeIdSize = pure self | ||
643 | | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1) | ||
644 | where | ||
645 | nodeIdSize = finiteBitSize (undefined :: nid) `div` 8 | ||
646 | build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) | ||
647 | where | ||
648 | hd = BS.take q $ S.encode self | ||
649 | h = xor b (complement m .&. BS.last hd) | ||
650 | t = m .&. BS.head tl | ||
651 | |||
652 | |||
555 | ------------------------------------------------------------------------ | 653 | ------------------------------------------------------------------------ |
556 | 654 | ||
557 | -- | Accepts a depth/index of a bucket and whether or not it is the last one, | 655 | -- | Accepts a depth/index of a bucket and whether or not it is the last one, |
@@ -583,11 +681,69 @@ instance BEncode a => BEncode (NodeAddr a) where | |||
583 | {-# INLINE fromBEncode #-} | 681 | {-# INLINE fromBEncode #-} |
584 | #endif | 682 | #endif |
585 | 683 | ||
586 | fromPeerAddr :: PeerAddr -> NodeAddr IP | 684 | |
587 | fromPeerAddr PeerAddr {..} = NodeAddr | 685 | instance Hashable PortNumber where |
588 | { nodeHost = peerHost | 686 | hashWithSalt s = hashWithSalt s . fromEnum |
589 | , nodePort = peerPort | 687 | {-# INLINE hashWithSalt #-} |
590 | } | 688 | |
689 | instance Pretty PortNumber where | ||
690 | pPrint = PP.int . fromEnum | ||
691 | {-# INLINE pPrint #-} | ||
692 | |||
693 | instance Serialize PortNumber where | ||
694 | get = fromIntegral <$> getWord16be | ||
695 | {-# INLINE get #-} | ||
696 | put = putWord16be . fromIntegral | ||
697 | {-# INLINE put #-} | ||
698 | |||
699 | instance Pretty IPv4 where | ||
700 | pPrint = PP.text . show | ||
701 | {-# INLINE pPrint #-} | ||
702 | |||
703 | instance Pretty IPv6 where | ||
704 | pPrint = PP.text . show | ||
705 | {-# INLINE pPrint #-} | ||
706 | |||
707 | instance Pretty IP where | ||
708 | pPrint = PP.text . show | ||
709 | {-# INLINE pPrint #-} | ||
710 | |||
711 | |||
712 | -- | When 'get'ing an IP it must be 'isolate'd to the appropriate | ||
713 | -- number of bytes since we have no other way of telling which | ||
714 | -- address type we are trying to parse | ||
715 | instance Serialize IP where | ||
716 | put (IPv4 ip) = put ip | ||
717 | put (IPv6 ip) = put ip | ||
718 | |||
719 | get = do | ||
720 | n <- remaining | ||
721 | case n of | ||
722 | 4 -> IPv4 <$> get | ||
723 | 16 -> IPv6 <$> get | ||
724 | _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP") | ||
725 | |||
726 | instance Serialize IPv4 where | ||
727 | put = putWord32host . toHostAddress | ||
728 | get = fromHostAddress <$> getWord32host | ||
729 | |||
730 | instance Serialize IPv6 where | ||
731 | put ip = put $ toHostAddress6 ip | ||
732 | get = fromHostAddress6 <$> get | ||
733 | |||
734 | |||
735 | instance Hashable IPv4 where | ||
736 | hashWithSalt = hashUsing toHostAddress | ||
737 | {-# INLINE hashWithSalt #-} | ||
738 | |||
739 | instance Hashable IPv6 where | ||
740 | hashWithSalt s a = hashWithSalt s (toHostAddress6 a) | ||
741 | |||
742 | instance Hashable IP where | ||
743 | hashWithSalt s (IPv4 h) = hashWithSalt s h | ||
744 | hashWithSalt s (IPv6 h) = hashWithSalt s h | ||
745 | |||
746 | |||
591 | 747 | ||
592 | ------------------------------------------------------------------------ | 748 | ------------------------------------------------------------------------ |
593 | 749 | ||
diff --git a/src/Network/BitTorrent/DHT/Search.hs b/src/Network/BitTorrent/DHT/Search.hs index 12fc29f6..54547211 100644 --- a/src/Network/BitTorrent/DHT/Search.hs +++ b/src/Network/BitTorrent/DHT/Search.hs | |||
@@ -26,7 +26,6 @@ import qualified Data.MinMaxPSQ as MM | |||
26 | import qualified Data.Wrapper.PSQ as PSQ | 26 | import qualified Data.Wrapper.PSQ as PSQ |
27 | ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ, PSQKey) | 27 | ;import Data.Wrapper.PSQ (pattern (:->), Binding, PSQ, PSQKey) |
28 | import Network.Address hiding (NodeId) | 28 | import Network.Address hiding (NodeId) |
29 | import Network.DatagramServer.Types | ||
30 | import Network.DHT.Routing as R | 29 | import Network.DHT.Routing as R |
31 | #ifdef THREAD_DEBUG | 30 | #ifdef THREAD_DEBUG |
32 | import Control.Concurrent.Lifted.Instrument | 31 | import Control.Concurrent.Lifted.Instrument |
diff --git a/src/Network/DatagramServer/Types.hs b/src/Network/DatagramServer/Types.hs deleted file mode 100644 index 68aa9212..00000000 --- a/src/Network/DatagramServer/Types.hs +++ /dev/null | |||
@@ -1,412 +0,0 @@ | |||
1 | {-# LANGUAGE ConstraintKinds #-} | ||
2 | {-# LANGUAGE DeriveDataTypeable #-} | ||
3 | {-# LANGUAGE DeriveFunctor #-} | ||
4 | {-# LANGUAGE DeriveFoldable #-} | ||
5 | {-# LANGUAGE DeriveTraversable #-} | ||
6 | {-# LANGUAGE DefaultSignatures #-} | ||
7 | {-# LANGUAGE FlexibleInstances #-} | ||
8 | {-# LANGUAGE FlexibleContexts #-} | ||
9 | {-# LANGUAGE FunctionalDependencies #-} | ||
10 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
11 | {-# LANGUAGE RankNTypes #-} | ||
12 | {-# LANGUAGE ScopedTypeVariables #-} | ||
13 | {-# LANGUAGE TupleSections #-} | ||
14 | {-# LANGUAGE TypeFamilies #-} | ||
15 | {-# LANGUAGE StandaloneDeriving #-} | ||
16 | module Network.DatagramServer.Types | ||
17 | ( module Network.DatagramServer.Types | ||
18 | , module Network.DatagramServer.Error | ||
19 | ) where | ||
20 | |||
21 | import Control.Applicative | ||
22 | import qualified Text.ParserCombinators.ReadP as RP | ||
23 | import Data.Word | ||
24 | import Data.Monoid | ||
25 | import Data.Hashable | ||
26 | import Data.String | ||
27 | import Data.Bits | ||
28 | import Data.ByteString (ByteString) | ||
29 | import Data.Kind (Constraint) | ||
30 | import Data.Data | ||
31 | import Data.Default | ||
32 | import Data.List.Split | ||
33 | import Data.Ord | ||
34 | import Data.IP | ||
35 | import Network.Socket | ||
36 | import Text.PrettyPrint as PP hiding ((<>)) | ||
37 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) | ||
38 | import Text.Read (readMaybe, readEither) | ||
39 | import Data.Serialize as S | ||
40 | import qualified Data.ByteString.Char8 as Char8 | ||
41 | import qualified Data.ByteString as BS | ||
42 | import Data.ByteString.Base16 as Base16 | ||
43 | import System.Entropy | ||
44 | import Network.DatagramServer.Error | ||
45 | import Data.LargeWord | ||
46 | import Data.Char | ||
47 | |||
48 | |||
49 | class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) | ||
50 | => Address a where | ||
51 | toSockAddr :: a -> SockAddr | ||
52 | fromSockAddr :: SockAddr -> Maybe a | ||
53 | |||
54 | fromAddr :: (Address a, Address b) => a -> Maybe b | ||
55 | fromAddr = fromSockAddr . toSockAddr | ||
56 | |||
57 | -- | Note that port is zeroed. | ||
58 | instance Address IPv4 where | ||
59 | toSockAddr = SockAddrInet 0 . toHostAddress | ||
60 | fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h) | ||
61 | fromSockAddr _ = Nothing | ||
62 | |||
63 | -- | Note that port is zeroed. | ||
64 | instance Address IPv6 where | ||
65 | toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0 | ||
66 | fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h) | ||
67 | fromSockAddr _ = Nothing | ||
68 | |||
69 | -- | Note that port is zeroed. | ||
70 | instance Address IP where | ||
71 | toSockAddr (IPv4 h) = toSockAddr h | ||
72 | toSockAddr (IPv6 h) = toSockAddr h | ||
73 | fromSockAddr sa = | ||
74 | IPv4 <$> fromSockAddr sa | ||
75 | <|> IPv6 <$> fromSockAddr sa | ||
76 | |||
77 | |||
78 | |||
79 | |||
80 | |||
81 | newtype ReflectedIP = ReflectedIP SockAddr | ||
82 | deriving (Eq, Ord, Show) | ||
83 | |||
84 | -- The MessageClass/MessageClassG duality is merely a way to help GHC derive | ||
85 | -- instances without having to cope with the QueryMethod and TransactionID type | ||
86 | -- functions | ||
87 | type MessageClass msg = MessageClassG (QueryMethod msg) (TransactionID msg) | ||
88 | data MessageClassG meth tid = Query meth | ||
89 | | Response (Maybe ReflectedIP) | ||
90 | | Error (KError tid) | ||
91 | deriving (Eq,Ord,Show) -- ,Read, Data: not implemented by SockAddr | ||
92 | |||
93 | |||
94 | class Envelope envelope where | ||
95 | data TransactionID envelope | ||
96 | type QueryMethod envelope | ||
97 | data NodeId envelope | ||
98 | data QueryExtra envelope | ||
99 | data ResponseExtra envelope | ||
100 | data PacketDestination envelope | ||
101 | |||
102 | envelopePayload :: envelope a -> a | ||
103 | envelopeTransaction :: envelope a -> TransactionID envelope | ||
104 | envelopeClass :: envelope a -> MessageClass envelope | ||
105 | |||
106 | -- | > replyAddress qry addr | ||
107 | -- | ||
108 | -- [ qry ] received query message | ||
109 | -- | ||
110 | -- [ addr ] SockAddr of query origin | ||
111 | -- | ||
112 | -- Returns: Destination address for reply. | ||
113 | makeAddress :: Either (NodeId envelope) (envelope a) -> SockAddr -> PacketDestination envelope | ||
114 | |||
115 | -- | > buildReply self addr qry response | ||
116 | -- | ||
117 | -- [ self ] this node's id. | ||
118 | -- | ||
119 | -- [ addr ] SockAddr of query origin. | ||
120 | -- | ||
121 | -- [ qry ] received query message. | ||
122 | -- | ||
123 | -- [ response ] response payload. | ||
124 | -- | ||
125 | -- Returns: response message envelope | ||
126 | buildReply :: NodeId envelope -> SockAddr -> envelope a -> b -> envelope b | ||
127 | |||
128 | -- This is a abstract constructor and a design wart. Since it returns into | ||
129 | -- the IO monad, it allows for outside state to be used in creating | ||
130 | -- envelopes. | ||
131 | buildQuery :: NodeId envelope -> SockAddr -> QueryMethod envelope -> TransactionID envelope -> a -> IO (envelope a) | ||
132 | |||
133 | uniqueTransactionId :: Int -> IO (TransactionID envelope) | ||
134 | |||
135 | fromRoutableNode :: QueryExtra envelope -> Bool | ||
136 | fromRoutableNode _ = True | ||
137 | |||
138 | -- | In Kademlia, the distance metric is XOR and the result is | ||
139 | -- interpreted as an unsigned integer. | ||
140 | newtype NodeDistance nodeid = NodeDistance nodeid | ||
141 | deriving (Eq, Ord) | ||
142 | |||
143 | -- | distance(A,B) = |A xor B| Smaller values are closer. | ||
144 | distance :: Bits nid => nid -> nid -> NodeDistance nid | ||
145 | distance a b = NodeDistance $ xor a b | ||
146 | |||
147 | instance Serialize nodeid => Show (NodeDistance nodeid) where | ||
148 | show (NodeDistance w) = Char8.unpack $ Base16.encode $ S.encode w | ||
149 | |||
150 | instance Serialize nodeid => Pretty (NodeDistance nodeid) where | ||
151 | pPrint n = text $ show n | ||
152 | |||
153 | |||
154 | -- | When 'get'ing an IP it must be 'isolate'd to the appropriate | ||
155 | -- number of bytes since we have no other way of telling which | ||
156 | -- address type we are trying to parse | ||
157 | instance Serialize IP where | ||
158 | put (IPv4 ip) = put ip | ||
159 | put (IPv6 ip) = put ip | ||
160 | |||
161 | get = do | ||
162 | n <- remaining | ||
163 | case n of | ||
164 | 4 -> IPv4 <$> get | ||
165 | 16 -> IPv6 <$> get | ||
166 | _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP") | ||
167 | |||
168 | instance Serialize IPv4 where | ||
169 | put = putWord32host . toHostAddress | ||
170 | get = fromHostAddress <$> getWord32host | ||
171 | |||
172 | instance Serialize IPv6 where | ||
173 | put ip = put $ toHostAddress6 ip | ||
174 | get = fromHostAddress6 <$> get | ||
175 | |||
176 | instance Pretty IPv4 where | ||
177 | pPrint = PP.text . show | ||
178 | {-# INLINE pPrint #-} | ||
179 | |||
180 | instance Pretty IPv6 where | ||
181 | pPrint = PP.text . show | ||
182 | {-# INLINE pPrint #-} | ||
183 | |||
184 | instance Pretty IP where | ||
185 | pPrint = PP.text . show | ||
186 | {-# INLINE pPrint #-} | ||
187 | |||
188 | instance Hashable IPv4 where | ||
189 | hashWithSalt = hashUsing toHostAddress | ||
190 | {-# INLINE hashWithSalt #-} | ||
191 | |||
192 | instance Hashable IPv6 where | ||
193 | hashWithSalt s a = hashWithSalt s (toHostAddress6 a) | ||
194 | |||
195 | instance Hashable IP where | ||
196 | hashWithSalt s (IPv4 h) = hashWithSalt s h | ||
197 | hashWithSalt s (IPv6 h) = hashWithSalt s h | ||
198 | |||
199 | |||
200 | |||
201 | |||
202 | |||
203 | data NodeAddr a = NodeAddr | ||
204 | { nodeHost :: !a | ||
205 | , nodePort :: {-# UNPACK #-} !PortNumber | ||
206 | } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable) | ||
207 | |||
208 | instance Show a => Show (NodeAddr a) where | ||
209 | showsPrec i NodeAddr {..} | ||
210 | = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort | ||
211 | |||
212 | instance Read (NodeAddr IPv4) where | ||
213 | readsPrec i = RP.readP_to_S $ do | ||
214 | ipv4 <- RP.readS_to_P (readsPrec i) | ||
215 | _ <- RP.char ':' | ||
216 | port <- toEnum <$> RP.readS_to_P (readsPrec i) | ||
217 | return $ NodeAddr ipv4 port | ||
218 | |||
219 | -- | @127.0.0.1:6882@ | ||
220 | instance Default (NodeAddr IPv4) where | ||
221 | def = "127.0.0.1:6882" | ||
222 | |||
223 | -- | KRPC compatible encoding. | ||
224 | instance Serialize a => Serialize (NodeAddr a) where | ||
225 | get = NodeAddr <$> get <*> get | ||
226 | {-# INLINE get #-} | ||
227 | put NodeAddr {..} = put nodeHost >> put nodePort | ||
228 | {-# INLINE put #-} | ||
229 | |||
230 | -- | Example: | ||
231 | -- | ||
232 | -- @nodePort \"127.0.0.1:6881\" == 6881@ | ||
233 | -- | ||
234 | instance IsString (NodeAddr IPv4) where | ||
235 | fromString str | ||
236 | | [hostAddrStr, portStr] <- splitWhen (== ':') str | ||
237 | , Just hostAddr <- readMaybe hostAddrStr | ||
238 | , Just portNum <- toEnum <$> readMaybe portStr | ||
239 | = NodeAddr hostAddr portNum | ||
240 | | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str | ||
241 | |||
242 | instance Hashable PortNumber where | ||
243 | hashWithSalt s = hashWithSalt s . fromEnum | ||
244 | {-# INLINE hashWithSalt #-} | ||
245 | |||
246 | instance Pretty PortNumber where | ||
247 | pPrint = PP.int . fromEnum | ||
248 | {-# INLINE pPrint #-} | ||
249 | |||
250 | |||
251 | instance Hashable a => Hashable (NodeAddr a) where | ||
252 | hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort) | ||
253 | {-# INLINE hashWithSalt #-} | ||
254 | |||
255 | instance Pretty ip => Pretty (NodeAddr ip) where | ||
256 | pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort | ||
257 | |||
258 | |||
259 | instance Serialize PortNumber where | ||
260 | get = fromIntegral <$> getWord16be | ||
261 | {-# INLINE get #-} | ||
262 | put = putWord16be . fromIntegral | ||
263 | {-# INLINE put #-} | ||
264 | |||
265 | |||
266 | |||
267 | |||
268 | data NodeInfo dht addr u = NodeInfo | ||
269 | { nodeId :: !(NodeId dht) | ||
270 | , nodeAddr :: !(NodeAddr addr) | ||
271 | , nodeAnnotation :: u | ||
272 | } deriving (Functor, Foldable, Traversable) | ||
273 | |||
274 | deriving instance ( Show (NodeId dht) | ||
275 | , Show addr | ||
276 | , Show u ) => Show (NodeInfo dht addr u) | ||
277 | |||
278 | hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') | ||
279 | |||
280 | instance ( FiniteBits (NodeId dht) | ||
281 | , Read (NodeId dht) | ||
282 | , Read (NodeAddr addr) | ||
283 | , Default u | ||
284 | ) => Read (NodeInfo dht addr u) where | ||
285 | readsPrec i = RP.readP_to_S $ do | ||
286 | RP.skipSpaces | ||
287 | let n = finiteBitSize (undefined :: NodeId dht) `div` 4 | ||
288 | hexhash <- sequence $ replicate n (RP.satisfy hexdigit) | ||
289 | RP.char '@' RP.+++ RP.satisfy isSpace | ||
290 | addrstr <- RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) | ||
291 | RP.+++ RP.munch (not . isSpace) | ||
292 | addr <- either fail return $ readEither addrstr | ||
293 | nid <- either fail return $ readEither hexhash | ||
294 | return $ NodeInfo nid addr def | ||
295 | |||
296 | |||
297 | |||
298 | mapAddress :: (addr -> b) -> NodeInfo dht addr u -> NodeInfo dht b u | ||
299 | mapAddress f ni = ni { nodeAddr = fmap f (nodeAddr ni) } | ||
300 | |||
301 | traverseAddress :: Applicative f => (addr -> f b) -> NodeInfo dht addr u -> f (NodeInfo dht b u) | ||
302 | traverseAddress f ni = fmap (\addr -> ni { nodeAddr = addr }) $ traverse f (nodeAddr ni) | ||
303 | |||
304 | -- Warning: Eq and Ord only look at the nodeId field. | ||
305 | instance Eq (NodeId dht) => Eq (NodeInfo dht a u) where | ||
306 | a == b = (nodeId a == nodeId b) | ||
307 | |||
308 | instance Ord (NodeId dht) => Ord (NodeInfo dht a u) where | ||
309 | compare = comparing nodeId | ||
310 | |||
311 | |||
312 | -- TODO WARN is the 'system' random suitable for this? | ||
313 | -- | Generate random NodeID used for the entire session. | ||
314 | -- Distribution of ID's should be as uniform as possible. | ||
315 | -- | ||
316 | genNodeId :: forall dht. | ||
317 | ( Serialize (NodeId dht) | ||
318 | , FiniteBits (NodeId dht) | ||
319 | ) => IO (NodeId dht) | ||
320 | genNodeId = either error id . S.decode <$> getEntropy nodeIdSize | ||
321 | where | ||
322 | nodeIdSize = finiteBitSize (undefined :: NodeId dht) `div` 8 | ||
323 | |||
324 | -- | Generate a random 'NodeId' within a range suitable for a bucket. To | ||
325 | -- obtain a sample for bucket number /index/ where /is_last/ indicates if this | ||
326 | -- is for the current deepest bucket in our routing table: | ||
327 | -- | ||
328 | -- > sample <- genBucketSample nid (bucketRange index is_last) | ||
329 | genBucketSample :: ( FiniteBits nid | ||
330 | , Serialize nid | ||
331 | ) => nid -> (Int,Word8,Word8) -> IO nid | ||
332 | genBucketSample n qmb = genBucketSample' getEntropy n qmb | ||
333 | |||
334 | -- | Generalizion of 'genBucketSample' that accepts a byte generator | ||
335 | -- function to use instead of the system entropy. | ||
336 | genBucketSample' :: forall m dht nid. | ||
337 | ( Applicative m | ||
338 | , FiniteBits nid | ||
339 | , Serialize nid | ||
340 | ) => | ||
341 | (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid | ||
342 | genBucketSample' gen self (q,m,b) | ||
343 | | q <= 0 = either error id . S.decode <$> gen nodeIdSize | ||
344 | | q >= nodeIdSize = pure self | ||
345 | | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1) | ||
346 | where | ||
347 | nodeIdSize = finiteBitSize (undefined :: nid) `div` 8 | ||
348 | build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) | ||
349 | where | ||
350 | hd = BS.take q $ S.encode self | ||
351 | h = xor b (complement m .&. BS.last hd) | ||
352 | t = m .&. BS.head tl | ||
353 | |||
354 | class (Envelope envelope, Address (PacketDestination envelope)) => WireFormat raw envelope where | ||
355 | type SerializableTo raw :: * -> Constraint | ||
356 | type CipherContext raw envelope | ||
357 | |||
358 | parsePacket :: Proxy envelope -> ByteString -> Either String raw | ||
359 | |||
360 | default parsePacket :: raw ~ ByteString => Proxy envelope -> ByteString -> Either String ByteString | ||
361 | parsePacket _ = Right | ||
362 | |||
363 | buildError :: KError (TransactionID envelope) -> Maybe (envelope raw) | ||
364 | buildError _ = Nothing | ||
365 | |||
366 | decodeHeaders :: CipherContext raw envelope -> raw -> Either String (envelope raw) | ||
367 | decodePayload :: SerializableTo raw a => envelope raw -> Either String (envelope a) | ||
368 | |||
369 | encodeHeaders :: CipherContext raw envelope -> envelope raw -> PacketDestination envelope -> ByteString | ||
370 | encodePayload :: SerializableTo raw a => envelope a -> envelope raw | ||
371 | |||
372 | initializeServerState :: Proxy (envelope raw) -> Maybe (NodeId envelope) -> IO (NodeId envelope, CipherContext raw envelope) | ||
373 | |||
374 | |||
375 | encodeHexDoc :: Serialize x => x -> Doc | ||
376 | encodeHexDoc nid = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid | ||
377 | |||
378 | decodeHex :: Serialize x => String -> [(x,String)] | ||
379 | decodeHex s = either (const []) (pure . (, Char8.unpack ybs)) $ S.decode xbs | ||
380 | where | ||
381 | (xbs,ybs) = Base16.decode $ Char8.pack s | ||
382 | |||
383 | -- FIXME Orphan Serialize intance for large words | ||
384 | instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where | ||
385 | put (LargeKey lo hi) = put hi >> put lo | ||
386 | get = flip LargeKey <$> get <*> get | ||
387 | |||
388 | instance (Pretty ip, Pretty (NodeId dht)) => Pretty (NodeInfo dht ip u) where | ||
389 | pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")" | ||
390 | |||
391 | instance (Pretty ip, Pretty (NodeId dht)) => Pretty [NodeInfo dht ip u] where | ||
392 | pPrint = PP.vcat . PP.punctuate "," . map pPrint | ||
393 | |||
394 | |||
395 | |||
396 | putSockAddr (SockAddrInet port addr) | ||
397 | = put (0x34 :: Word8) >> put port >> put addr | ||
398 | putSockAddr (SockAddrInet6 port flow addr scope) | ||
399 | = put (0x36 :: Word8) >> put port >> put addr >> put scope >> put flow | ||
400 | putSockAddr (SockAddrUnix path) | ||
401 | = put (0x75 :: Word8) >> put path | ||
402 | putSockAddr (SockAddrCan num) | ||
403 | = put (0x63 :: Word8) >> put num | ||
404 | |||
405 | getSockAddr = do | ||
406 | c <- get | ||
407 | case c :: Word8 of | ||
408 | 0x34 -> SockAddrInet <$> get <*> get | ||
409 | 0x36 -> (\p a s f -> SockAddrInet6 p f a s) <$> get <*> get <*> get <*> get | ||
410 | 0x75 -> SockAddrUnix <$> get | ||
411 | 0x63 -> SockAddrCan <$> get | ||
412 | _ -> fail "getSockAddr" | ||