Merge branch 'dev' of https://github.com/DanielG/bittorrent

10 files changed, 81 insertions, 284 deletions

diff --git a/.gitmodules b/.gitmodules
index d90db85e..21868293 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -4,3 +4,6 @@
 [submodule "sub/krpc"]
         path = sub/krpc
         url = git://github.com/pxqr/krpc.git
+[submodule "sub/hspec"]
+        path = sub/hspec
+        url = https://github.com/DanielG/hspec.git
diff --git a/TODO.org b/TODO.org
index 7fcb95c3..4c8fc619 100644
--- a/TODO.org
+++ b/TODO.org
@@ -1,5 +1,8 @@
-* DONE version 0.0.0.1
-* TODO torrent linting for indexing
-* TODO move PeerClient to Data.Torrent.Client
-* TODO Word64 for Progress fields
-* TODO rename TConnection -> Connection, etc
+* TODO Rename Ext,Extension -> Cap
+* TODO Use System.IO instead of Network.recv/send
+  The functions in System.IO use GHC/base's built in support for epoll/kqueue
+  and the like which makes them a whole lot more efficient for file descriptor
+  I/O. Network.recv/send on the other hand just use a plain FFI call to
+  recvmsg/sendmsg which will block the whole OS thread.
+
+** TODO Compare performance of the two
diff --git a/bittorrent.cabal b/bittorrent.cabal
index 4cb9fce7..9c7dc2c6 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -157,8 +157,9 @@ test-suite spec
   default-extensions:  OverloadedStrings
   type:                exitcode-stdio-1.0
   hs-source-dirs:      tests
-  main-is:             Spec.hs
-  other-modules:       Data.Torrent.BitfieldSpec
+  main-is:             Main.hs
+  other-modules:       Spec
+                       Data.Torrent.BitfieldSpec
                        Data.Torrent.InfoHashSpec
                        Data.Torrent.LayoutSpec
                        Data.Torrent.MagnetSpec
@@ -202,6 +203,7 @@ test-suite spec
                      , quickcheck-instances
                      , http-types
                      , bencoding
+                     , process
                      , bittorrent
   ghc-options:         -Wall -fno-warn-orphans
 
