1 files changed, 205 insertions, 0 deletions

diff --git a/src/Network/BitTorrent/PeerID.hs b/src/Network/BitTorrent/PeerID.hs
new file mode 100644
index 00000000..cef1fa58
--- /dev/null
+++ b/src/Network/BitTorrent/PeerID.hs
@@ -0,0 +1,205 @@
+-- TODO: tests
+-- |
+--   Copyright   :  (c) Sam T. 2013
+--   License     :  MIT
+--   Maintainer  :  pxqr.sta@gmail.com
+--   Stability   :  experimental
+--   Portability :  non-portable
+--
+--   This module provides 'Peer' and 'PeerID' datatypes and all related
+--   operations.
+--   Recommended method for generation of the peer ID's is 'newPeerID',
+--   though this module exports some other goodies for custom generation.
+--
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
+module Network.BitTorrent.PeerID
+       ( -- * Peer addr
+         Peer(..)
+       , peerSockAddr, connectToPeer
+
+         -- * Peer identification
+       , PeerID (getPeerID)
+
+         -- ** Encoding styles
+       , azureusStyle, shadowStyle
+
+         -- ** Defaults
+       , defaultClientID, defaultVersionNumber
+
+         -- ** Generation
+       , newPeerID, timestampByteString
+         -- ** Extra
+
+       , byteStringPadded
+       ) where
+
+import Control.Applicative
+import Data.Word
+import Data.Bits
+import Data.BEncode
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Builder as B
+import Data.Foldable    (foldMap)
+import Data.Monoid      ((<>))
+import Data.Serialize
+import Data.URLEncoded
+import Data.Version     (Version(Version), versionBranch)
+import Data.Time.Clock  (getCurrentTime)
+import Data.Time.Format (formatTime)
+import System.Locale    (defaultTimeLocale)
+import Network
+import Network.Socket
+
+
+-- TODO we have linker error here, so manual hardcoded version for a while.
+-- import Paths_network_bittorrent (version)
+version :: Version
+version = Version [0, 10, 0, 0] []
+
+
+
+data Peer = Peer {
+      peerID   :: Maybe PeerID
+    , peerIP   :: HostAddress
+    , peerPort :: PortNumber
+    } deriving Show
+
+-- TODO make platform independent, clarify htonl
+-- | Convert peer info from tracker response to socket address.
+--   Used for establish connection between peers.
+--
+peerSockAddr :: Peer -> SockAddr
+peerSockAddr = SockAddrInet <$> (g . peerPort) <*> (htonl . peerIP)
+  where
+    htonl :: Word32 -> Word32
+    htonl d =
+       ((d .&. 0xff) `shiftL` 24) .|.
+       (((d `shiftR` 8 ) .&. 0xff) `shiftL` 16) .|.
+       (((d `shiftR` 16) .&. 0xff) `shiftL` 8)  .|.
+       ((d `shiftR` 24) .&. 0xff)
+
+    g :: PortNumber -> PortNumber
+    g = id
+
+-- ipv6 extension
+-- | Tries to connect to peer using reasonable default parameters.
+--
+connectToPeer :: Peer -> IO Socket
+connectToPeer p = do
+  sock <- socket AF_INET Stream Network.Socket.defaultProtocol
+  connect sock (peerSockAddr p)
+  return sock
+
+
+-- | Peer identifier is exactly 20 bytes long bytestring.
+newtype PeerID = PeerID { getPeerID :: ByteString }
+                 deriving (Show, Eq, Ord, BEncodable)
+
+instance Serialize PeerID where
+  put = putByteString . getPeerID
+  get = PeerID <$> getBytes 20
+
+instance URLShow PeerID where
+  urlShow = BC.unpack . getPeerID
+
+
+-- | 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 $ B.toLazyByteString $
+    B.char8 '-' <>
+      byteStringPadded cid 2  'H' <>
+      byteStringPadded ver 4  'X' <>
+    B.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 $ B.toLazyByteString $
+    B.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.
+defaultVersionNumber :: ByteString
+defaultVersionNumber = B.take 4 (BC.pack (foldMap show (versionBranch version)))
+
+-- | Gives 15 characters long decimal timestamp such that:
+--
+--     * 6 bytes   : first 6 characters from picoseconds obtained with %q.
+--
+--     * 1 bytes   : 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) and more or less random.
+--
+timestampByteString :: IO ByteString
+timestampByteString = (BC.pack . format) <$> getCurrentTime
+  where
+    format t = take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
+               take 9 (reverse (formatTime defaultTimeLocale "%s" t))
+
+-- |  Here we use Azureus-style encoding with the following args:
+--
+--      * 'HS' for the client id.
+--
+--      * Version of the package for the version number
+--
+--      * UTC time day ++ day time for the random number.
+--
+newPeerID :: IO PeerID
+newPeerID = azureusStyle defaultClientID defaultVersionNumber
+                                     <$> timestampByteString
+
+-- | 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.
+                 -> B.Builder
+byteStringPadded bs s c =
+      B.byteString (B.take s bs) <>
+      B.byteString (BC.replicate padLen c)
+  where
+    padLen = s - min (B.length bs) s
\ No newline at end of file