Fix bugs in PeerAddr encoding.

Also:

* PeerAddr.hs internals and export list have been simplified;
* tests added.

7 files changed, 130 insertions, 53 deletions

diff --git a/bittorrent.cabal b/bittorrent.cabal
index c2785f02..8e7fda46 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -163,8 +163,9 @@ test-suite spec
                        Data.Torrent.PieceSpec
                        Data.Torrent.ProgressSpec
                        Network.BitTorrent.CoreSpec
-                       Network.BitTorrent.Core.PeerIdSpec
                        Network.BitTorrent.Core.FingerprintSpec
+                       Network.BitTorrent.Core.PeerAddrSpec
+                       Network.BitTorrent.Core.PeerIdSpec
                        Network.BitTorrent.Tracker.MessageSpec
                        Network.BitTorrent.Tracker.RPCSpec
                        Network.BitTorrent.Tracker.RPC.HTTPSpec
@@ -181,6 +182,7 @@ test-suite spec
                      , data-default
                      , monad-loops
                      , containers
+                     , iproute
 
                      , aeson
                      , cereal
diff --git a/src/Network/BitTorrent/Core.hs b/src/Network/BitTorrent/Core.hs
index 990a5975..7b8ff07d 100644
--- a/src/Network/BitTorrent/Core.hs
+++ b/src/Network/BitTorrent/Core.hs
@@ -7,7 +7,17 @@
 --
 --   Re-export every @Network.BitTorrent.Core.*@ module.
 --
-module Network.BitTorrent.Core (module Core) where
+module Network.BitTorrent.Core
+       ( module Core
+
+         -- * Re-exports from Data.IP
+       , IPv4
+       , IPv6
+       , IP (..)
+       ) where
+
+import Data.IP
+
 import Network.BitTorrent.Core.Fingerprint as Core
 import Network.BitTorrent.Core.PeerId      as Core
