Rename Network.BitTorrent.Address -> Network.Address

1 files changed, 1051 insertions, 0 deletions

diff --git a/src/Network/Address.hs b/src/Network/Address.hs
new file mode 100644
index 00000000..19bf29d6
--- /dev/null
+++ b/src/Network/Address.hs
@@ -0,0 +1,1051 @@
+-- |
+--   Module      :  Network.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 FlexibleContexts           #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE ViewPatterns               #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveFoldable             #-}
+{-# LANGUAGE DeriveTraversable          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# OPTIONS -fno-warn-orphans           #-}
+module Network.Address
+       ( -- * Address
+         Address (..)
+       , fromAddr
+       , PortNumber
+       , SockAddr
+
+         -- ** 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
+       , testIdBit
+       , genNodeId
+       , bucketRange
+       , genBucketSample
+
+         -- ** Info
+       , NodeAddr (..)
+       , NodeInfo (..)
+       , mapAddress
+       , traverseAddress
+       , rank
+
+         -- * Fingerprint
+         -- $fingerprint
+       , Software (..)
+       , Fingerprint (..)
+       , libFingerprint
+       , fingerprint
+
+         -- * Utils
+       , libUserAgent
+       , sockAddrPort
+       , getBindAddress
+       ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Exception (onException)
+#ifdef VERSION_bencoding
+import Data.BEncode as BE
+import Data.BEncode.BDict (BKey)
+#endif
+import Data.Bits
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BS
+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 Network.DatagramServer.Types as RPC
+-- import Network.DHT.Mainline
+
+-- import Paths_bittorrent (version)
+
+instance Pretty UTCTime where
+  pPrint = PP.text . show
+
+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 #-}
+
+-- | Obtains the port associated with a socket address
+-- if one is associated with it.
+sockAddrPort :: SockAddr -> Maybe PortNumber
+sockAddrPort (SockAddrInet  p   _  ) = Just p
+sockAddrPort (SockAddrInet6 p _ _ _) = Just p
+sockAddrPort _                       = Nothing
+{-# INLINE sockAddrPort #-}
+
+instance Address a => Address (NodeAddr a) where
+  toSockAddr NodeAddr {..} = setPort nodePort $ toSockAddr nodeHost
+  fromSockAddr sa = NodeAddr <$> fromSockAddr sa <*> sockAddrPort sa
+
+instance Address a => Address (PeerAddr a) where
+  toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost
+  fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> sockAddrPort 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, Typeable
+#ifdef VERSION_bencoding
+           , BEncode
+#endif
+           )
+
+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
+-----------------------------------------------------------------------}
+
+#ifdef VERSION_bencoding
+instance BEncode PortNumber where
+  toBEncode   = toBEncode    .  fromEnum
+  fromBEncode = fromBEncode >=> portNumber
+    where
+      portNumber :: Integer -> BE.Result PortNumber
+      portNumber n
+        | 0 <= n && n <= fromIntegral (maxBound :: Word16)
+        = pure $ fromIntegral n
+        | otherwise = decodingError $ "PortNumber: " ++ show n
+#endif
+{-----------------------------------------------------------------------
+--  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
+
+#ifdef VERSION_bencoding
+ipToBEncode :: Show i => i -> BValue
+ipToBEncode ip = BString $ BS8.pack $ show ip
+{-# INLINE ipToBEncode #-}
+
+ipFromBEncode :: Read a => BValue -> BE.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 #-}
+#endif
+
+{-----------------------------------------------------------------------
+--  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)
+
+#ifdef VERSION_bencoding
+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
+#endif
+
+-- | 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.
+
+-- asNodeId :: ByteString -> NodeId
+-- asNodeId bs = NodeId $ BS.take nodeIdSize bs
+
+{-
+
+-- | 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
+-}
+
+testIdBit :: FiniteBits bs => bs -> Word -> Bool
+testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - fromIntegral i))
+{-# INLINE testIdBit #-}
+
+------------------------------------------------------------------------
+
+-- | 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)
+
+------------------------------------------------------------------------
+
+#ifdef VERSION_bencoding
+-- | 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 #-}
+#endif
+
+fromPeerAddr :: PeerAddr a -> NodeAddr a
+fromPeerAddr PeerAddr {..} = NodeAddr
+  { nodeHost = peerHost
+  , nodePort = peerPort
+  }
+
+------------------------------------------------------------------------
+
+-- | Order by closeness: nearest nodes first.
+rank :: ( Ord (NodeId dht)
+        , Bits (NodeId dht)
+        ) => (x -> NodeId dht) -> NodeId dht -> [x] -> [x]
+rank f nid = L.sortBy (comparing (RPC.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 <- BS.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) []
+
+
+
+-- | Given a string specifying a port (numeric or service name)
+-- and a flag indicating whether you want to support IPv6, this
+-- function will return a SockAddr to bind to.  If the input
+-- is not understood as a port number, zero will be set in order
+-- to ask the system for an unused port.
+--
+-- TODO: Also interpret local ip address specifications in the input
+-- string.
+getBindAddress :: String -> Bool -> IO SockAddr
+getBindAddress listenPortString enabled6 = do
+    -- Bind addresses for localhost
+    xs <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE] }))
+                      Nothing
+                      (Just listenPortString)
+            `onException` return []
+    -- We prefer IPv6 because that can also handle connections from IPv4
+    -- clients...
+    let (x6s,x4s) = partition (\s -> addrFamily s == AF_INET6) xs
+        listenAddr =
+          case if enabled6 then x6s++x4s else x4s of
+            AddrInfo { addrAddress = addr } : _ -> addr
+            _ -> if enabled6
+                  then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0
+                  else SockAddrInet (parsePort listenPortString) iNADDR_ANY
+                    where parsePort s = fromMaybe 0 $ readMaybe s
+    return listenAddr