Ressurect Truzjan's Tracker modules.

2 files changed, 32 insertions, 24 deletions

diff --git a/dht/bittorrent/src/Network/BitTorrent/Internal/Progress.hs b/dht/src/Network/BitTorrent/Internal/Progress.hs
index 6ac889e2..251bbca4 100644
--- a/dht/bittorrent/src/Network/BitTorrent/Internal/Progress.hs
+++ b/dht/src/Network/BitTorrent/Internal/Progress.hs
@@ -77,6 +77,10 @@ instance Default Progress where
   def = Progress 0 0 0
   {-# INLINE def #-}
 
+instance Semigroup Progress where
+  (<>) = mappend
+  {-# INLINE (<>) #-}
+
 -- | Can be used to aggregate total progress.
 instance Monoid Progress where
   mempty  = def
diff --git a/dht/bittorrent/src/Network/BitTorrent/Tracker/Message.hs b/dht/src/Network/BitTorrent/Tracker/Message.hs
index ab492275..e9d12006 100644
--- a/dht/bittorrent/src/Network/BitTorrent/Tracker/Message.hs
+++ b/dht/src/Network/BitTorrent/Tracker/Message.hs
@@ -28,6 +28,7 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE CPP                        #-}
+{-# LANGUAGE PatternSynonyms            #-}
 {-# OPTIONS -fno-warn-orphans           #-}
 module Network.BitTorrent.Tracker.Message
        ( -- * Announce
@@ -94,6 +95,8 @@ module Network.BitTorrent.Tracker.Message
        , genTransactionId
        , TransactionId
        , Transaction  (..)
+
+       , MessageId(ConnectId,AnnounceId,ScrapeId,ErrorId)
        )
        where
 
@@ -257,7 +260,7 @@ instance Serialize AnnounceQuery where
       , reqPort       = port
       , reqProgress   = progress
       , reqIP         = if ip == 0 then Nothing else Just ip
-      , reqNumWant    = if want == -1 then Nothing
+      , reqNumWant    = if want == maxBound then Nothing
                         else Just (fromIntegral want)
       , reqEvent      = ev
       }
@@ -515,15 +518,13 @@ instance BEncode AnnounceInfo where
       merge :: PeerList IPv4 -> Maybe (PeerList IPv6) -> BE.Get (PeerList IP)
       merge (PeerList ips)          Nothing  = pure (PeerList ips)
       merge (PeerList _  )          (Just _)
-        = fail "PeerList: non-compact peer list provided, \
-                         \but the `peers6' field present"
+        = fail "PeerList: non-compact peer list provided, but the `peers6' field present"
 
       merge (CompactPeerList ipv4s) Nothing
         = pure $ CompactPeerList ipv4s
 
       merge (CompactPeerList _    ) (Just (PeerList _))
-        = fail "PeerList: the `peers6' field value \
-                         \should contain *compact* peer list"
+        = fail "PeerList: the `peers6' field value should contain *compact* peer list"
 
       merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s))
         = pure $ CompactPeerList $
@@ -846,29 +847,32 @@ data instance Transaction Response = TransactionR
 newtype MessageId = MessageId Word32
                     deriving (Show, Eq, Num, Serialize)
 
-connectId, announceId, scrapeId, errorId :: MessageId
-connectId  = 0
-announceId = 1
-scrapeId   = 2
-errorId    = 3
+pattern ConnectId  :: MessageId
+pattern ConnectId  = MessageId 0
+pattern AnnounceId :: MessageId
+pattern AnnounceId = MessageId 1
+pattern ScrapeId   :: MessageId
+pattern ScrapeId   = MessageId 2
+pattern ErrorId    :: MessageId
+pattern ErrorId    = MessageId 3
 
 instance Serialize (Transaction Request) where
   put TransactionQ {..} = do
     case request of
       Connect        -> do
         put initialConnectionId
-        put connectId
+        put ConnectId
         put transIdQ
 
       Announce ann -> do
         put connIdQ
-        put announceId
+        put AnnounceId
         put transIdQ
         put ann
 
       Scrape   hashes -> do
         put connIdQ
-        put scrapeId
+        put ScrapeId
         put transIdQ
         forM_ hashes put
 
@@ -879,9 +883,9 @@ instance Serialize (Transaction Request) where
     where
       getBody :: MessageId -> S.Get Request
       getBody msgId
-        | msgId == connectId  = pure Connect
-        | msgId == announceId = Announce <$> get
-        | msgId == scrapeId   = Scrape   <$> many get
+        | msgId == ConnectId  = pure Connect
+        | msgId == AnnounceId = Announce <$> get
+        | msgId == ScrapeId   = Scrape   <$> many get
         |       otherwise     = fail errMsg
         where
           errMsg = "unknown request: " ++ show msgId
@@ -890,22 +894,22 @@ instance Serialize (Transaction Response) where
   put TransactionR {..} = do
     case response of
       Connected conn -> do
-        put connectId
+        put ConnectId
         put transIdR
         put conn
 
       Announced info -> do
-        put announceId
+        put AnnounceId
         put transIdR
         put info
 
       Scraped infos -> do
-        put scrapeId
+        put ScrapeId
         put transIdR
         forM_ infos put
 
       Failed info -> do
-        put errorId
+        put ErrorId
         put transIdR
         put (encodeUtf8 info)
 
@@ -916,10 +920,10 @@ instance Serialize (Transaction Response) where
     where
       getBody :: MessageId -> S.Get Response
       getBody msgId
-        | msgId == connectId  = Connected <$> get
-        | msgId == announceId = Announced <$> get
-        | msgId == scrapeId   = Scraped   <$> many get
-        | msgId == errorId    = (Failed . decodeUtf8) <$> get
+        | msgId == ConnectId  = Connected <$> get
+        | msgId == AnnounceId = Announced <$> get
+        | msgId == ScrapeId   = Scraped   <$> many get
+        | msgId == ErrorId    = (Failed . decodeUtf8) <$> get
         |       otherwise     = fail msg
         where
           msg = "unknown response: " ++ show msgId