-import Network.BitTorrent.Core.PeerAddr    as Core
\ No newline at end of file
+import Network.BitTorrent.Core.PeerAddr    as Core
diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs
index 60ada54d..3c3e98c5 100644
--- a/src/Network/BitTorrent/Core/PeerAddr.hs
+++ b/src/Network/BitTorrent/Core/PeerAddr.hs
@@ -14,6 +14,7 @@
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE ViewPatterns               #-}
 {-# OPTIONS -fno-warn-orphans           #-} -- for PortNumber instances
 module Network.BitTorrent.Core.PeerAddr
        ( -- * Peer address
@@ -24,25 +25,26 @@ module Network.BitTorrent.Core.PeerAddr
          -- * IP
        , mergeIPLists
        , splitIPList
-       , IP, IPv4, IPv6 --re-export Data.IP constructors
        , IPAddress ()
        ) where
 
 import Control.Applicative
+import Control.Monad
 import Data.Aeson (ToJSON, FromJSON)
 import Data.BEncode   as BS
 import Data.BEncode.BDict (BKey)
 import Data.ByteString.Char8 as BS8
 import Data.Char
 import Data.Default
+import Data.Either
+import Data.Foldable
+import Data.IP
 import Data.List      as L
 import Data.List.Split
 import Data.Serialize as S
 import Data.String
 import Data.Typeable
-import Data.IP
-import Data.Foldable
-import Data.Either
+import Data.Word
 import Network.Socket
 import Text.PrettyPrint
 import Text.PrettyPrint.Class
@@ -52,12 +54,22 @@ import qualified Text.ParserCombinators.ReadP as RP
 import Network.BitTorrent.Core.PeerId
 
 
+{-----------------------------------------------------------------------
+--  Port number
+-----------------------------------------------------------------------}
+
 deriving instance ToJSON PortNumber
 deriving instance FromJSON PortNumber
 
 instance BEncode PortNumber where
-  toBEncode = toBEncode . fromEnum
-  fromBEncode b = toEnum <$> fromBEncode b
+  toBEncode   = toBEncode    .  fromEnum
+  fromBEncode = fromBEncode >=> portNumber
+    where
+      portNumber :: Integer -> BS.Result PortNumber
+      portNumber n
+        | 0 <= n && n <= fromIntegral (maxBound :: Word16)
+        = pure $ fromIntegral n
+        | otherwise = decodingError $ "PortNumber: " ++ show n
 
 instance Serialize PortNumber where
   get = fromIntegral <$> getWord16be
@@ -65,57 +77,59 @@ instance Serialize PortNumber where
   put = putWord16be . fromIntegral
   {-# INLINE put #-}
 
-class (Show i, Read i) => IPAddress i where
-    showIp :: i -> String
-    showIp = show
+{-----------------------------------------------------------------------
+--  IP addr
+-----------------------------------------------------------------------}
 
-    readIp :: String -> i
-    readIp = read
-
-    toHostAddr :: i -> Either HostAddress HostAddress6
+class IPAddress i where
+  toHostAddr :: i -> Either HostAddress HostAddress6
 
 instance IPAddress IPv4 where
-    toHostAddr = Left . toHostAddress
+  toHostAddr = Left . toHostAddress
 
 instance IPAddress IPv6 where
-    toHostAddr = Right . toHostAddress6
+  toHostAddr = Right . toHostAddress6
 
 instance IPAddress IP where
-    toHostAddr (IPv4 ip) = toHostAddr ip
-    toHostAddr (IPv6 ip) = toHostAddr ip
-
+  toHostAddr (IPv4 ip) = toHostAddr ip
+  toHostAddr (IPv6 ip) = toHostAddr ip
 
 deriving instance Typeable IP
 deriving instance Typeable IPv4
 deriving instance Typeable IPv6
 
-ipToBEncode :: IPAddress i => i -> BValue
-ipToBEncode ip = BString $ BS8.pack $ showIp ip
+ipToBEncode :: Show i => i -> BValue
+ipToBEncode ip = BString $ BS8.pack $ show ip
 
-ipFromBEncode :: Monad m => IPAddress a => BValue -> m a
-ipFromBEncode (BString ip) = return $ readIp $ BS8.unpack ip
-ipFromBEncode _            = fail "ipFromBEncode"
+ipFromBEncode :: Read a => BValue -> BS.Result a
+ipFromBEncode (BString (BS8.unpack -> ipStr))
+  | Just ip <- readMaybe (ipStr) = pure ip
+  |         otherwise            = decodingError $ "IP: " ++ ipStr
+ipFromBEncode _    = decodingError $ "IP: addr should be a bstring"
 
 instance BEncode IP where
-    toBEncode = ipToBEncode
-    fromBEncode = ipFromBEncode
+  toBEncode   = ipToBEncode
+  fromBEncode = ipFromBEncode
 
 instance BEncode IPv4 where
-    toBEncode = ipToBEncode
-    fromBEncode = ipFromBEncode
+  toBEncode   = ipToBEncode
+  fromBEncode = ipFromBEncode
 
 instance BEncode IPv6 where
-    toBEncode = ipToBEncode
-    fromBEncode = ipFromBEncode
+  toBEncode   = ipToBEncode
+  fromBEncode = ipFromBEncode
 
 instance Serialize IPv4 where
-    put ip = put $ toHostAddress ip
-    get = fromHostAddress <$> get
+    put = putWord32host    .  toHostAddress
+    get = fromHostAddress <$> getWord32host
 
 instance Serialize IPv6 where
     put ip = put $ toHostAddress6 ip
     get = fromHostAddress6 <$> get
 
+{-----------------------------------------------------------------------
+--  Peer addr
+-----------------------------------------------------------------------}
 -- TODO check semantic of ord and eq instances
 
 -- | Peer address info normally extracted from peer list or peer
@@ -126,23 +140,25 @@ data PeerAddr a = PeerAddr
   , peerPort :: {-# UNPACK #-} !PortNumber
   } deriving (Show, Eq, Typeable, Functor)
 
-peer_id_key, peer_ip_key, peer_port_key :: BKey
-peer_id_key   = "peer id"
+peer_ip_key, peer_id_key, peer_port_key :: BKey
 peer_ip_key   = "ip"
+peer_id_key   = "peer id"
 peer_port_key = "port"
 
 -- | The tracker's 'announce response' compatible encoding.
 instance (Typeable a, BEncode a) => BEncode (PeerAddr a) where
   toBEncode PeerAddr {..} = toDict $
-       peer_id_key   .=? peerId
-    .: peer_ip_key   .=! peerAddr
+       peer_ip_key   .=! peerAddr
+    .: peer_id_key   .=? peerId
     .: peer_port_key .=! peerPort
     .: endDict
 
   fromBEncode = fromDict $ do
-    PeerAddr <$>? peer_id_key
+    peerAddr <$>? peer_id_key
              <*>! peer_ip_key
              <*>! peer_port_key
+    where
+      peerAddr ip pid port = PeerAddr ip pid port
 
 mergeIPLists :: [PeerAddr IPv4] -> Maybe [PeerAddr IPv6] -> [PeerAddr IP]
 mergeIPLists v4 v6 = (fmap IPv4 `L.map` v4)
@@ -162,10 +178,8 @@ splitIPList xs = partitionEithers $ toEither <$> xs
 --
 -- TODO: test byte order
 instance (Serialize a) => Serialize (PeerAddr a) where
-    put PeerAddr {..} =
-        put peerAddr >> put peerPort
-    get =
-        PeerAddr Nothing <$> get <*> get
+  put PeerAddr {..} = put peerAddr >> put peerPort
+  get = PeerAddr Nothing <$> get <*> get
 
 -- | @127.0.0.1:6881@
 instance Default (PeerAddr IPv4) where
@@ -178,7 +192,7 @@ instance Default (PeerAddr IPv4) where
 instance IsString (PeerAddr IPv4) where
   fromString str
     | [hostAddrStr, portStr] <- splitWhen (== ':') str
-    , hostAddr <- read hostAddrStr
+    , Just hostAddr <- readMaybe hostAddrStr
     , Just portNum  <- toEnum <$> readMaybe portStr
                 = PeerAddr Nothing hostAddr portNum
     | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str
@@ -196,6 +210,11 @@ instance IsString (PeerAddr IPv6) where
         PeerAddr Nothing ip port
     | otherwise = error $ "fromString: unable to parse (PeerAddr IPv6): " ++ str
 
+instance IsString (PeerAddr IP) where
+  fromString str
+    | '[' `L.elem` str = IPv6 <$> fromString str
+    |      otherwise   = IPv4 <$> fromString str
+
 -- | fingerprint + "at" + dotted.host.inet.addr:port
 -- TODO: instances for IPv6, HostName
 instance Pretty (PeerAddr IP) where
@@ -215,8 +234,8 @@ _resolvePeerAddr = undefined
 -- | Convert peer info from tracker response to socket address.  Used
 --   for establish connection between peers.
 --
-peerSockAddr :: (IPAddress i) => PeerAddr i -> SockAddr
+peerSockAddr :: PeerAddr IP -> SockAddr
 peerSockAddr PeerAddr {..} =
-  case toHostAddr peerAddr of
-    Left  host4 -> SockAddrInet  peerPort   host4
-    Right host6 -> SockAddrInet6 peerPort 0 host6 0
+  case peerAddr of
+    IPv4 ipv4 -> SockAddrInet  peerPort   (toHostAddress  ipv4)
+    IPv6 ipv6 -> SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0
diff --git a/src/Network/BitTorrent/Exchange/Wire.hs b/src/Network/BitTorrent/Exchange/Wire.hs
index 27b4be12..2a7d2aeb 100644
--- a/src/Network/BitTorrent/Exchange/Wire.hs
+++ b/src/Network/BitTorrent/Exchange/Wire.hs
@@ -505,7 +505,7 @@ initiateHandshake sock hs = do
   recvHandshake sock
 
 -- | Tries to connect to peer using reasonable default parameters.
-connectToPeer :: (IPAddress i) => PeerAddr i -> IO Socket
+connectToPeer :: PeerAddr IP -> IO Socket
 connectToPeer p = do
   sock <- socket AF_INET Stream Network.Socket.defaultProtocol
   connect sock (peerSockAddr p)
@@ -628,7 +628,7 @@ reconnect = undefined
 --
 -- This function can throw 'WireFailure' exception.
 --
-connectWire :: (IPAddress i) => Handshake -> PeerAddr i -> ExtendedCaps -> Wire () -> IO ()
+connectWire :: Handshake -> PeerAddr IP -> ExtendedCaps -> Wire () -> IO ()
 connectWire hs addr extCaps wire =
   bracket (connectToPeer addr) close $ \ sock -> do
     hs' <- initiateHandshake sock hs
diff --git a/src/Network/BitTorrent/Tracker/Message.hs b/src/Network/BitTorrent/Tracker/Message.hs
index 95b9c7ca..0d720471 100644
--- a/src/Network/BitTorrent/Tracker/Message.hs
+++ b/src/Network/BitTorrent/Tracker/Message.hs
@@ -81,6 +81,7 @@ import Data.Default
 import Data.List as L
 import Data.Maybe
 import Data.Serialize as S hiding (Result)
+import Data.String
 import Data.Text (Text)
 import Data.Text.Encoding
 import Data.Typeable
@@ -480,7 +481,7 @@ data AnnounceInfo =
 
        -- | Human readable warning.
      , respWarning     :: !(Maybe Text)
-     } deriving (Show, Typeable)
+     } deriving (Show, Eq, Typeable)
 
 -- | HTTP tracker protocol compatible encoding.
 instance BEncode AnnounceInfo where
