path: root/network-addr/src/Network/Address.hs

-- |
--   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            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# OPTIONS -fno-warn-orphans           #-}
module Network.Address
       ( -- * Address
         Address (..)
       , fromAddr
       , PortNumber
       , SockAddr

         -- ** IP
       , IPv4
       , IPv6
       , IP (..)
       , un4map
       , WantIP (..)
       , ipFamily
       , is4mapped
       , either4or6

         -- * PeerId
         -- $peer-id
       , PeerId

         -- ** Generation
       , genPeerId
       , timestamp
       , entropy

         -- ** Encoding
       , azureusStyle
       , shadowStyle
       , defaultClientId
       , defaultVersionNumber

         -- * PeerAddr
         -- $peer-addr
       , PeerAddr(..)
       , defaultPorts
       , peerSockAddr
       , peerSocket

         -- * Node
       , NodeAddr (..)

         -- ** Id
       , testIdBit
       , bucketRange
       , genBucketSample
       , genBucketSample'

         -- * Fingerprint
         -- $fingerprint
       , Software (..)
       , Fingerprint (..)
       , libFingerprint
       , fingerprint

         -- * Utils
       , libUserAgent
       , sockAddrPort
       , setPort
       , getBindAddress
       , localhost4
       , localhost6
       , nullAddress4
       , linesBy
       ) 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
#if MIN_VERSION_iproute(1,7,4)
import Data.IP hiding (fromSockAddr)
#else
import Data.IP
#endif
import Data.List as L
import Data.Maybe       (fromMaybe, catMaybes)
import Data.Monoid
import Data.Hashable
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 DPut
import DebugTag

-- 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 #-}

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

