1 files changed, 1254 insertions, 0 deletions

diff --git a/src/Network/BitTorrent/Address.hs b/src/Network/BitTorrent/Address.hs
new file mode 100644
index 00000000..a72a8a07
--- /dev/null
+++ b/src/Network/BitTorrent/Address.hs
@@ -0,0 +1,1254 @@
+-- |
+--   Module      :  Network.BitTorrent.Address
+--   Copyright   :  (c) Sam Truzjan 2013
+--                  (c) Daniel Gröber 2013
+--   License     :  BSD3
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  provisional
+--   Portability :  portable
+--
+--   Peer and Node addresses.
+--
+{-# LANGUAGE CPP                        #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE ViewPatterns               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Network.BitTorrent.Address
+       ( -- * Address
+         Address (..)
+       , fromAddr
+
+         -- ** IP
+       , IPv4
+       , IPv6
+       , IP (..)
+
+         -- * PeerId
+         -- $peer-id
+       , PeerId
+
+         -- ** Generation
+       , genPeerId
+       , timestamp
+       , entropy
+
+         -- ** Encoding
+       , azureusStyle
+       , shadowStyle
+       , defaultClientId
+       , defaultVersionNumber
+
+         -- * PeerAddr
+         -- $peer-addr
+       , PeerAddr(..)
+       , defaultPorts
+       , peerSockAddr
+       , peerSocket
+
+         -- * Node
+         -- ** Id
+       , NodeId(..)
+       , nodeIdSize
+       , testIdBit
+       , NodeDistance
+       , distance
+       , genNodeId
+       , bucketRange
+       , genBucketSample
+       , bep42
+       , bep42s
+
+         -- ** Info
+       , NodeAddr (..)
+       , NodeInfo (..)
+       , rank
+
+         -- * Fingerprint
+         -- $fingerprint
+       , Software (..)
+       , Fingerprint (..)
+       , libFingerprint
+       , fingerprint
+
+         -- * Utils
+       , libUserAgent
+       ) where
+
+import Control.Applicative
+import Control.Monad
+import Data.BEncode as BE
+import Data.BEncode   as BS
+import Data.BEncode.BDict (BKey)
+import Data.Bits
+import Data.ByteString as BS
+import Data.ByteString.Internal as BS
+import Data.ByteString.Base16 as Base16
+import Data.ByteString.Char8 as BC
+import Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Lazy.Builder as BS
+import Data.Char
+import Data.Convertible
+import Data.Default
+import Data.IP
+import Data.List as L
+import Data.List.Split as L
+import Data.Maybe       (fromMaybe, catMaybes, mapMaybe)
+import Data.Monoid
+import Data.Hashable
+import Data.Ord
+import Data.Serialize as S
+import Data.String
+import Data.Time
+import Data.Typeable
+import Data.Version
+import Data.Word
+import qualified Text.ParserCombinators.ReadP as RP
+import Text.Read        (readMaybe)
+import Network.HTTP.Types.QueryLike
+import Network.Socket
+import Text.PrettyPrint as PP hiding ((<>))
+import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
+#if !MIN_VERSION_time(1,5,0)
+import System.Locale    (defaultTimeLocale)
+#endif
+import System.Entropy
+import Data.Digest.CRC32C
+
+-- import Paths_bittorrent (version)
+
+{-----------------------------------------------------------------------
+--  Address
+-----------------------------------------------------------------------}
+
+instance Pretty UTCTime where
+  pPrint = PP.text . show
+
+class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
+    => Address a where
+  toSockAddr   :: a        -> SockAddr
+  fromSockAddr :: SockAddr -> Maybe a
+
+fromAddr :: (Address a, Address b) => a -> Maybe b
+fromAddr = fromSockAddr . toSockAddr
+
+-- | Note that port is zeroed.
+instance Address IPv4 where
+  toSockAddr = SockAddrInet 0 . toHostAddress
+  fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
+  fromSockAddr  _                 = Nothing
+
+-- | Note that port is zeroed.
+instance Address IPv6 where
+  toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
+  fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
+  fromSockAddr  _                      = Nothing
+
+-- | Note that port is zeroed.
+instance Address IP where
+  toSockAddr (IPv4 h) = toSockAddr h
+  toSockAddr (IPv6 h) = toSockAddr h
+  fromSockAddr sa =
+        IPv4 <$> fromSockAddr sa
+    <|> IPv6 <$> fromSockAddr sa
+
+setPort :: PortNumber -> SockAddr -> SockAddr
+setPort port (SockAddrInet  _   h  ) = SockAddrInet  port   h
+setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
+setPort _    addr                    = addr
+{-# INLINE setPort #-}
+
+getPort :: SockAddr -> Maybe PortNumber
+getPort (SockAddrInet  p   _  ) = Just p
+getPort (SockAddrInet6 p _ _ _) = Just p
+getPort _                       = Nothing
+{-# INLINE getPort #-}
+
+instance Address a => Address (NodeAddr a) where
+  toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost
+  fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> getPort sa
+
+instance Address a => Address (PeerAddr a) where
+  toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost
+  fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> getPort sa
+
+{-----------------------------------------------------------------------
+--  Peer id
+-----------------------------------------------------------------------}
+-- $peer-id
+--
+--  'PeerID' represent self assigned peer identificator. Ideally each
+--  host in the network should have unique peer id to avoid
+--  collisions, therefore for peer ID generation we use good entropy
+--  source. Peer ID is sent in /tracker request/, sent and received in
+--  /peer handshakes/ and used in DHT queries.
+--
+
+-- TODO use unpacked Word160 form (length is known statically)
+
+-- | Peer identifier is exactly 20 bytes long bytestring.
+newtype PeerId = PeerId { getPeerId :: ByteString }
+  deriving (Show, Eq, Ord, BEncode, Typeable)
+
+peerIdLen :: Int
+peerIdLen = 20
+
+-- | For testing purposes only.
+instance Default PeerId where
+  def = azureusStyle defaultClientId defaultVersionNumber ""
+
+instance Hashable PeerId where
+  hashWithSalt = hashUsing getPeerId
+  {-# INLINE hashWithSalt #-}
+
+instance Serialize PeerId where
+  put = putByteString . getPeerId
+  get = PeerId <$> getBytes peerIdLen
+
+instance QueryValueLike PeerId where
+  toQueryValue (PeerId pid) = Just pid
+  {-# INLINE toQueryValue #-}
+
+instance IsString PeerId where
+  fromString str
+      | BS.length bs == peerIdLen = PeerId bs
+      | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str
+    where
+      bs = fromString str
+
+instance Pretty PeerId where
+  pPrint = text . BC.unpack . getPeerId
+
+instance Convertible BS.ByteString PeerId where
+  safeConvert bs
+    | BS.length bs == peerIdLen = pure (PeerId bs)
+    |          otherwise        = convError "invalid length" bs
+
+------------------------------------------------------------------------
+
+-- | Pad bytestring so it's becomes exactly request length. Conversion
+-- is done like so:
+--
+--     * length < size: Complete bytestring by given charaters.
+--
+--     * length = size: Output bytestring as is.
+--
+--     * length > size: Drop last (length - size) charaters from a
+--     given bytestring.
+--
+byteStringPadded :: ByteString -- ^ bytestring to be padded.
+                 -> Int        -- ^ size of result builder.
+                 -> Char       -- ^ character used for padding.
+                 -> BS.Builder
+byteStringPadded bs s c =
+      BS.byteString (BS.take s bs) <>
+      BS.byteString (BC.replicate padLen c)
+  where
+    padLen = s - min (BS.length bs) s
+
+-- | Azureus-style encoding have the following layout:
+--
+--     * 1  byte : '-'
+--
+--     * 2  bytes: client id
+--
+--     * 4  bytes: version number
+--
+--     * 1  byte : '-'
+--
+--     * 12 bytes: random number
+--
+azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
+             -> ByteString -- ^ Version number, padded with 'X'.
+             -> ByteString -- ^ Random number, padded with '0'.
+             -> PeerId     -- ^ Azureus-style encoded peer ID.
+azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
+    BS.char8 '-' <>
+      byteStringPadded cid 2  'H' <>
+      byteStringPadded ver 4  'X' <>
+    BS.char8 '-' <>
+      byteStringPadded rnd 12 '0'
+
+-- | Shadow-style encoding have the following layout:
+--
+--     * 1 byte   : client id.
+--
+--     * 0-4 bytes: version number. If less than 4 then padded with
+--     '-' char.
+--
+--     * 15 bytes : random number. If length is less than 15 then
+--     padded with '0' char.
+--
+shadowStyle :: Char       -- ^ Client ID.
+            -> ByteString -- ^ Version number.
+            -> ByteString -- ^ Random number.
+            -> PeerId     -- ^ Shadow style encoded peer ID.
+shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
+    BS.char8 cid <>
+      byteStringPadded ver 4  '-' <>
+      byteStringPadded rnd 15 '0'
+
+
+-- | 'HS'- 2 bytes long client identifier.
+defaultClientId :: ByteString
+defaultClientId = "HS"
+
+-- | Gives exactly 4 bytes long version number for any version of the
+-- package.  Version is taken from .cabal file.
+defaultVersionNumber :: ByteString
+defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $
+                         versionBranch myVersion
+  where
+    Fingerprint _ myVersion = libFingerprint
+
+------------------------------------------------------------------------
+
+-- | Gives 15 characters long decimal timestamp such that:
+--
+--     * 6 bytes   : first 6 characters from picoseconds obtained with %q.
+--
+--     * 1 byte    : character \'.\' for readability.
+--
+--     * 9..* bytes: number of whole seconds since the Unix epoch
+--     (!)REVERSED.
+--
+--   Can be used both with shadow and azureus style encoding. This
+--   format is used to make the ID's readable for debugging purposes.
+--
+timestamp :: IO ByteString
+timestamp = (BC.pack . format) <$> getCurrentTime
+  where
+    format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
+               L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t))
+
+-- | Gives 15 character long random bytestring. This is more robust
+-- method for generation of random part of peer ID than 'timestamp'.
+entropy :: IO ByteString
+entropy = getEntropy 15
+
+-- NOTE: entropy generates incorrrect peer id
+
+-- |  Here we use 'azureusStyle' encoding with the following args:
+--
+--      * 'HS' for the client id; ('defaultClientId')
+--
+--      * Version of the package for the version number;
+--      ('defaultVersionNumber')
+--
+--      * UTC time day ++ day time for the random number. ('timestamp')
+--
+genPeerId :: IO PeerId
+genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
+
+{-----------------------------------------------------------------------
+-- Peer Addr
+-----------------------------------------------------------------------}
+-- $peer-addr
+--
+--   'PeerAddr' is used to represent peer address. Currently it's
+--   just peer IP and peer port but this might change in future.
+--
+
+{-----------------------------------------------------------------------
+--  Port number
+-----------------------------------------------------------------------}
+
+instance BEncode PortNumber where
+  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
+  {-# INLINE get #-}
+  put = putWord16be . fromIntegral
+  {-# INLINE put #-}
+
+instance Hashable PortNumber where
+  hashWithSalt s = hashWithSalt s . fromEnum
+  {-# INLINE hashWithSalt #-}
+
+instance Pretty PortNumber where
+  pPrint = PP.int . fromEnum
+  {-# INLINE pPrint #-}
+
+{-----------------------------------------------------------------------
+--  IP addr
+-----------------------------------------------------------------------}
+
+class IPAddress i where
+  toHostAddr :: i -> Either HostAddress HostAddress6
+
+instance IPAddress IPv4 where
+  toHostAddr = Left . toHostAddress
+  {-# INLINE toHostAddr #-}
+
+instance IPAddress IPv6 where
+  toHostAddr = Right . toHostAddress6
+  {-# INLINE toHostAddr #-}
+
+instance IPAddress IP where
+  toHostAddr (IPv4 ip) = toHostAddr ip
+  toHostAddr (IPv6 ip) = toHostAddr ip
+  {-# INLINE toHostAddr #-}
+
+deriving instance Typeable IP
+deriving instance Typeable IPv4
+deriving instance Typeable IPv6
+
+ipToBEncode :: Show i => i -> BValue
+ipToBEncode ip = BString $ BS8.pack $ show ip
+{-# INLINE ipToBEncode #-}
+
+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
+  {-# INLINE toBEncode #-}
+  fromBEncode = ipFromBEncode
+  {-# INLINE fromBEncode #-}
+
+instance BEncode IPv4 where
+  toBEncode   = ipToBEncode
+  {-# INLINE toBEncode #-}
+  fromBEncode = ipFromBEncode
+  {-# INLINE fromBEncode #-}
+
+instance BEncode IPv6 where
+  toBEncode   = ipToBEncode
+  {-# INLINE toBEncode #-}
+  fromBEncode = ipFromBEncode
+  {-# INLINE fromBEncode #-}
+
+-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
+-- number of bytes since we have no other way of telling which
+-- address type we are trying to parse
+instance Serialize IP where
+    put (IPv4 ip) = put ip
+    put (IPv6 ip) = put ip
+
+    get = do
+      n <- remaining
+      case n of
+        4  -> IPv4 <$> get
+        16 -> IPv6 <$> get
+        _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
+
+instance Serialize IPv4 where
+    put = putWord32host    .  toHostAddress
+    get = fromHostAddress <$> getWord32host
+
+instance Serialize IPv6 where
+    put ip = put $ toHostAddress6 ip
+    get = fromHostAddress6 <$> get
+
+instance Pretty IPv4 where
+  pPrint = PP.text . show
+  {-# INLINE pPrint #-}
+
+instance Pretty IPv6 where
+  pPrint = PP.text . show
+  {-# INLINE pPrint #-}
+
+instance Pretty IP where
+  pPrint = PP.text . show
+  {-# INLINE pPrint #-}
+
+instance Hashable IPv4 where
+  hashWithSalt = hashUsing toHostAddress
+  {-# INLINE hashWithSalt #-}
+
+instance Hashable IPv6 where
+  hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
+
+instance Hashable IP where
+  hashWithSalt s (IPv4 h) = hashWithSalt s h
+  hashWithSalt s (IPv6 h) = hashWithSalt s h
+
+{-----------------------------------------------------------------------
+--  Peer addr
+-----------------------------------------------------------------------}
+-- TODO check semantic of ord and eq instances
+
+-- | Peer address info normally extracted from peer list or peer
+-- compact list encoding.
+data PeerAddr a = PeerAddr
+  { peerId   :: !(Maybe PeerId)
+
+    -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved
+    -- 'HostName'.
+  , peerHost :: !a
+
+    -- | The port the peer listenning for incoming P2P sessions.
+  , peerPort :: {-# UNPACK #-} !PortNumber
+  } deriving (Show, Eq, Ord, Typeable, Functor)
+
+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_ip_key   .=! peerHost
+    .: peer_id_key   .=? peerId
+    .: peer_port_key .=! peerPort
+    .: endDict
+
+  fromBEncode = fromDict $ do
+    peerAddr <$>! peer_ip_key
+             <*>? peer_id_key
+             <*>! peer_port_key
+    where
+      peerAddr = flip PeerAddr
+
+-- | The tracker's 'compact peer list' compatible encoding. The
+-- 'peerId' is always 'Nothing'.
+--
+--   For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
+--
+-- TODO: test byte order
+instance (Serialize a) => Serialize (PeerAddr a) where
+  put PeerAddr {..} = put peerHost >> put peerPort
+  get = PeerAddr Nothing <$> get <*> get
+
+-- | @127.0.0.1:6881@
+instance Default (PeerAddr IPv4) where
+  def = "127.0.0.1:6881"
+
+-- | @127.0.0.1:6881@
+instance Default (PeerAddr IP) where
+  def = IPv4 <$> def
+
+-- | Example:
+--
+--   @peerPort \"127.0.0.1:6881\" == 6881@
+--
+instance IsString (PeerAddr IPv4) where
+  fromString str
+    | [hostAddrStr, portStr] <- splitWhen (== ':') str
+    , Just hostAddr <- readMaybe hostAddrStr
+    , Just portNum  <- toEnum <$> readMaybe portStr
+                = PeerAddr Nothing hostAddr portNum
+    | otherwise = error $ "fromString: unable to parse (PeerAddr IPv4): " ++ str
+
+instance Read (PeerAddr IPv4) where
+  readsPrec i = RP.readP_to_S $ do
+    ipv4 <- RP.readS_to_P (readsPrec i)
+    _    <- RP.char ':'
+    port <- toEnum <$> RP.readS_to_P (readsPrec i)
+    return $ PeerAddr Nothing ipv4 port
+
+readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
+readsIPv6_port = RP.readP_to_S $ do
+  ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']'
+  _ <- RP.char ':'
+  port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof
+  return (ip,port)
+
+instance IsString (PeerAddr IPv6) where
+  fromString str
+    | [((ip,port),"")] <- readsIPv6_port str =
+        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 a => Pretty (PeerAddr a) where
+  pPrint PeerAddr {..}
+    | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr
+    |     otherwise      = paddr
+    where
+      paddr = pPrint peerHost <> ":" <> text (show peerPort)
+
+instance Hashable a => Hashable (PeerAddr a) where
+  hashWithSalt s PeerAddr {..} =
+    s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort
+
+-- | Ports typically reserved for bittorrent P2P listener.
+defaultPorts :: [PortNumber]
+defaultPorts =  [6881..6889]
+
+_resolvePeerAddr :: (IPAddress i) => PeerAddr HostName -> PeerAddr i
+_resolvePeerAddr = undefined
+
+_peerSockAddr :: PeerAddr IP -> (Family, SockAddr)
+_peerSockAddr PeerAddr {..} =
+    case peerHost of
+          IPv4 ipv4 ->
+              (AF_INET, SockAddrInet peerPort (toHostAddress  ipv4))
+          IPv6 ipv6 ->
+              (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0)
+
+peerSockAddr :: PeerAddr IP -> SockAddr
+peerSockAddr = snd . _peerSockAddr
+
+-- | Create a socket connected to the address specified in a peerAddr
+peerSocket :: SocketType -> PeerAddr IP -> IO Socket
+peerSocket socketType pa = do
+    let (family, addr) = _peerSockAddr pa
+    sock <- socket family socketType defaultProtocol
+    connect sock addr
+    return sock
+
+{-----------------------------------------------------------------------
+--  Node info
+-----------------------------------------------------------------------}
+--   $node-info
+--
+--   A \"node\" is a client\/server listening on a UDP port
+--   implementing the distributed hash table protocol. The DHT is
+--   composed of nodes and stores the location of peers. BitTorrent
+--   clients include a DHT node, which is used to contact other nodes
+--   in the DHT to get the location of peers to download from using
+--   the BitTorrent protocol.
+
+-- TODO more compact representation ('ShortByteString's?)
+
+-- | Each node has a globally unique identifier known as the \"node
+-- ID.\"
+--
+--   Normally, /this/ node id should be saved between invocations
+--   of the client software.
+newtype NodeId = NodeId ByteString
+  deriving (Show, Eq, Ord, BEncode, Typeable)
+
+nodeIdSize :: Int
+nodeIdSize = 20
+
+-- | Meaningless node id, for testing purposes only.
+instance Default NodeId where
+  def = NodeId (BS.replicate nodeIdSize 0)
+
+instance Serialize NodeId where
+  get = NodeId <$> getByteString nodeIdSize
+  {-# INLINE get #-}
+  put (NodeId bs) = putByteString bs
+  {-# INLINE put #-}
+
+-- | ASCII encoded.
+instance IsString NodeId where
+  fromString str
+    | L.length str == nodeIdSize     = NodeId (fromString str)
+    | L.length str == 2 * nodeIdSize = NodeId (fst $ Base16.decode $ fromString str)
+    |           otherwise = error "fromString: invalid NodeId length"
+  {-# INLINE fromString #-}
+
+-- | base16 encoded.
+instance Pretty NodeId where
+  pPrint (NodeId nid) = PP.text $ BC.unpack $ Base16.encode nid
+
+-- | Test if the nth bit is set.
+testIdBit :: NodeId -> Word -> Bool
+testIdBit (NodeId bs) i
+  | fromIntegral i < nodeIdSize * 8
+  , (q, r) <- quotRem (fromIntegral i) 8
+  = testBit (BS.index bs q) (7 - r)
+  |     otherwise      = False
+{-# INLINE testIdBit #-}
+
+-- TODO WARN is the 'system' random suitable for this?
+-- | Generate random NodeID used for the entire session.
+--   Distribution of ID's should be as uniform as possible.
+--
+genNodeId :: IO NodeId
+genNodeId = NodeId <$> getEntropy nodeIdSize
+
+------------------------------------------------------------------------
+
+-- | In Kademlia, the distance metric is XOR and the result is
+-- interpreted as an unsigned integer.
+newtype NodeDistance = NodeDistance BS.ByteString
+  deriving (Eq, Ord)
+
+instance Pretty NodeDistance where
+  pPrint (NodeDistance bs) = foldMap bitseq $ BS.unpack bs
+    where
+      listBits w = L.map (testBit w) (L.reverse [0..finiteBitSize w - 1])
+      bitseq = foldMap (int . fromEnum) . listBits
+
+-- | distance(A,B) = |A xor B| Smaller values are closer.
+distance :: NodeId -> NodeId -> NodeDistance
+distance (NodeId a) (NodeId b) = NodeDistance (BS.pack (BS.zipWith xor a b))
+
+-- | Accepts a depth/index of a bucket and whether or not it is the last one,
+-- yields:
+--
+--  count of leading bytes to be copied from your node id.
+--
+--  mask to clear the extra bits of the last copied byte
+--
+--  mask to toggle the last copied bit if it is not the last bucket
+--
+-- Normally this is used with 'genBucketSample' to obtain a random id suitable
+-- for refreshing a particular bucket.
+bucketRange :: Int -> Bool -> (Int, Word8, Word8)
+bucketRange depth is_last = (q,m,b)
+ where
+     (q,r) = divMod ((if is_last then (+7) else (+8)) depth) 8
+     m = 2^(7-r) - 1
+     b = if is_last then 0 else 2^(7-r)
+
+-- | Generate a random 'NodeId' within a range suitable for a bucket.  To
+-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
+-- is for the current deepest bucket in our routing table:
+--
+-- > sample <- genBucketSample nid (bucketRange index is_last)
+genBucketSample :: NodeId -> (Int,Word8,Word8) -> IO NodeId
+genBucketSample n qmb = genBucketSample' getEntropy n qmb
+
+-- | Generalizion of 'genBucketSample' that accepts a byte generator
+-- function to use instead of the system entropy.
+genBucketSample' :: Applicative m =>
+    (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
+genBucketSample' gen (NodeId self) (q,m,b)
+    | q <= 0           =  NodeId <$> gen nodeIdSize
+    | q >= nodeIdSize  =  pure (NodeId self)
+    | otherwise        =  NodeId . build <$> gen (nodeIdSize - q + 1)
+ where
+    build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
+     where
+        hd = BS.take q self
+        h = xor b (complement m .&. BS.last hd)
+        t = m .&. BS.head tl
+
+------------------------------------------------------------------------
+
+data NodeAddr a = NodeAddr
+  { nodeHost ::                !a
+  , nodePort :: {-# UNPACK #-} !PortNumber
+  } deriving (Eq, Typeable, Functor, Foldable, Traversable)
+
+instance Show a => Show (NodeAddr a) where
+  showsPrec i NodeAddr {..}
+    = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
+
+instance Read (NodeAddr IPv4) where
+  readsPrec i x = [ (fromPeerAddr a, s) | (a, s) <- readsPrec i x ]
+
+-- | @127.0.0.1:6882@
+instance Default (NodeAddr IPv4) where
+  def = "127.0.0.1:6882"
+
+-- | KRPC compatible encoding.
+instance Serialize a => Serialize (NodeAddr a) where
+  get = NodeAddr <$> get <*> get
+  {-# INLINE get #-}
+  put NodeAddr {..} = put nodeHost >> put nodePort
+  {-# INLINE put #-}
+
+-- | Torrent file compatible encoding.
+instance BEncode a => BEncode (NodeAddr a) where
+  toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort)
+  {-# INLINE toBEncode #-}
+  fromBEncode b = uncurry NodeAddr <$> fromBEncode b
+  {-# INLINE fromBEncode #-}
+
+instance Hashable a => Hashable (NodeAddr a) where
+  hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
+  {-# INLINE hashWithSalt #-}
+
+instance Pretty ip => Pretty (NodeAddr ip) where
+  pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
+
+-- | Example:
+--
+--   @nodePort \"127.0.0.1:6881\" == 6881@
+--
+instance IsString (NodeAddr IPv4) where
+  fromString = fromPeerAddr . fromString
+
+fromPeerAddr :: PeerAddr a -> NodeAddr a
+fromPeerAddr PeerAddr {..} = NodeAddr
+  { nodeHost = peerHost
+  , nodePort = peerPort
+  }
+
+------------------------------------------------------------------------
+
+data NodeInfo a = NodeInfo
+  { nodeId   :: !NodeId
+  , nodeAddr :: !(NodeAddr a)
+  } deriving (Show, Eq, Functor, Foldable, Traversable)
+
+instance Eq a => Ord (NodeInfo a) where
+  compare = comparing nodeId
+
+-- | KRPC 'compact list' compatible encoding: contact information for
+-- nodes is encoded as a 26-byte string. Also known as "Compact node
+-- info" the 20-byte Node ID in network byte order has the compact
+-- IP-address/port info concatenated to the end.
+instance Serialize a => Serialize (NodeInfo a) where
+  get = NodeInfo <$> get <*> get
+  put NodeInfo {..} = put nodeId >> put nodeAddr
+
+instance Pretty ip => Pretty (NodeInfo ip) where
+  pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
+
+instance Pretty ip => Pretty [NodeInfo ip] where
+  pPrint = PP.vcat . PP.punctuate "," . L.map pPrint
+
+-- | Order by closeness: nearest nodes first.
+rank :: (x -> NodeId) -> NodeId -> [x] -> [x]
+rank f nid = L.sortBy (comparing (distance nid . f))
+
+{-----------------------------------------------------------------------
+-- Fingerprint
+-----------------------------------------------------------------------}
+-- $fingerprint
+--
+--   'Fingerprint' is used to identify the client implementation and
+--   version which also contained in 'Peer'. For exsample first 6
+--   bytes of peer id of this this library are @-HS0100-@ while for
+--   mainline we have @M4-3-6--@.  We could extract this info and
+--   print in human-friendly form: this is useful for debugging and
+--   logging.
+--
+--   For more information see:
+--   <http://bittorrent.org/beps/bep_0020.html>
+--
+--
+--   NOTE: Do /not/ use this information to control client
+--   capabilities (such as supported enchancements), this should be
+--   done using 'Network.BitTorrent.Extension'!
+--
+
+-- TODO FIXME
+version :: Version
+version = Version [0, 0, 0, 3] []
+
+-- | List of registered client versions + 'IlibHSbittorrent' (this
+-- package) + 'IUnknown' (for not recognized software). All names are
+-- prefixed by \"I\" because some of them starts from lowercase letter
+-- but that is not a valid Haskell constructor name.
+--
+data Software =
+   IUnknown
+
+ | IMainline
+
+ | IABC
+ | IOspreyPermaseed
+ | IBTQueue
+ | ITribler
+ | IShadow
+ | IBitTornado
+
+-- UPnP(!) Bit Torrent !???
+-- 'U' - UPnP NAT Bit Torrent
+ | IBitLord
+ | IOpera
+ | IMLdonkey
+
+ | IAres
+ | IArctic
+ | IAvicora
+ | IBitPump
+ | IAzureus
+ | IBitBuddy
+ | IBitComet
+ | IBitflu
+ | IBTG
+ | IBitRocket
+ | IBTSlave
+ | IBittorrentX
+ | IEnhancedCTorrent
+ | ICTorrent
+ | IDelugeTorrent
+ | IPropagateDataClient
+ | IEBit
+ | IElectricSheep
+ | IFoxTorrent
+ | IGSTorrent
+ | IHalite
+ | IlibHSbittorrent
+ | IHydranode
+ | IKGet
+ | IKTorrent
+ | ILH_ABC
+ | ILphant
+ | ILibtorrent
+ | ILibTorrent
+ | ILimeWire
+ | IMonoTorrent
+ | IMooPolice
+ | IMiro
+ | IMoonlightTorrent
+ | INetTransport
+ | IPando
+ | IqBittorrent
+ | IQQDownload
+ | IQt4TorrentExample
+ | IRetriever
+ | IShareaza
+ | ISwiftbit
+ | ISwarmScope
+ | ISymTorrent
+ | Isharktorrent
+ | ITorrentDotNET
+ | ITransmission
+ | ITorrentstorm
+ | ITuoTu
+ | IuLeecher
+ | IuTorrent
+ | IVagaa
+ | IBitLet
+ | IFireTorrent
+ | IXunlei
+ | IXanTorrent
+ | IXtorrent
+ | IZipTorrent
+   deriving (Show, Eq, Ord, Enum, Bounded)
+
+parseSoftware :: ByteString -> Software
+parseSoftware = f . BC.unpack
+ where
+  f "AG" = IAres
+  f "A~" = IAres
+  f "AR" = IArctic
+  f "AV" = IAvicora
+  f "AX" = IBitPump
+  f "AZ" = IAzureus
+  f "BB" = IBitBuddy
+  f "BC" = IBitComet
+  f "BF" = IBitflu
+  f "BG" = IBTG
+  f "BR" = IBitRocket
+  f "BS" = IBTSlave
+  f "BX" = IBittorrentX
+  f "CD" = IEnhancedCTorrent
+  f "CT" = ICTorrent
+  f "DE" = IDelugeTorrent
+  f "DP" = IPropagateDataClient
+  f "EB" = IEBit
+  f "ES" = IElectricSheep
+  f "FT" = IFoxTorrent
+  f "GS" = IGSTorrent
+  f "HL" = IHalite
+  f "HS" = IlibHSbittorrent
+  f "HN" = IHydranode
+  f "KG" = IKGet
+  f "KT" = IKTorrent
+  f "LH" = ILH_ABC
+  f "LP" = ILphant
+  f "LT" = ILibtorrent
+  f "lt" = ILibTorrent
+  f "LW" = ILimeWire
+  f "MO" = IMonoTorrent
+  f "MP" = IMooPolice
+  f "MR" = IMiro
+  f "ML" = IMLdonkey
+  f "MT" = IMoonlightTorrent
+  f "NX" = INetTransport
+  f "PD" = IPando
+  f "qB" = IqBittorrent
+  f "QD" = IQQDownload
+  f "QT" = IQt4TorrentExample
+  f "RT" = IRetriever
+  f "S~" = IShareaza
+  f "SB" = ISwiftbit
+  f "SS" = ISwarmScope
+  f "ST" = ISymTorrent
+  f "st" = Isharktorrent
+  f "SZ" = IShareaza
+  f "TN" = ITorrentDotNET
+  f "TR" = ITransmission
+  f "TS" = ITorrentstorm
+  f "TT" = ITuoTu
+  f "UL" = IuLeecher
+  f "UT" = IuTorrent
+  f "VG" = IVagaa
+  f "WT" = IBitLet
+  f "WY" = IFireTorrent
+  f "XL" = IXunlei
+  f "XT" = IXanTorrent
+  f "XX" = IXtorrent
+  f "ZT" = IZipTorrent
+  f _    = IUnknown
+
+-- | Used to represent a not recognized implementation
+instance Default Software where
+  def = IUnknown
+  {-# INLINE def #-}
+
+-- | Example: @\"BitLet\" == 'IBitLet'@
+instance IsString Software where
+  fromString str
+    | Just impl <- L.lookup str alist = impl
+    | otherwise = error $ "fromString: not recognized " ++ str
+    where
+      alist = L.map mk [minBound..maxBound]
+      mk  x = (L.tail $ show x, x)
+
+-- | Example: @pPrint 'IBitLet' == \"IBitLet\"@
+instance Pretty Software where
+  pPrint = text . L.tail . show
+
+-- | Just the '0' version.
+instance Default Version where
+  def = Version [0] []
+  {-# INLINE def #-}
+
+-- | For dot delimited version strings.
+--   Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@
+--
+instance IsString Version where
+  fromString str
+    | Just nums <- chunkNums str = Version nums []
+    | otherwise = error $ "fromString: invalid version string " ++ str
+    where
+      chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==)
+
+instance Pretty Version where
+  pPrint = text . showVersion
+
+-- | The all sensible infomation that can be obtained from a peer
+-- identifier or torrent /createdBy/ field.
+data Fingerprint = Fingerprint Software Version
+  deriving (Show, Eq, Ord)
+
+-- | Unrecognized client implementation.
+instance Default Fingerprint where
+  def = Fingerprint def def
+  {-# INLINE def #-}
+
+-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
+instance IsString Fingerprint where
+  fromString str
+    | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver)
+    | otherwise = error $ "fromString: invalid client info string" ++ str
+    where
+      (impl, _ver) = L.span ((/=) '-') str
+
+instance Pretty Fingerprint where
+  pPrint (Fingerprint s v) = pPrint s <+> "version" <+> pPrint v
+
+-- | Fingerprint of this (the bittorrent library) package. Normally,
+-- applications should introduce its own fingerprints, otherwise they
+-- can use 'libFingerprint' value.
+--
+libFingerprint :: Fingerprint
+libFingerprint =  Fingerprint IlibHSbittorrent version
+
+-- | HTTP user agent of this (the bittorrent library) package. Can be
+-- used in HTTP tracker requests.
+libUserAgent :: String
+libUserAgent = render (pPrint IlibHSbittorrent <> "/" <> pPrint version)
+
+{-----------------------------------------------------------------------
+--  For torrent file
+-----------------------------------------------------------------------}
+-- TODO collect information about createdBy torrent field
+-- renderImpl :: ClientImpl -> Text
+-- renderImpl = T.pack . L.tail . show
+--
+-- renderVersion :: Version -> Text
+-- renderVersion = undefined
+--
+-- renderClientInfo :: ClientInfo -> Text
+-- renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
+--
+-- parseClientInfo :: Text -> ClientImpl
+-- parseClientInfo t = undefined
+
+
+-- code used for generation; remove it later on
+--
+-- mkEnumTyDef :: NM -> String
+-- mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
+--
+-- mkPars :: NM -> String
+-- mkPars = unlines . map (\(code, impl) -> "  f \"" ++ code ++ "\" = " ++ "I" ++ impl)
+--
+-- type NM = [(String, String)]
+-- nameMap :: NM
+-- nameMap =
+--  [ ("AG", "Ares")
+--  , ("A~", "Ares")
+--  , ("AR", "Arctic")
+--  , ("AV", "Avicora")
+--  , ("AX", "BitPump")
+--  , ("AZ", "Azureus")
+--  , ("BB", "BitBuddy")
+--  , ("BC", "BitComet")
+--  , ("BF", "Bitflu")
+--  , ("BG", "BTG")
+--  , ("BR", "BitRocket")
+--  , ("BS", "BTSlave")
+--  , ("BX", "BittorrentX")
+--  , ("CD", "EnhancedCTorrent")
+--  , ("CT", "CTorrent")
+--  , ("DE", "DelugeTorrent")
+--  , ("DP", "PropagateDataClient")
+--  , ("EB", "EBit")
+--  , ("ES", "ElectricSheep")
+--  , ("FT", "FoxTorrent")
+--  , ("GS", "GSTorrent")
+--  , ("HL", "Halite")
+--  , ("HS", "libHSnetwork_bittorrent")
+--  , ("HN", "Hydranode")
+--  , ("KG", "KGet")
+--  , ("KT", "KTorrent")
+--  , ("LH", "LH_ABC")
+--  , ("LP", "Lphant")
+--  , ("LT", "Libtorrent")
+--  , ("lt", "LibTorrent")
+--  , ("LW", "LimeWire")
+--  , ("MO", "MonoTorrent")
+--  , ("MP", "MooPolice")
+--  , ("MR", "Miro")
+--  , ("MT", "MoonlightTorrent")
+--  , ("NX", "NetTransport")
+--  , ("PD", "Pando")
+--  , ("qB", "qBittorrent")
+--  , ("QD", "QQDownload")
+--  , ("QT", "Qt4TorrentExample")
+--  , ("RT", "Retriever")
+--  , ("S~", "Shareaza")
+--  , ("SB", "Swiftbit")
+--  , ("SS", "SwarmScope")
+--  , ("ST", "SymTorrent")
+--  , ("st", "sharktorrent")
+--  , ("SZ", "Shareaza")
+--  , ("TN", "TorrentDotNET")
+--  , ("TR", "Transmission")
+--  , ("TS", "Torrentstorm")
+--  , ("TT", "TuoTu")
+--  , ("UL", "uLeecher")
+--  , ("UT", "uTorrent")
+--  , ("VG", "Vagaa")
+--  , ("WT", "BitLet")
+--  , ("WY", "FireTorrent")
+--  , ("XL", "Xunlei")
+--  , ("XT", "XanTorrent")
+--  , ("XX", "Xtorrent")
+--  , ("ZT", "ZipTorrent")
+--  ]
+
+-- TODO use regexps
+
+-- | Tries to extract meaningful information from peer ID bytes. If
+-- peer id uses unknown coding style then client info returned is
+-- 'def'.
+--
+fingerprint :: PeerId -> Fingerprint
+fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid)
+  where
+    getCI    = do
+      leading <- BS.w2c <$> getWord8
+      case leading of
+        '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion
+        'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion
+        'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
+        'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
+        c   -> do
+          c1 <- w2c <$> S.lookAhead getWord8
+          if c1 == 'P'
+            then do
+                 _ <- getWord8
+                 Fingerprint <$> pure IOpera            <*> getOperaVersion
+            else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion
+
+    getMainlineVersion = do
+      str <- BC.unpack <$> getByteString 7
+      let mnums = L.filter (not . L.null) $ L.linesBy ('-' ==) str
+      return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) []
+
+    getAzureusImpl    = parseSoftware <$> getByteString 2
+    getAzureusVersion = mkVer         <$> getByteString 4
+      where
+        mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] []
+
+    getBitCometImpl = do
+      bs <- getByteString 3
+      S.lookAhead $ do
+        _  <- getByteString 2
+        lr <- getByteString 4
+        return $
+          if lr == "LORD" then IBitLord  else
+          if bs == "UTB"  then IBitComet else
+          if bs == "xbc"  then IBitComet else def
+
+    getBitCometVersion = do
+      x <- getWord8
+      y <- getWord8
+      return $ Version [fromIntegral x, fromIntegral y] []
+
+    getOperaVersion = do
+      str <- BC.unpack <$> getByteString 4
+      return $ Version [fromMaybe 0 $ readMaybe str] []
+
+    getShadowImpl 'A' = IABC
+    getShadowImpl 'O' = IOspreyPermaseed
+    getShadowImpl 'Q' = IBTQueue
+    getShadowImpl 'R' = ITribler
+    getShadowImpl 'S' = IShadow
+    getShadowImpl 'T' = IBitTornado
+    getShadowImpl  _  = IUnknown
+
+    decodeShadowVerNr :: Char -> Maybe Int
+    decodeShadowVerNr c
+      | '0' < c && c <= '9' = Just  (fromEnum c - fromEnum '0')
+      | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10)
+      | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36)
+      |        otherwise    = Nothing
+
+    getShadowVersion = do
+      str <- BC.unpack <$> getByteString 5
+      return $ Version (catMaybes $ L.map decodeShadowVerNr str) []
+
+
+-- | Yields all 8 DHT neighborhoods available to you given a particular ip
+-- address.
+bep42s :: Address a => a -> NodeId -> [NodeId]
+bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs
+ where
+    rs = L.map (NodeId . change3bits r) [0..7]
+
+change3bits :: ByteString -> Word8 -> ByteString
+change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n)
+
+-- | Modifies a purely random 'NodeId' to one that is related to a given
+-- routable address in accordance with BEP 42.
+bep42 :: Address a => a -> NodeId -> Maybe NodeId
+bep42 addr (NodeId r)
+ | Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4)
+              <|> fmap S.encode (fromAddr addr :: Maybe IPv6)
+    = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0)
+ | otherwise
+    = Nothing
+ where
+    ip4mask = "\x03\x0f\x3f\xff" :: ByteString
+    ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
+    nbhood_select = BS.last r .&. 7
+    retr n = pure $ BS.drop (BS.length r - n) r
+    crc = S.encode . crc32c . BS.pack
+    applyMask ip = case BS.zipWith (.&.) msk ip of
+                    (b:bs) -> (b .|. shiftL nbhood_select 5) : bs
+                    bs     -> bs
+        where msk | BS.length ip == 4  =  ip4mask
+                  | otherwise          =  ip6mask