@@ -535,6 +536,12 @@ instance Serialize AnnounceInfo where
       , respPeers       = PeerList peers
       }
 
+-- | Decodes announce response from bencoded string, for debugging only.
+instance IsString AnnounceInfo where
+  fromString str = either (error . format) id $ BE.decode (fromString str)
+    where
+      format msg = "fromString: unable to decode AnnounceInfo: " ++ msg
+
 -- | Above 25, new peers are highly unlikely to increase download
 --   speed.  Even 30 peers is /plenty/, the official client version 3
 --   in fact only actively forms new connections if it has less than
diff --git a/tests/Network/BitTorrent/Core/PeerIdSpec.hs b/tests/Network/BitTorrent/Core/PeerIdSpec.hs
index a4cc30b8..4b0c2398 100644
--- a/tests/Network/BitTorrent/Core/PeerIdSpec.hs
+++ b/tests/Network/BitTorrent/Core/PeerIdSpec.hs
@@ -1,6 +1,7 @@
 {-# OPTIONS -fno-warn-orphans #-}
 module Network.BitTorrent.Core.PeerIdSpec (spec) where
 import Control.Applicative
+import Data.BEncode as BE
 import Data.Text.Encoding as T
 import Test.Hspec
 import Test.QuickCheck
@@ -17,4 +18,8 @@ instance Arbitrary PeerId where
     ]
 
 spec :: Spec
