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/Network/Address.hs | |
parent | d197a423e664ca20d7aec9cacb883cbc5af1493f (diff) |
Fixed cabal build.
Diffstat (limited to 'src/Network/Address.hs')
-rw-r--r-- | src/Network/Address.hs | 190 |
1 files changed, 173 insertions, 17 deletions
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 | ||