diff --git a/res/testfile b/res/testfile
new file mode 100644
index 00000000..8e984818
--- /dev/null
+++ b/res/testfile
diff --git a/res/testfile.torrent b/res/testfile.torrent
new file mode 100644
index 00000000..a03f7780
--- /dev/null
+++ b/res/testfile.torrent
@@ -0,0 +1 @@
+d8:announce44:udp://tracker.openbittorrent.com:80/announce10:created by26:Enhanced-CTorrent/dnh3.3.213:creation datei1387753787e4:infod6:lengthi8192e4:name8:testfile12:piece lengthi262144e6:pieces20:
œd•Dú—uÈÔtÝ®aÿöK³2ee
\ No newline at end of file
diff --git a/src/Network/BitTorrent/Core/PeerAddr.hs b/src/Network/BitTorrent/Core/PeerAddr.hs
index 63ae04b9..b9d4878e 100644
--- a/src/Network/BitTorrent/Core/PeerAddr.hs
+++ b/src/Network/BitTorrent/Core/PeerAddr.hs
@@ -133,6 +133,20 @@ instance BEncode IPv6 where
   fromBEncode = ipFromBEncode
   {-# INLINE fromBEncode #-}
 
+instance Serialize IP where
+    put (IPv4 ip) = put ip
+    put (IPv6 ip) = put ip
+
+    -- | 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
+    get = do
+      n <- remaining
+      case n of
+        4  -> IPv4 <$> get
+        16 -> IPv6 <$> get
+        _ -> fail "Wrong number of bytes remaining to parse IP"
+
 instance Serialize IPv4 where
     put = putWord32host    .  toHostAddress
     get = fromHostAddress <$> getWord32host
diff --git a/src/Network/BitTorrent/Exchange/Wire.hs b/src/Network/BitTorrent/Exchange/Wire.hs
index 109f6551..c0658961 100644
--- a/src/Network/BitTorrent/Exchange/Wire.hs
+++ b/src/Network/BitTorrent/Exchange/Wire.hs
@@ -432,8 +432,9 @@ data Connection = Connection
     -- future.
     connProtocol     :: !ProtocolName
 
-    -- | A set of enabled extensions. This value used to check if a
-    -- message is allowed to be sent or received.
+    -- | Set of enabled core extensions, i.e. the pre BEP10 extension
+    -- mecahnism. This value is used to check if a message is allowed to be sent
+    -- or received.
   , connCaps         :: !Caps
 
     -- | /Both/ peers handshaked with this infohash. A connection can
@@ -450,9 +451,9 @@ data Connection = Connection
     -- |
   , connOptions      :: !Options
 
-    -- | If @not (allowed ExtExtended connCaps)@ then this set is
-    -- always empty. Otherwise it has extension protocol 'MessageId'
-    -- map.
+    -- | If @not (allowed ExtExtended connCaps)@ then this set is always
+    -- empty. Otherwise it has the BEP10 extension protocol mandated mapping of
+    -- 'MessageId' to the message type for the remote peer.
   , connExtCaps      :: !(IORef ExtendedCaps)
 
     -- | Current extended handshake information from the remote peer
@@ -632,9 +633,9 @@ rehandshake caps = undefined
 reconnect :: Wire ()
 reconnect = undefined
 
--- | Initiate 'Wire' connection and handshake with a peer. This
--- function will also do extension protocol handshake if 'ExtExtended'
--- is enabled on both sides.
+-- | Initiate 'Wire' connection and handshake with a peer. This function will
+-- also do the BEP10 extension protocol handshake if 'ExtExtended' is enabled on
+-- both sides.
 --
 -- This function can throw 'WireFailure' exception.
 --
@@ -643,20 +644,19 @@ connectWire hs addr extCaps wire =
   bracket (connectToPeer addr) close $ \ sock -> do
     hs' <- initiateHandshake sock hs
 
-    unless (def           == hsProtocol hs') $ do
-      throwIO $ ProtocolError $ InvalidProtocol (hsProtocol hs')
-
-    unless (hsProtocol hs == hsProtocol hs') $ do
-      throwIO $ ProtocolError $ UnexpectedProtocol (hsProtocol hs')
-
-    unless (hsInfoHash hs == hsInfoHash hs') $ do
-      throwIO $ ProtocolError $ UnexpectedTopic (hsInfoHash hs')
-
-    unless (hsPeerId hs' == fromMaybe (hsPeerId hs') (peerId addr)) $ do
-      throwIO $ ProtocolError $ UnexpectedPeerId (hsPeerId hs')
+    Prelude.mapM_ (\(t,e) -> unless t $ throwIO $ ProtocolError e) [
+      (def == hsProtocol hs'
+      , InvalidProtocol $ hsProtocol hs'),
+      (hsProtocol hs == hsProtocol hs'
+      , UnexpectedProtocol $ hsProtocol hs'),
+      (hsInfoHash hs == hsInfoHash hs'
+      , UnexpectedTopic $ hsInfoHash hs'),
+      (hsPeerId hs' == fromMaybe (hsPeerId hs') (peerId addr)
+      , UnexpectedPeerId $ hsPeerId hs')
+      ]
 
     let caps = hsReserved hs <> hsReserved hs'
-    let wire' = if ExtExtended `allowed` caps
+        wire' = if ExtExtended `allowed` caps
                 then extendedHandshake extCaps >> wire
                 else wire
 
diff --git a/sub/hspec b/sub/hspec
new file mode 160000
+Subproject 6b5bf6fe8bc59909c5b7346f6f70fdfe643d115
diff --git a/tests/Main.hs b/tests/Main.hs
index 3c58e2ed..66283339 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,260 +1,34 @@
--- |
---   Copyright   :  (c) Sam Truzjan 2013
---   License     :  BSD3
---   Maintainer  :  pxqr.sta@gmail.com
---   Stability   :  experimental
---   Portability :  portable
---
---   Do not add other (than this) test suites without need. Do not use
---   linux-specific paths, use 'filepath' and 'directory' machinery.
---
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings          #-}
-module Main (main) where
-
-import Control.Applicative hiding (empty)
-import           Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as Lazy
-import Data.List as L
+module Main where
+
+import Spec
+import System.Exit
+import System.Environment
+import System.Process
+import Control.Exception
+import Data.List
 import Data.Maybe
-import Data.Word
-import Data.Serialize as S
-import Data.Text as T
-
-import Network
-import Network.URI
-
-import Test.QuickCheck as QC
-import Test.Framework as Framework (Test, defaultMain)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-
-import Data.Aeson as JSON
-import Data.BEncode as BE
-import Data.Torrent.Block
-import Data.Torrent.Bitfield as BF
-import Data.Torrent.Metainfo
-import Network.BitTorrent.Exchange.Protocol
-import Network.BitTorrent.Tracker
-import Network.BitTorrent.Tracker.Protocol
-import Network.BitTorrent.Tracker.HTTP
-import Network.BitTorrent.Peer
-
--- import Debug.Trace
-
-
-data T a = T
-
-
-prop_properBEncode :: Show a => BEncodable a => Eq a => T a -> a -> Bool
-prop_properBEncode _ expected = actual == Right expected
-  where
-    actual = decoded $ Lazy.toStrict $ encoded expected
-
-instance Arbitrary URI where
-  arbitrary = pure $ fromJust
-              $ parseURI "http://exsample.com:80/123365_asd"
-
-instance Arbitrary Text where
-  arbitrary = T.pack <$> arbitrary
-
-{-
-{-----------------------------------------------------------------------
-    MemMap
------------------------------------------------------------------------}
-
-tmpdir :: FilePath
-tmpdir = "tmp"
-
-boundaryTest :: Assertion
-boundaryTest = do
-  f <- mallocTo (Fixed.interval 0 1) Fixed.empty
-  f <- mallocTo (Fixed.interval 1 2) f
-  writeElem f 0 (1 :: Word8)
-  writeElem f 1 (2 :: Word8)
-  bs <- readBytes (Fixed.interval 0 2) f
-  "\x1\x2" @=? bs
-
-mmapSingle :: Assertion
-mmapSingle = do
-  f  <- mmapTo (tmpdir </> "single.test") (10, 5) 5 Fixed.empty
-  writeBytes (Fixed.interval 5 5) "abcde" f
-  bs <- readBytes (Fixed.interval 5 5) f
-  "abcde" @=? bs
-
-coalesceTest :: Assertion
-coalesceTest = do
-  f <- mmapTo (tmpdir </> "a.test")  (0, 1) 10 Fixed.empty
-  f <- mmapTo (tmpdir </> "bc.test") (0, 2) 12 f
-  f <- mmapTo (tmpdir </> "c.test")  (0, 1) 13 f
-  writeBytes (Fixed.interval 10 4) "abcd" f
-  bs <- readBytes  (Fixed.interval 10 4) f
-  "abcd" @=? bs
--}
-
-{-----------------------------------------------------------------------
-    Bitfield
------------------------------------------------------------------------}
--- other properties are tested in IntervalSet
-
-prop_completenessRange :: Bitfield -> Bool
-prop_completenessRange bf = 0 <= c && c <= 1
-  where
-    c = completeness bf
-
-prop_minMax :: Bitfield -> Bool
-prop_minMax bf
-  | BF.null bf = True
-  | otherwise  = BF.findMin bf <= BF.findMax bf
-
-prop_rarestInRange :: [Bitfield] -> Bool
-prop_rarestInRange xs = case rarest xs of
-  Just r  -> 0 <= r
-          && r < totalCount (maximumBy (comparing totalCount) xs)
-  Nothing -> True
-
-{- this one should give pretty good coverage -}
-prop_differenceDeMorgan :: Bitfield -> Bitfield -> Bitfield -> Bool
-prop_differenceDeMorgan a b c =
-  (a `BF.difference` (b `BF.intersection` c))
-     == ((a `BF.difference` b) `BF.union` (a `BF.difference` c))
-  &&
-  (a `BF.difference` (b `BF.union` c))
-     == ((a `BF.difference` b) `BF.intersection` (a `BF.difference` c))
-
-              {-
-  [ -- mem map
-    testCase "boudary"  boundaryTest
-  , testCase "single"   mmapSingle
-  , testCase "coalesce" coalesceTest
-  ]
-
-instance Arbitrary Bitfield where
-  arbitrary = mkBitfield <$> (succ . min 1000 <$> positive)
-                         <*> arbitrary
-
-    testProperty "completeness range"      prop_completenessRange
-  , testProperty "rarest in range"         prop_rarestInRange
-  , testProperty "min less that max"       prop_minMax
-  , testProperty "difference de morgan"    prop_differenceDeMorgan
--}
-{-----------------------------------------------------------------------
-    Handshake
------------------------------------------------------------------------}
-
-instance Arbitrary PeerId where
-  arbitrary = azureusStyle <$> pure defaultClientId
-                           <*> arbitrary
-                           <*> arbitrary
-
-instance Arbitrary InfoHash where
-  arbitrary = (hash . B.pack) <$> arbitrary
-
-instance Arbitrary Handshake where
-  arbitrary = defaultHandshake <$> arbitrary <*> arbitrary
-
-prop_cerealEncoding :: (Serialize a, Eq a) => T a -> [a] -> Bool
-prop_cerealEncoding _ msgs = S.decode (S.encode msgs) == Right msgs
-
-{-----------------------------------------------------------------------
-    Tracker/Scrape
------------------------------------------------------------------------}
-
-instance Arbitrary ScrapeInfo where
-  arbitrary = ScrapeInfo <$> arbitrary <*> arbitrary
-                         <*> arbitrary <*> arbitrary
-
--- | Note that in 6 esample we intensionally do not agree with
--- specification, because taking in account '/' in query parameter
--- seems to be meaningless.  (And thats because other clients do not
--- chunk uri by parts) Moreover in practice there should be no
--- difference. (I think so)
---
-test_scrape_url :: [Framework.Test]
-test_scrape_url = L.zipWith mkTest [1 :: Int ..] (check `L.map` tests)
-  where
-    check (iu, ou) = (parseURI iu >>= (`scrapeURL` [])
-                      >>= return . show) == ou
-    tests =
-      [ (      "http://example.com/announce"
-        , Just "http://example.com/scrape")
-      , (      "http://example.com/x/announce"
-        , Just "http://example.com/x/scrape")
-      , (      "http://example.com/announce.php"
-        , Just "http://example.com/scrape.php")
-      , (      "http://example.com/a"    , Nothing)
-      , (      "http://example.com/announce?x2%0644"
-        , Just "http://example.com/scrape?x2%0644")
-      , (      "http://example.com/announce?x=2/4"
-        , Just "http://example.com/scrape?x=2/4")
---      , ("http://example.com/announce?x=2/4"  , Nothing) -- by specs
-      , ("http://example.com/x%064announce"   , Nothing)
-      ]
-
-    mkTest i = testProperty ("scrape test #" ++ show i)
-
-{-----------------------------------------------------------------------
-    P2P/message
------------------------------------------------------------------------}
-
-positive :: Gen Int
-positive = fromIntegral <$> (arbitrary :: Gen Word32)
-
-instance Arbitrary ByteString where
-  arbitrary = B.pack <$> arbitrary
-
-instance Arbitrary Lazy.ByteString where
-  arbitrary = Lazy.pack <$> arbitrary
-
-instance Arbitrary BlockIx where
-  arbitrary = BlockIx <$> positive <*> positive <*> positive
-
-instance Arbitrary Block where
-  arbitrary = Block <$> positive <*> positive <*> arbitrary
-
-instance Arbitrary PortNumber where
-  arbitrary = fromIntegral <$> (arbitrary :: Gen Word16)
-
-instance Arbitrary Message where
-  arbitrary = oneof
-    [ pure KeepAlive
-    , pure Choke
-    , pure Unchoke
-    , pure Interested
-    , pure NotInterested
-    , Have     <$> positive
-    , pure $ Bitfield $ BF.haveNone 0
-    , Request  <$> arbitrary
-    , Piece    <$> arbitrary
-    , Cancel   <$> arbitrary
-    , Port     <$> arbitrary
-    ]
--- todo add all messages
-
-prop_messageEncoding :: Message -> Bool
-prop_messageEncoding msg @ (Bitfield bf)
-  = case S.decode (S.encode msg) of
-      Right (Bitfield bf') -> bf == adjustSize (totalCount bf) bf'
-      _   -> False
-prop_messageEncoding msg
-  = S.decode (S.encode msg) == Right msg
-
-{-----------------------------------------------------------------------
-    Main
------------------------------------------------------------------------}
+import Data.Functor
 
-allTests :: [Framework.Test]
-allTests =
-  [ -- handshake module
-    testProperty "handshake encoding" $
-      prop_cerealEncoding  (T :: T Handshake)
-  , testProperty "message encoding" prop_messageEncoding
-  ] ++ test_scrape_url
-    ++
-  [ testProperty "scrape bencode" $
-      prop_properBEncode (T :: T ScrapeInfo)
-  ]
+clients :: [(String, String)]
+clients = [
+ ("rtorrent","rtorrent -p 51234-51234 res/testfile.torrent") ]
 
 main :: IO ()
-main = defaultMain allTests
+main = do
+  args <- getArgs
+  let cmd' = do
+        cl <- listToMaybe $ reverse
+                   $ map (tail . dropWhile (/='='))
+                   $ filter (isPrefixOf "--bittorrent-client=") args
+        cmd <- (++) "screen -dm -S bittorrent-testsuite " <$> lookup cl clients
+        return cmd
+  case cmd' of
+    Just cmd -> do _ <- system "screen -S bittorrent-testsuite -X quit"
+                   createProcess (shell cmd) >> return ()
+    Nothing -> return ()
+
+  let args' = (filter (not . isPrefixOf "--bittorrent-client=") args)
+  code <- catch (withArgs args' hspecMain >> return ExitSuccess) return
+
+  _ <- system "screen -S bittorrent-testsuite -X quit"
+  exitWith code >> return ()
diff --git a/tests/Spec.hs b/tests/Spec.hs
index 52ef578f..8d2b5139 100644
--- a/tests/Spec.hs
+++ b/tests/Spec.hs
@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
\ No newline at end of file
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --hook-main #-}