-spec = return ()
\ No newline at end of file
+spec = do
+  describe "PeerId" $ do
+    it "properly bencoded" $ do
+      BE.decode "20:01234567890123456789"
+        `shouldBe` Right ("01234567890123456789" :: PeerId)
\ No newline at end of file
diff --git a/tests/Network/BitTorrent/Tracker/MessageSpec.hs b/tests/Network/BitTorrent/Tracker/MessageSpec.hs
index ac770905..bf89e717 100644
--- a/tests/Network/BitTorrent/Tracker/MessageSpec.hs
+++ b/tests/Network/BitTorrent/Tracker/MessageSpec.hs
@@ -7,6 +7,8 @@ module Network.BitTorrent.Tracker.MessageSpec
        ) where
 
 import Control.Applicative
+import Control.Exception
+import Data.BEncode as BE
 import Data.List as L
 import Data.Maybe
 import Data.Word
@@ -56,10 +58,42 @@ arbitrarySample = L.head <$> sample' arbitrary
 
 spec :: Spec
 spec = do
-  describe "Announce" $ do
+  describe "AnnounceQuery" $ do
     it "properly url encoded" $ property $ \ q ->
       parseAnnounceQuery (renderAnnounceQuery q)
         `shouldBe` Right q
 
+  describe "AnnounceInfo" $ do
+    it "parses minimal sample" $ do
+      "d8:intervali0e5:peerslee"
+        `shouldBe`
+        AnnounceInfo Nothing Nothing 0 Nothing (PeerList []) Nothing
+
+    it "parses optional fields" $ do
+      "d8:completei1e\
+       \10:incompletei2e\
+       \8:intervali3e\
+       \12:min intervali4e\
+       \5:peersle\
+       \15:warning message3:str\
+       \e"
+        `shouldBe`
+        AnnounceInfo (Just 1) (Just 2) 3 (Just 4) (PeerList []) (Just "str")
+
+    it "parses failed response" $ do
+      "d14:failure reason10:any reasone"
+                 `shouldBe`
+        Message.Failure "any reason"
+
+    it "fail if no peer list present" $ do
+      evaluate ("d8:intervali0ee" :: AnnounceInfo)
+        `shouldThrow`
+         errorCall "fromString: unable to decode AnnounceInfo: \
+                   \required field `peers' not found"
+
+    it "parses peer list" $ do -- TODO
+      "d8:intervali0e5:peerslee" `shouldBe`
+        AnnounceInfo Nothing Nothing 0 Nothing (PeerList []) Nothing
+
   describe "Scrape" $ do
     return ()