summaryrefslogtreecommitdiff
path: root/src/Network/BitTorrent
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/BitTorrent')
-rw-r--r--src/Network/BitTorrent/Address.hs48
-rw-r--r--src/Network/BitTorrent/DHT/Query.hs4
-rw-r--r--src/Network/BitTorrent/DHT/Routing.hs4
-rw-r--r--src/Network/BitTorrent/DHT/Session.hs12
-rw-r--r--src/Network/BitTorrent/Exchange/Block.hs12
-rw-r--r--src/Network/BitTorrent/Exchange/Connection.hs32
-rw-r--r--src/Network/BitTorrent/Exchange/Message.hs92
-rw-r--r--src/Network/BitTorrent/Exchange/Session.hs20
-rw-r--r--src/Network/BitTorrent/Internal/Progress.hs4
9 files changed, 117 insertions, 111 deletions
diff --git a/src/Network/BitTorrent/Address.hs b/src/Network/BitTorrent/Address.hs
index eeb04c74..3159fab0 100644
--- a/src/Network/BitTorrent/Address.hs
+++ b/src/Network/BitTorrent/Address.hs
@@ -110,7 +110,7 @@ import Text.Read (readMaybe)
110import Network.HTTP.Types.QueryLike 110import Network.HTTP.Types.QueryLike
111import Network.Socket 111import Network.Socket
112import Text.PrettyPrint as PP hiding ((<>)) 112import Text.PrettyPrint as PP hiding ((<>))
113import Text.PrettyPrint.Class 113import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
114import System.Locale (defaultTimeLocale) 114import System.Locale (defaultTimeLocale)
115import System.Entropy 115import System.Entropy
116 116
@@ -121,7 +121,7 @@ import System.Entropy
121-----------------------------------------------------------------------} 121-----------------------------------------------------------------------}
122 122
123instance Pretty UTCTime where 123instance Pretty UTCTime where
124 pretty = PP.text . show 124 pPrint = PP.text . show
125 125
126class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a) 126class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
127 => Address a where 127 => Address a where
@@ -216,7 +216,7 @@ instance IsString PeerId where
216 bs = fromString str 216 bs = fromString str
217 217
218instance Pretty PeerId where 218instance Pretty PeerId where
219 pretty = text . BC.unpack . getPeerId 219 pPrint = text . BC.unpack . getPeerId
220 220
221instance Convertible BS.ByteString PeerId where 221instance Convertible BS.ByteString PeerId where
222 safeConvert bs 222 safeConvert bs
@@ -373,8 +373,8 @@ instance Hashable PortNumber where
373 {-# INLINE hashWithSalt #-} 373 {-# INLINE hashWithSalt #-}
374 374
375instance Pretty PortNumber where 375instance Pretty PortNumber where
376 pretty = PP.int . fromEnum 376 pPrint = PP.int . fromEnum
377 {-# INLINE pretty #-} 377 {-# INLINE pPrint #-}
378 378
379{----------------------------------------------------------------------- 379{-----------------------------------------------------------------------
380-- IP addr 380-- IP addr
@@ -451,16 +451,16 @@ instance Serialize IPv6 where
451 get = fromHostAddress6 <$> get 451 get = fromHostAddress6 <$> get
452 452
453instance Pretty IPv4 where 453instance Pretty IPv4 where
454 pretty = PP.text . show 454 pPrint = PP.text . show
455 {-# INLINE pretty #-} 455 {-# INLINE pPrint #-}
456 456
457instance Pretty IPv6 where 457instance Pretty IPv6 where
458 pretty = PP.text . show 458 pPrint = PP.text . show
459 {-# INLINE pretty #-} 459 {-# INLINE pPrint #-}
460 460
461instance Pretty IP where 461instance Pretty IP where
462 pretty = PP.text . show 462 pPrint = PP.text . show
463 {-# INLINE pretty #-} 463 {-# INLINE pPrint #-}
464 464
465instance Hashable IPv4 where 465instance Hashable IPv4 where
466 hashWithSalt = hashUsing toHostAddress 466 hashWithSalt = hashUsing toHostAddress
@@ -569,11 +569,11 @@ instance IsString (PeerAddr IP) where
569-- | fingerprint + "at" + dotted.host.inet.addr:port 569-- | fingerprint + "at" + dotted.host.inet.addr:port
570-- TODO: instances for IPv6, HostName 570-- TODO: instances for IPv6, HostName
571instance Pretty a => Pretty (PeerAddr a) where 571instance Pretty a => Pretty (PeerAddr a) where
572 pretty PeerAddr {..} 572 pPrint PeerAddr {..}
573 | Just pid <- peerId = pretty (fingerprint pid) <+> "at" <+> paddr 573 | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr
574 | otherwise = paddr 574 | otherwise = paddr
575 where 575 where
576 paddr = pretty peerHost <> ":" <> text (show peerPort) 576 paddr = pPrint peerHost <> ":" <> text (show peerPort)
577 577
578instance Hashable a => Hashable (PeerAddr a) where 578instance Hashable a => Hashable (PeerAddr a) where
579 hashWithSalt s PeerAddr {..} = 579 hashWithSalt s PeerAddr {..} =
@@ -649,7 +649,7 @@ instance IsString NodeId where
649 649
650-- | base16 encoded. 650-- | base16 encoded.
651instance Pretty NodeId where 651instance Pretty NodeId where
652 pretty (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid 652 pPrint (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid
653 653
654-- | Test if the nth bit is set. 654-- | Test if the nth bit is set.
655testIdBit :: NodeId -> Word -> Bool 655testIdBit :: NodeId -> Word -> Bool
@@ -675,7 +675,7 @@ newtype NodeDistance = NodeDistance BS.ByteString
675 deriving (Eq, Ord) 675 deriving (Eq, Ord)
676 676
677instance Pretty NodeDistance where 677instance Pretty NodeDistance where
678 pretty (NodeDistance bs) = foldMap bitseq $ BS.unpack bs 678 pPrint (NodeDistance bs) = foldMap bitseq $ BS.unpack bs
679 where 679 where
680 listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1]) 680 listBits w = L.map (testBit w) (L.reverse [0..bitSize w - 1])
681 bitseq = foldMap (int . fromEnum) . listBits 681 bitseq = foldMap (int . fromEnum) . listBits
@@ -721,7 +721,7 @@ instance Hashable a => Hashable (NodeAddr a) where
721 {-# INLINE hashWithSalt #-} 721 {-# INLINE hashWithSalt #-}
722 722
723instance Pretty ip => Pretty (NodeAddr ip) where 723instance Pretty ip => Pretty (NodeAddr ip) where
724 pretty NodeAddr {..} = pretty nodeHost <> ":" <> pretty nodePort 724 pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
725 725
726-- | Example: 726-- | Example:
727-- 727--
@@ -755,10 +755,10 @@ instance Serialize a => Serialize (NodeInfo a) where
755 put NodeInfo {..} = put nodeId >> put nodeAddr 755 put NodeInfo {..} = put nodeId >> put nodeAddr
756 756
757instance Pretty ip => Pretty (NodeInfo ip) where 757instance Pretty ip => Pretty (NodeInfo ip) where
758 pretty NodeInfo {..} = pretty nodeId <> "@(" <> pretty nodeAddr <> ")" 758 pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
759 759
760instance Pretty ip => Pretty [NodeInfo ip] where 760instance Pretty ip => Pretty [NodeInfo ip] where
761 pretty = PP.vcat . PP.punctuate "," . L.map pretty 761 pPrint = PP.vcat . PP.punctuate "," . L.map pPrint
762 762
763-- | Order by closeness: nearest nodes first. 763-- | Order by closeness: nearest nodes first.
764rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip] 764rank :: Eq ip => NodeId -> [NodeInfo ip] -> [NodeInfo ip]
@@ -952,9 +952,9 @@ instance IsString Software where
952 alist = L.map mk [minBound..maxBound] 952 alist = L.map mk [minBound..maxBound]
953 mk x = (L.tail $ show x, x) 953 mk x = (L.tail $ show x, x)
954 954
955-- | Example: @pretty 'IBitLet' == \"IBitLet\"@ 955-- | Example: @pPrint 'IBitLet' == \"IBitLet\"@
956instance Pretty Software where 956instance Pretty Software where
957 pretty = text . L.tail . show 957 pPrint = text . L.tail . show
958 958
959-- | Just the '0' version. 959-- | Just the '0' version.
960instance Default Version where 960instance Default Version where
@@ -972,7 +972,7 @@ instance IsString Version where
972 chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==) 972 chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==)
973 973
974instance Pretty Version where 974instance Pretty Version where
975 pretty = text . showVersion 975 pPrint = text . showVersion
976 976
977-- | The all sensible infomation that can be obtained from a peer 977-- | The all sensible infomation that can be obtained from a peer
978-- identifier or torrent /createdBy/ field. 978-- identifier or torrent /createdBy/ field.
@@ -993,7 +993,7 @@ instance IsString Fingerprint where
993 (impl, _ver) = L.span ((/=) '-') str 993 (impl, _ver) = L.span ((/=) '-') str
994 994
995instance Pretty Fingerprint where 995instance Pretty Fingerprint where
996 pretty (Fingerprint s v) = pretty s <+> "version" <+> pretty v 996 pPrint (Fingerprint s v) = pPrint s <+> "version" <+> pPrint v
997 997
998-- | Fingerprint of this (the bittorrent library) package. Normally, 998-- | Fingerprint of this (the bittorrent library) package. Normally,
999-- applications should introduce its own fingerprints, otherwise they 999-- applications should introduce its own fingerprints, otherwise they
@@ -1005,7 +1005,7 @@ libFingerprint = Fingerprint IlibHSbittorrent version
1005-- | HTTP user agent of this (the bittorrent library) package. Can be 1005-- | HTTP user agent of this (the bittorrent library) package. Can be
1006-- used in HTTP tracker requests. 1006-- used in HTTP tracker requests.
1007libUserAgent :: String 1007libUserAgent :: String
1008libUserAgent = render (pretty IlibHSbittorrent <> "/" <> pretty version) 1008libUserAgent = render (pPrint IlibHSbittorrent <> "/" <> pPrint version)
1009 1009
1010{----------------------------------------------------------------------- 1010{-----------------------------------------------------------------------
1011-- For torrent file 1011-- For torrent file
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs
index f7657490..ac53bd91 100644
--- a/src/Network/BitTorrent/DHT/Query.hs
+++ b/src/Network/BitTorrent/DHT/Query.hs
@@ -53,7 +53,7 @@ import Data.Monoid
53import Data.Text as T 53import Data.Text as T
54import Network 54import Network
55import Text.PrettyPrint as PP hiding ((<>), ($$)) 55import Text.PrettyPrint as PP hiding ((<>), ($$))
56import Text.PrettyPrint.Class 56import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
57 57
58import Network.KRPC hiding (Options, def) 58import Network.KRPC hiding (Options, def)
59import Data.Torrent 59import Data.Torrent
@@ -132,7 +132,7 @@ getPeersQ topic NodeInfo {..} = do
132 GotPeers {..} <- GetPeers topic <@> nodeAddr 132 GotPeers {..} <- GetPeers topic <@> nodeAddr
133 let dist = distance (toNodeId topic) nodeId 133 let dist = distance (toNodeId topic) nodeId
134 $(logInfoS) "getPeersQ" $ T.pack 134 $(logInfoS) "getPeersQ" $ T.pack
135 $ "distance: " <> render (pretty dist) <> " , result: " 135 $ "distance: " <> render (pPrint dist) <> " , result: "
136 <> case peers of { Left _ -> "NODES"; Right _ -> "PEERS" } 136 <> case peers of { Left _ -> "NODES"; Right _ -> "PEERS" }
137 return peers 137 return peers
138 138
diff --git a/src/Network/BitTorrent/DHT/Routing.hs b/src/Network/BitTorrent/DHT/Routing.hs
index ee295125..cb3cf273 100644
--- a/src/Network/BitTorrent/DHT/Routing.hs
+++ b/src/Network/BitTorrent/DHT/Routing.hs
@@ -71,7 +71,7 @@ import Data.Time.Clock.POSIX
71import Data.Word 71import Data.Word
72import GHC.Generics 72import GHC.Generics
73import Text.PrettyPrint as PP hiding ((<>)) 73import Text.PrettyPrint as PP hiding ((<>))
74import Text.PrettyPrint.Class 74import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
75 75
76import Data.Torrent 76import Data.Torrent
77import Network.BitTorrent.Address 77import Network.BitTorrent.Address
@@ -325,7 +325,7 @@ instance (Eq ip, Serialize ip) => Serialize (Table ip)
325 325
326-- | Shape of the table. 326-- | Shape of the table.
327instance Pretty (Table ip) where 327instance Pretty (Table ip) where
328 pretty t 328 pPrint t
329 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss 329 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss
330 | otherwise = brackets $ 330 | otherwise = brackets $
331 PP.int (L.sum ss) <> " nodes, " <> 331 PP.int (L.sum ss) <> " nodes, " <>
diff --git a/src/Network/BitTorrent/DHT/Session.hs b/src/Network/BitTorrent/DHT/Session.hs
index 208f8ec8..0c806db2 100644
--- a/src/Network/BitTorrent/DHT/Session.hs
+++ b/src/Network/BitTorrent/DHT/Session.hs
@@ -90,7 +90,7 @@ import Network (PortNumber)
90import System.Log.FastLogger 90import System.Log.FastLogger
91import System.Random (randomIO) 91import System.Random (randomIO)
92import Text.PrettyPrint as PP hiding ((<>), ($$)) 92import Text.PrettyPrint as PP hiding ((<>), ($$))
93import Text.PrettyPrint.Class 93import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
94 94
95import Data.Torrent as Torrent 95import Data.Torrent as Torrent
96import Network.KRPC hiding (Options, def) 96import Network.KRPC hiding (Options, def)
@@ -340,7 +340,7 @@ routing = runRouting probeNode refreshNodes getTimestamp
340 340
341probeNode :: Address ip => NodeAddr ip -> DHT ip Bool 341probeNode :: Address ip => NodeAddr ip -> DHT ip Bool
342probeNode addr = do 342probeNode addr = do
343 $(logDebugS) "routing.questionable_node" (T.pack (render (pretty addr))) 343 $(logDebugS) "routing.questionable_node" (T.pack (render (pPrint addr)))
344 result <- try $ Ping <@> addr 344 result <- try $ Ping <@> addr
345 let _ = result :: Either SomeException Ping 345 let _ = result :: Either SomeException Ping
346 return $ either (const False) (const True) result 346 return $ either (const False) (const True) result
@@ -351,7 +351,7 @@ probeNode addr = do
351-- FIXME do not use getClosest sinse we should /refresh/ them 351-- FIXME do not use getClosest sinse we should /refresh/ them
352refreshNodes :: Address ip => NodeId -> DHT ip [NodeInfo ip] 352refreshNodes :: Address ip => NodeId -> DHT ip [NodeInfo ip]
353refreshNodes nid = do 353refreshNodes nid = do
354 $(logDebugS) "routing.refresh_bucket" (T.pack (render (pretty nid))) 354 $(logDebugS) "routing.refresh_bucket" (T.pack (render (pPrint nid)))
355 nodes <- getClosest nid 355 nodes <- getClosest nid
356 nss <- forM (nodeAddr <$> nodes) $ \ addr -> do 356 nss <- forM (nodeAddr <$> nodes) $ \ addr -> do
357 NodeFound ns <- FindNode nid <@> addr 357 NodeFound ns <- FindNode nid <@> addr
@@ -361,7 +361,7 @@ refreshNodes nid = do
361getTimestamp :: DHT ip Timestamp 361getTimestamp :: DHT ip Timestamp
362getTimestamp = do 362getTimestamp = do
363 utcTime <- liftIO $ getCurrentTime 363 utcTime <- liftIO $ getCurrentTime
364 $(logDebugS) "routing.make_timestamp" (T.pack (render (pretty utcTime))) 364 $(logDebugS) "routing.make_timestamp" (T.pack (render (pPrint utcTime)))
365 return $ utcTimeToPOSIXSeconds utcTime 365 return $ utcTimeToPOSIXSeconds utcTime
366 366
367{----------------------------------------------------------------------- 367{-----------------------------------------------------------------------
@@ -419,11 +419,11 @@ insertNode info = fork $ do
419 case result of 419 case result of
420 Nothing -> do 420 Nothing -> do
421 $(logDebugS) "insertNode" $ "Routing table is full: " 421 $(logDebugS) "insertNode" $ "Routing table is full: "
422 <> T.pack (show (pretty t)) 422 <> T.pack (show (pPrint t))
423 return t 423 return t
424 Just t' -> do 424 Just t' -> do
425 let logMsg = "Routing table updated: " 425 let logMsg = "Routing table updated: "
426 <> pretty t <> " -> " <> pretty t' 426 <> pPrint t <> " -> " <> pPrint t'
427 $(logDebugS) "insertNode" (T.pack (render logMsg)) 427 $(logDebugS) "insertNode" (T.pack (render logMsg))
428 return t' 428 return t'
429 429
diff --git a/src/Network/BitTorrent/Exchange/Block.hs b/src/Network/BitTorrent/Exchange/Block.hs
index ccc7a0a9..bc9a3d24 100644
--- a/src/Network/BitTorrent/Exchange/Block.hs
+++ b/src/Network/BitTorrent/Exchange/Block.hs
@@ -67,7 +67,7 @@ import Data.Serialize as S
67import Data.Typeable 67import Data.Typeable
68import Numeric 68import Numeric
69import Text.PrettyPrint as PP hiding ((<>)) 69import Text.PrettyPrint as PP hiding ((<>))
70import Text.PrettyPrint.Class 70import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
71 71
72import Data.Torrent 72import Data.Torrent
73 73
@@ -138,7 +138,7 @@ instance Serialize BlockIx where
138 {-# INLINE put #-} 138 {-# INLINE put #-}
139 139
140instance Pretty BlockIx where 140instance Pretty BlockIx where
141 pretty BlockIx {..} = 141 pPrint BlockIx {..} =
142 ("piece = " <> int ixPiece <> ",") <+> 142 ("piece = " <> int ixPiece <> ",") <+>
143 ("offset = " <> int ixOffset <> ",") <+> 143 ("offset = " <> int ixOffset <> ",") <+>
144 ("length = " <> int ixLength) 144 ("length = " <> int ixLength)
@@ -169,8 +169,8 @@ data Block payload = Block {
169 169
170-- | Payload is ommitted. 170-- | Payload is ommitted.
171instance Pretty (Block BL.ByteString) where 171instance Pretty (Block BL.ByteString) where
172 pretty = pretty . blockIx 172 pPrint = pPrint . blockIx
173 {-# INLINE pretty #-} 173 {-# INLINE pPrint #-}
174 174
175-- | Get size of block /payload/ in bytes. 175-- | Get size of block /payload/ in bytes.
176blockSize :: Block BL.ByteString -> BlockSize 176blockSize :: Block BL.ByteString -> BlockSize
@@ -241,8 +241,8 @@ valid = check Nothing
241 check (Just False) xs 241 check (Just False) xs
242 242
243instance Pretty Bucket where 243instance Pretty Bucket where
244 pretty Nil = nilInvFailed 244 pPrint Nil = nilInvFailed
245 pretty bkt = go bkt 245 pPrint bkt = go bkt
246 where 246 where
247 go Nil = PP.empty 247 go Nil = PP.empty
248 go (Span sz xs) = "Span" <+> PP.int sz <+> go xs 248 go (Span sz xs) = "Span" <+> PP.int sz <+> go xs
diff --git a/src/Network/BitTorrent/Exchange/Connection.hs b/src/Network/BitTorrent/Exchange/Connection.hs
index 2d5f39bf..d65d322e 100644
--- a/src/Network/BitTorrent/Exchange/Connection.hs
+++ b/src/Network/BitTorrent/Exchange/Connection.hs
@@ -131,7 +131,7 @@ import Network
131import Network.Socket hiding (Connected) 131import Network.Socket hiding (Connected)
132import Network.Socket.ByteString as BS 132import Network.Socket.ByteString as BS
133import Text.PrettyPrint as PP hiding ((<>)) 133import Text.PrettyPrint as PP hiding ((<>))
134import Text.PrettyPrint.Class 134import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
135import Text.Show.Functions () 135import Text.Show.Functions ()
136import System.Log.FastLogger (ToLogStr(..)) 136import System.Log.FastLogger (ToLogStr(..))
137import System.Timeout 137import System.Timeout
@@ -161,7 +161,7 @@ instance Default ChannelSide where
161 def = ThisPeer 161 def = ThisPeer
162 162
163instance Pretty ChannelSide where 163instance Pretty ChannelSide where
164 pretty = PP.text . show 164 pPrint = PP.text . show
165 165
166-- | A protocol errors occur when a peer violates protocol 166-- | A protocol errors occur when a peer violates protocol
167-- specification. 167-- specification.
@@ -213,7 +213,7 @@ data ProtocolError
213 deriving Show 213 deriving Show
214 214
215instance Pretty ProtocolError where 215instance Pretty ProtocolError where
216 pretty = PP.text . show 216 pPrint = PP.text . show
217 217
218errorPenalty :: ProtocolError -> Int 218errorPenalty :: ProtocolError -> Int
219errorPenalty (InvalidProtocol _) = 1 219errorPenalty (InvalidProtocol _) = 1
@@ -256,7 +256,7 @@ data WireFailure
256instance Exception WireFailure 256instance Exception WireFailure
257 257
258instance Pretty WireFailure where 258instance Pretty WireFailure where
259 pretty = PP.text . show 259 pPrint = PP.text . show
260 260
261-- TODO 261-- TODO
262-- data Penalty = Ban | Penalty Int 262-- data Penalty = Ban | Penalty Int
@@ -288,9 +288,9 @@ data FlowStats = FlowStats
288 } deriving Show 288 } deriving Show
289 289
290instance Pretty FlowStats where 290instance Pretty FlowStats where
291 pretty FlowStats {..} = 291 pPrint FlowStats {..} =
292 PP.int messageCount <+> "messages" $+$ 292 PP.int messageCount <+> "messages" $+$
293 pretty messageBytes 293 pPrint messageBytes
294 294
295-- | Zeroed stats. 295-- | Zeroed stats.
296instance Default FlowStats where 296instance Default FlowStats where
@@ -328,10 +328,10 @@ data ConnectionStats = ConnectionStats
328 } deriving Show 328 } deriving Show
329 329
330instance Pretty ConnectionStats where 330instance Pretty ConnectionStats where
331 pretty ConnectionStats {..} = vcat 331 pPrint ConnectionStats {..} = vcat
332 [ "Recv:" <+> pretty incomingFlow 332 [ "Recv:" <+> pPrint incomingFlow
333 , "Sent:" <+> pretty outcomingFlow 333 , "Sent:" <+> pPrint outcomingFlow
334 , "Both:" <+> pretty (incomingFlow <> outcomingFlow) 334 , "Both:" <+> pPrint (incomingFlow <> outcomingFlow)
335 ] 335 ]
336 336
337-- | Zeroed stats. 337-- | Zeroed stats.
@@ -493,8 +493,8 @@ data PeerStatus = PeerStatus
493$(makeLenses ''PeerStatus) 493$(makeLenses ''PeerStatus)
494 494
495instance Pretty PeerStatus where 495instance Pretty PeerStatus where
496 pretty PeerStatus {..} = 496 pPrint PeerStatus {..} =
497 pretty (Choking _choking) <+> "and" <+> pretty (Interested _interested) 497 pPrint (Choking _choking) <+> "and" <+> pPrint (Interested _interested)
498 498
499-- | Connections start out choked and not interested. 499-- | Connections start out choked and not interested.
500instance Default PeerStatus where 500instance Default PeerStatus where
@@ -535,9 +535,9 @@ data ConnectionStatus = ConnectionStatus
535$(makeLenses ''ConnectionStatus) 535$(makeLenses ''ConnectionStatus)
536 536
537instance Pretty ConnectionStatus where 537instance Pretty ConnectionStatus where
538 pretty ConnectionStatus {..} = 538 pPrint ConnectionStatus {..} =
539 "this " PP.<+> pretty _clientStatus PP.$$ 539 "this " PP.<+> pPrint _clientStatus PP.$$
540 "remote" PP.<+> pretty _remoteStatus 540 "remote" PP.<+> pPrint _remoteStatus
541 541
542-- | Connections start out choked and not interested. 542-- | Connections start out choked and not interested.
543instance Default ConnectionStatus where 543instance Default ConnectionStatus where
@@ -646,7 +646,7 @@ data Connection s = Connection
646 } 646 }
647 647
648instance Pretty (Connection s) where 648instance Pretty (Connection s) where
649 pretty Connection {..} = "Connection" 649 pPrint Connection {..} = "Connection"
650 650
651instance ToLogStr (Connection s) where 651instance ToLogStr (Connection s) where
652 toLogStr Connection {..} = mconcat 652 toLogStr Connection {..} = mconcat
diff --git a/src/Network/BitTorrent/Exchange/Message.hs b/src/Network/BitTorrent/Exchange/Message.hs
index f8b76186..74232b47 100644
--- a/src/Network/BitTorrent/Exchange/Message.hs
+++ b/src/Network/BitTorrent/Exchange/Message.hs
@@ -115,7 +115,7 @@ import Data.IP
115import Network 115import Network
116import Network.Socket hiding (KeepAlive) 116import Network.Socket hiding (KeepAlive)
117import Text.PrettyPrint as PP hiding ((<>)) 117import Text.PrettyPrint as PP hiding ((<>))
118import Text.PrettyPrint.Class 118import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
119 119
120import Data.Torrent hiding (Piece (..)) 120import Data.Torrent hiding (Piece (..))
121import qualified Data.Torrent as P (Piece (..)) 121import qualified Data.Torrent as P (Piece (..))
@@ -141,7 +141,7 @@ class Capabilities caps where
141 allowed :: Ext caps -> caps -> Bool 141 allowed :: Ext caps -> caps -> Bool
142 142
143ppCaps :: Capabilities caps => Pretty (Ext caps) => caps -> Doc 143ppCaps :: Capabilities caps => Pretty (Ext caps) => caps -> Doc
144ppCaps = hcat . punctuate ", " . L.map pretty . fromCaps 144ppCaps = hcat . punctuate ", " . L.map pPrint . fromCaps
145 145
146{----------------------------------------------------------------------- 146{-----------------------------------------------------------------------
147-- Extensions 147-- Extensions
@@ -159,9 +159,9 @@ data Extension
159 159
160-- | Full extension names, suitable for logging. 160-- | Full extension names, suitable for logging.
161instance Pretty Extension where 161instance Pretty Extension where
162 pretty ExtDHT = "Distributed Hash Table Protocol" 162 pPrint ExtDHT = "Distributed Hash Table Protocol"
163 pretty ExtFast = "Fast Extension" 163 pPrint ExtFast = "Fast Extension"
164 pretty ExtExtended = "Extension Protocol" 164 pPrint ExtExtended = "Extension Protocol"
165 165
166-- | Extension bitmask as specified by BEP 4. 166-- | Extension bitmask as specified by BEP 4.
167extMask :: Extension -> Word64 167extMask :: Extension -> Word64
@@ -180,8 +180,8 @@ newtype Caps = Caps Word64
180 180
181-- | Render set of extensions as comma separated list. 181-- | Render set of extensions as comma separated list.
182instance Pretty Caps where 182instance Pretty Caps where
183 pretty = ppCaps 183 pPrint = ppCaps
184 {-# INLINE pretty #-} 184 {-# INLINE pPrint #-}
185 185
186-- | The empty set. 186-- | The empty set.
187instance Default Caps where 187instance Default Caps where
@@ -235,7 +235,7 @@ instance Show ProtocolName where
235 show (ProtocolName bs) = show bs 235 show (ProtocolName bs) = show bs
236 236
237instance Pretty ProtocolName where 237instance Pretty ProtocolName where
238 pretty (ProtocolName bs) = PP.text $ BC.unpack bs 238 pPrint (ProtocolName bs) = PP.text $ BC.unpack bs
239 239
240instance IsString ProtocolName where 240instance IsString ProtocolName where
241 fromString str 241 fromString str
@@ -287,10 +287,10 @@ instance Serialize Handshake where
287 287
288-- | Show handshake protocol string, caps and fingerprint. 288-- | Show handshake protocol string, caps and fingerprint.
289instance Pretty Handshake where 289instance Pretty Handshake where
290 pretty Handshake {..} 290 pPrint Handshake {..}
291 = pretty hsProtocol $$ 291 = pPrint hsProtocol $$
292 pretty hsReserved $$ 292 pPrint hsReserved $$
293 pretty (fingerprint hsPeerId) 293 pPrint (fingerprint hsPeerId)
294 294
295-- | Get handshake message size in bytes from the length of protocol 295-- | Get handshake message size in bytes from the length of protocol
296-- string. 296-- string.
@@ -334,7 +334,7 @@ data ByteStats = ByteStats
334 } deriving Show 334 } deriving Show
335 335
336instance Pretty ByteStats where 336instance Pretty ByteStats where
337 pretty s @ ByteStats {..} = fsep 337 pPrint s @ ByteStats {..} = fsep
338 [ PP.int overhead, "overhead" 338 [ PP.int overhead, "overhead"
339 , PP.int control, "control" 339 , PP.int control, "control"
340 , PP.int payload, "payload" 340 , PP.int payload, "payload"
@@ -408,10 +408,10 @@ data StatusUpdate
408 deriving (Show, Eq, Ord, Typeable) 408 deriving (Show, Eq, Ord, Typeable)
409 409
410instance Pretty StatusUpdate where 410instance Pretty StatusUpdate where
411 pretty (Choking False) = "not choking" 411 pPrint (Choking False) = "not choking"
412 pretty (Choking True ) = "choking" 412 pPrint (Choking True ) = "choking"
413 pretty (Interested False) = "not interested" 413 pPrint (Interested False) = "not interested"
414 pretty (Interested True ) = "interested" 414 pPrint (Interested True ) = "interested"
415 415
416instance PeerMessage StatusUpdate where 416instance PeerMessage StatusUpdate where
417 envelop _ = Status 417 envelop _ = Status
@@ -439,8 +439,8 @@ data Available =
439 deriving (Show, Eq) 439 deriving (Show, Eq)
440 440
441instance Pretty Available where 441instance Pretty Available where
442 pretty (Have ix ) = "Have" <+> int ix 442 pPrint (Have ix ) = "Have" <+> int ix
443 pretty (Bitfield _ ) = "Bitfield" 443 pPrint (Bitfield _ ) = "Bitfield"
444 444
445instance PeerMessage Available where 445instance PeerMessage Available where
446 envelop _ = Available 446 envelop _ = Available
@@ -472,9 +472,9 @@ data Transfer
472 deriving (Show, Eq) 472 deriving (Show, Eq)
473 473
474instance Pretty Transfer where 474instance Pretty Transfer where
475 pretty (Request ix ) = "Request" <+> pretty ix 475 pPrint (Request ix ) = "Request" <+> pPrint ix
476 pretty (Piece blk) = "Piece" <+> pretty blk 476 pPrint (Piece blk) = "Piece" <+> pPrint blk
477 pretty (Cancel i ) = "Cancel" <+> pretty i 477 pPrint (Cancel i ) = "Cancel" <+> pPrint i
478 478
479instance PeerMessage Transfer where 479instance PeerMessage Transfer where
480 envelop _ = Transfer 480 envelop _ = Transfer
@@ -519,11 +519,11 @@ data FastMessage =
519 deriving (Show, Eq) 519 deriving (Show, Eq)
520 520
521instance Pretty FastMessage where 521instance Pretty FastMessage where
522 pretty (HaveAll ) = "Have all" 522 pPrint (HaveAll ) = "Have all"
523 pretty (HaveNone ) = "Have none" 523 pPrint (HaveNone ) = "Have none"
524 pretty (SuggestPiece pix) = "Suggest" <+> int pix 524 pPrint (SuggestPiece pix) = "Suggest" <+> int pix
525 pretty (RejectRequest bix) = "Reject" <+> pretty bix 525 pPrint (RejectRequest bix) = "Reject" <+> pPrint bix
526 pretty (AllowedFast pix) = "Allowed fast" <+> int pix 526 pPrint (AllowedFast pix) = "Allowed fast" <+> int pix
527 527
528instance PeerMessage FastMessage where 528instance PeerMessage FastMessage where
529 envelop _ = Fast 529 envelop _ = Fast
@@ -556,7 +556,7 @@ instance IsString ExtendedExtension where
556 msg = "fromString: could not parse ExtendedExtension" 556 msg = "fromString: could not parse ExtendedExtension"
557 557
558instance Pretty ExtendedExtension where 558instance Pretty ExtendedExtension where
559 pretty ExtMetadata = "Extension for Peers to Send Metadata Files" 559 pPrint ExtMetadata = "Extension for Peers to Send Metadata Files"
560 560
561fromKey :: BKey -> Maybe ExtendedExtension 561fromKey :: BKey -> Maybe ExtendedExtension
562fromKey "ut_metadata" = Just ExtMetadata 562fromKey "ut_metadata" = Just ExtMetadata
@@ -582,8 +582,8 @@ newtype ExtendedCaps = ExtendedCaps { extendedCaps :: ExtendedMap }
582 deriving (Show, Eq) 582 deriving (Show, Eq)
583 583
584instance Pretty ExtendedCaps where 584instance Pretty ExtendedCaps where
585 pretty = ppCaps 585 pPrint = ppCaps
586 {-# INLINE pretty #-} 586 {-# INLINE pPrint #-}
587 587
588-- | The empty set. 588-- | The empty set.
589instance Default ExtendedCaps where 589instance Default ExtendedCaps where
@@ -738,7 +738,7 @@ getYourIp f =
738 _ -> fail "" 738 _ -> fail ""
739 739
740instance Pretty ExtendedHandshake where 740instance Pretty ExtendedHandshake where
741 pretty = PP.text . show 741 pPrint = PP.text . show
742 742
743-- | NOTE: Approximated 'stats'. 743-- | NOTE: Approximated 'stats'.
744instance PeerMessage ExtendedHandshake where 744instance PeerMessage ExtendedHandshake where
@@ -760,7 +760,7 @@ nullExtendedHandshake caps = ExtendedHandshake
760 , ehsMetadataSize = Nothing 760 , ehsMetadataSize = Nothing
761 , ehsPort = Nothing 761 , ehsPort = Nothing
762 , ehsQueueLength = Just defaultQueueLength 762 , ehsQueueLength = Just defaultQueueLength
763 , ehsVersion = Just $ T.pack $ render $ pretty libFingerprint 763 , ehsVersion = Just $ T.pack $ render $ pPrint libFingerprint
764 , ehsYourIp = Nothing 764 , ehsYourIp = Nothing
765 } 765 }
766 766
@@ -843,10 +843,10 @@ instance BEncode ExtendedMetadata where
843 843
844-- | Piece data bytes are omitted. 844-- | Piece data bytes are omitted.
845instance Pretty ExtendedMetadata where 845instance Pretty ExtendedMetadata where
846 pretty (MetadataRequest pix ) = "Request" <+> PP.int pix 846 pPrint (MetadataRequest pix ) = "Request" <+> PP.int pix
847 pretty (MetadataData p t) = "Data" <+> pretty p <+> PP.int t 847 pPrint (MetadataData p t) = "Data" <+> pPrint p <+> PP.int t
848 pretty (MetadataReject pix ) = "Reject" <+> PP.int pix 848 pPrint (MetadataReject pix ) = "Reject" <+> PP.int pix
849 pretty (MetadataUnknown bval ) = "Unknown" <+> ppBEncode bval 849 pPrint (MetadataUnknown bval ) = "Unknown" <+> ppBEncode bval
850 850
851-- | NOTE: Approximated 'stats'. 851-- | NOTE: Approximated 'stats'.
852instance PeerMessage ExtendedMetadata where 852instance PeerMessage ExtendedMetadata where
@@ -957,9 +957,9 @@ data ExtendedMessage
957 deriving (Show, Eq, Typeable) 957 deriving (Show, Eq, Typeable)
958 958
959instance Pretty ExtendedMessage where 959instance Pretty ExtendedMessage where
960 pretty (EHandshake ehs) = pretty ehs 960 pPrint (EHandshake ehs) = pPrint ehs
961 pretty (EMetadata _ msg) = "Metadata" <+> pretty msg 961 pPrint (EMetadata _ msg) = "Metadata" <+> pPrint msg
962 pretty (EUnknown mid _ ) = "Unknown" <+> PP.text (show mid) 962 pPrint (EUnknown mid _ ) = "Unknown" <+> PP.text (show mid)
963 963
964instance PeerMessage ExtendedMessage where 964instance PeerMessage ExtendedMessage where
965 envelop _ = Extended 965 envelop _ = Extended
@@ -1010,13 +1010,13 @@ instance Default Message where
1010 1010
1011-- | Payload bytes are omitted. 1011-- | Payload bytes are omitted.
1012instance Pretty Message where 1012instance Pretty Message where
1013 pretty (KeepAlive ) = "Keep alive" 1013 pPrint (KeepAlive ) = "Keep alive"
1014 pretty (Status m) = "Status" <+> pretty m 1014 pPrint (Status m) = "Status" <+> pPrint m
1015 pretty (Available m) = pretty m 1015 pPrint (Available m) = pPrint m
1016 pretty (Transfer m) = pretty m 1016 pPrint (Transfer m) = pPrint m
1017 pretty (Port p) = "Port" <+> int (fromEnum p) 1017 pPrint (Port p) = "Port" <+> int (fromEnum p)
1018 pretty (Fast m) = pretty m 1018 pPrint (Fast m) = pPrint m
1019 pretty (Extended m) = pretty m 1019 pPrint (Extended m) = pPrint m
1020 1020
1021instance PeerMessage Message where 1021instance PeerMessage Message where
1022 envelop _ = id 1022 envelop _ = id
diff --git a/src/Network/BitTorrent/Exchange/Session.hs b/src/Network/BitTorrent/Exchange/Session.hs
index 2bd275bd..ca849c23 100644
--- a/src/Network/BitTorrent/Exchange/Session.hs
+++ b/src/Network/BitTorrent/Exchange/Session.hs
@@ -1,7 +1,9 @@
1{-# LANGUAGE FlexibleInstances #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TypeFamilies #-} 2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TemplateHaskell #-} 3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE DeriveDataTypeable #-} 4{-# LANGUAGE StandaloneDeriving #-}
5{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeFamilies #-}
5module Network.BitTorrent.Exchange.Session 7module Network.BitTorrent.Exchange.Session
6 ( -- * Session 8 ( -- * Session
7 Session 9 Session
@@ -43,7 +45,7 @@ import Data.Set as S
43import Data.Text as T 45import Data.Text as T
44import Data.Typeable 46import Data.Typeable
45import Text.PrettyPrint hiding ((<>)) 47import Text.PrettyPrint hiding ((<>))
46import Text.PrettyPrint.Class 48import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
47import System.Log.FastLogger (LogStr, ToLogStr (..)) 49import System.Log.FastLogger (LogStr, ToLogStr (..))
48 50
49import Data.BEncode as BE 51import Data.BEncode as BE
@@ -57,6 +59,10 @@ import Network.BitTorrent.Exchange.Download as D
57import Network.BitTorrent.Exchange.Message as Message 59import Network.BitTorrent.Exchange.Message as Message
58import System.Torrent.Storage 60import System.Torrent.Storage
59 61
62#if !MIN_VERSION_iproute(1,2,12)
63deriving instance Ord IP
64#endif
65
60{----------------------------------------------------------------------- 66{-----------------------------------------------------------------------
61-- Exceptions 67-- Exceptions
62-----------------------------------------------------------------------} 68-----------------------------------------------------------------------}
@@ -222,11 +228,11 @@ instance MonadLogger (Connected Session) where
222 conn <- ask 228 conn <- ask
223 ses <- asks connSession 229 ses <- asks connSession
224 addr <- asks connRemoteAddr 230 addr <- asks connRemoteAddr
225 let addrSrc = src <> " @ " <> T.pack (render (pretty addr)) 231 let addrSrc = src <> " @ " <> T.pack (render (pPrint addr))
226 liftIO $ sessionLogger ses loc addrSrc lvl (toLogStr msg) 232 liftIO $ sessionLogger ses loc addrSrc lvl (toLogStr msg)
227 233
228logMessage :: MonadLogger m => Message -> m () 234logMessage :: MonadLogger m => Message -> m ()
229logMessage msg = logDebugN $ T.pack (render (pretty msg)) 235logMessage msg = logDebugN $ T.pack (render (pPrint msg))
230 236
231logEvent :: MonadLogger m => Text -> m () 237logEvent :: MonadLogger m => Text -> m ()
232logEvent = logInfoN 238logEvent = logInfoN
diff --git a/src/Network/BitTorrent/Internal/Progress.hs b/src/Network/BitTorrent/Internal/Progress.hs
index 9aff9935..6ac889e2 100644
--- a/src/Network/BitTorrent/Internal/Progress.hs
+++ b/src/Network/BitTorrent/Internal/Progress.hs
@@ -45,7 +45,7 @@ import Data.Ratio
45import Data.Word 45import Data.Word
46import Network.HTTP.Types.QueryLike 46import Network.HTTP.Types.QueryLike
47import Text.PrettyPrint as PP 47import Text.PrettyPrint as PP
48import Text.PrettyPrint.Class 48import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
49 49
50 50
51-- | Progress data is considered as dynamic within one client 51-- | Progress data is considered as dynamic within one client
@@ -104,7 +104,7 @@ instance QueryLike Progress where
104 ] 104 ]
105 105
106instance Pretty Progress where 106instance Pretty Progress where
107 pretty Progress {..} = 107 pPrint Progress {..} =
108 "/\\" <+> PP.text (show _uploaded) $$ 108 "/\\" <+> PP.text (show _uploaded) $$
109 "\\/" <+> PP.text (show _downloaded) $$ 109 "\\/" <+> PP.text (show _downloaded) $$
110 "left" <+> PP.text (show _left) 110 "left" <+> PP.text (show _left)
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 18:15:29 +0000