data NodeAddr a = NodeAddr
  { nodeHost ::                !a
  , nodePort :: {-# UNPACK #-} !PortNumber
  } deriving (Eq, Ord, 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 = RP.readP_to_S $ do
    ipv4 <- RP.readS_to_P (readsPrec i)
    _    <- RP.char ':'
    port <- toEnum <$> RP.readS_to_P (readsPrec i)
    return $ NodeAddr ipv4 port

-- | @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 #-}

-- | Example:
--
--   @nodePort \"127.0.0.1:6881\" == 6881@
--
instance IsString (NodeAddr IPv4) where
  fromString str
    | (hostAddrStr, portStr0) <- L.break (== ':') str
    , let portStr = L.drop 1 portStr0
    , Just hostAddr <- readMaybe hostAddrStr
    , Just portNum  <- toEnum <$> readMaybe portStr
                = NodeAddr hostAddr portNum
    | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str


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



instance Address PeerAddr 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 address info normally extracted from peer list or peer
-- compact list encoding.
data PeerAddr = PeerAddr
  { peerId   :: !(Maybe PeerId)

    -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved
    -- 'HostName'.
  , peerHost :: !IP

    -- | The port the peer listenning for incoming P2P sessions.
  , peerPort :: {-# UNPACK #-} !PortNumber
  } deriving (Show, Eq, Ord, Typeable)

#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 BEncode PeerAddr 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>
--
-- WARNING: Input must be exactly 6 or 18 bytes so that we can identify IP version.
--
instance Serialize PeerAddr where
  put PeerAddr {..} = put peerHost >> put peerPort
  get = do
    cnt <- remaining
    PeerAddr Nothing <$> isolate (cnt - 2) get <*> get

-- | @127.0.0.1:6881@
instance Default PeerAddr where
  def = "127.0.0.1:6881"

-- | Example:
--
--   @peerPort \"127.0.0.1:6881\" == 6881@
--
instance IsString PeerAddr where
  fromString str
    | (hostAddrStr, portStr0) <- L.break (== ':') str
    , let portStr = L.drop 1 portStr0
    , Just hostAddr <- readMaybe hostAddrStr
    , Just portNum  <- toEnum <$> readMaybe portStr
                = PeerAddr Nothing (IPv4 hostAddr) portNum
    | [((ip,port),"")] <- readsIPv6_port str =
        PeerAddr Nothing (IPv6 ip) port
    | otherwise = error $ "fromString: unable to parse IP: " ++ str

instance Read PeerAddr where
  readsPrec i = RP.readP_to_S $ do
    ip <-     IPv4 <$> ( RP.readS_to_P (readsPrec i)                         )
          <|> IPv6 <$> ( RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' )
    _    <- RP.char ':'
    port <- toEnum <$> RP.readS_to_P (readsPrec i)
    return $ PeerAddr Nothing ip 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)


-- | fingerprint + "at" + dotted.host.inet.addr:port
instance Pretty PeerAddr where
  pPrint PeerAddr {..}
    | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr
    |     otherwise      = paddr
    where
      paddr = pPrint peerHost <> ":" <> text (show peerPort)

instance Hashable PeerAddr where
  hashWithSalt s PeerAddr {..} =
    s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort

-- | Ports typically reserved for bittorrent P2P listener.
defaultPorts :: [PortNumber]
defaultPorts =  [6881..6889]

_peerSockAddr :: PeerAddr -> (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 -> SockAddr
peerSockAddr = snd . _peerSockAddr

-- | Create a socket connected to the address specified in a peerAddr
peerSocket :: SocketType -> PeerAddr -> 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 - 1 - fromIntegral i))
{-# INLINE testIdBit #-}

-- | 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 :: ( FiniteBits nid
                   , Serialize nid
                   ) => nid -> (Int,Word8,Word8) -> IO nid
genBucketSample n qmb = genBucketSample' getEntropy n qmb

-- | Generalizion of 'genBucketSample' that accepts a byte generator
-- function to use instead of the system entropy.
genBucketSample' :: forall m dht nid.
                    ( Applicative m
                    , FiniteBits nid
                    , Serialize nid
                    ) =>
    (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid
genBucketSample' gen self (q,m,b)
    | q <= 0           =  either error id . S.decode <$> gen nodeIdSize
    | q >= nodeIdSize  =  pure self
    | otherwise        =  either error id . S.decode .  build <$> gen (nodeIdSize - q + 1)
 where
    nodeIdSize = finiteBitSize (undefined :: nid) `div` 8

    -- Prepends q bytes to modified input:
    --   applies mask m
    --   toggles bit b
    build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
     where
        hd = BS.take q $ S.encode self
        h = xor b (complement m .&. BS.last hd)
        t = m .&. BS.head tl


------------------------------------------------------------------------

-- | 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


instance Hashable PortNumber where
  hashWithSalt s = hashWithSalt s . fromEnum
  {-# INLINE hashWithSalt #-}

instance Pretty PortNumber where
  pPrint = PP.int . fromEnum
  {-# INLINE pPrint #-}

instance Serialize PortNumber where
  get = fromIntegral <$> getWord16be
  {-# INLINE get #-}
  put = putWord16be . fromIntegral
  {-# INLINE put #-}

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 #-}


-- | 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 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



------------------------------------------------------------------------

{-----------------------------------------------------------------------
-- 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 #-}

dropLastIf :: (a -> Bool) -> [a] -> [a]
dropLastIf pred []                 =  []
dropLastIf pred (x:xs)             =  init' x xs
  where init' y [] | pred y = []
        init' y []          = [y]
        init' y (z:zs)      = y : init' z zs

linesBy :: (a -> Bool) -> [a] -> [[a]]
linesBy pred ys = dropLastIf L.null $ L.map dropDelim $ L.groupBy (\_ x -> not $ pred x) ys
 where
    dropDelim []                 = []
    dropDelim (x:xs) | pred x    = xs
                     | otherwise = x:xs

-- | 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 . 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) $ 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.
getBindAddress :: String -> Bool -> IO SockAddr
getBindAddress bindspec enabled6 = do
    let (host,listenPortString) = case L.break (==':') (L.reverse bindspec) of
            (rport,':':rhost) -> (Just $ L.reverse rhost, L.reverse rport)
            _                 -> (Nothing, bindspec)
    -- Bind addresses for localhost
    xs <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE] }))
                      host
                      (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 (0,0,0,0){-iN6ADDR_ANY-} 0
                  else SockAddrInet (parsePort listenPortString) 0{-iNADDR_ANY-}
                    where parsePort s = fromMaybe 0 $ readMaybe s
    dput XMisc $ "Listening on " ++ show listenAddr
    return listenAddr

-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96
-- as defined in RFC 4291.
is4mapped :: IPv6 -> Bool
is4mapped ip
    | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip
                = True
    | otherwise = False

un4map :: IPv6 -> Maybe IPv4
un4map ip
    | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip
                = Just $ toIPv4
                       $ L.map (.&. 0xFF)
                               [x `shiftR` 8, x, y `shiftR` 8, y ]
    | otherwise = Nothing

ipFamily :: IP -> WantIP
ipFamily ip = case ip of
    IPv4 _               -> Want_IP4
    IPv6 a | is4mapped a -> Want_IP4
           | otherwise   -> Want_IP6

either4or6 :: SockAddr -> Either SockAddr SockAddr
either4or6 a4@(SockAddrInet port addr)         = Left a4
either4or6 a6@(SockAddrInet6 port _ addr _)
    | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4)
    | otherwise                                = Right a6

data WantIP = Want_IP4 | Want_IP6 | Want_Both
 deriving (Eq, Enum, Ord, Show)

localhost6 :: SockAddr
localhost6 = SockAddrInet6 0 0 (0,0,0,1) 0 -- [::1]:0

localhost4 :: SockAddr
localhost4 = SockAddrInet 0 16777343 -- 127.0.0.1:0

nullAddress4 :: SockAddr
nullAddress4 = SockAddrInet 0 0 -- 0.0.0.0:0