Add test suite configuration

3 files changed, 217 insertions, 28 deletions

diff --git a/bittorrent.cabal b/bittorrent.cabal
index 0ccc5d97..e6a6db93 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -181,6 +181,8 @@ test-suite spec
   hs-source-dirs:      tests
   main-is:             Main.hs
   other-modules:       Spec
+                       Config
+
                        Data.Torrent.BitfieldSpec
                        Data.Torrent.InfoHashSpec
                        Data.Torrent.LayoutSpec
diff --git a/tests/Config.hs b/tests/Config.hs
new file mode 100644
index 00000000..3dc254a8
--- /dev/null
+++ b/tests/Config.hs
@@ -0,0 +1,148 @@
+{-# LANGUAGE RecordWildCards #-}
+module Config
+       ( -- * Types
+         ClientName
+       , ClientOpts (..)
+       , EnvOpts (..)
+
+         -- * For test suite driver
+       , getOpts
+
+         -- * For item specs
+       , getEnvOpts
+       , getThisOpts
+       , getRemoteOpts
+       , withRemote
+       ) where
+
+import Control.Monad
+import Network
+import Data.Default
+import Data.IORef
+import Data.List as L
+import Data.Maybe
+import Options.Applicative
+import System.Exit
+import System.Environment
+import System.IO.Unsafe
+import Test.Hspec
+
+type ClientName = String
+
+
+instance Read PortNumber where
+  readsPrec = undefined
+
+data ClientOpts = ClientOpts
+  { peerPort   :: PortNumber  -- tcp port
+  , nodePort   :: PortNumber  -- udp port
+  }
+
+instance Default ClientOpts where
+  def = ClientOpts
+    { peerPort = 6881
+    , nodePort = 6881
+    }
+
+defRemoteOpts :: ClientOpts
+defRemoteOpts = def
+
+defThisOpts :: ClientOpts
+defThisOpts = def
+  { peerPort = 6882
+  , nodePort = 6882
+  }
+
+clientOptsParser :: Parser ClientOpts
+clientOptsParser = ClientOpts
+  <$> option
+    ( long    "peer-port"  <> short 'p'
+   <> value   6881         <> showDefault
+   <> metavar "NUM"
+   <> help    "port to bind the specified bittorrent client"
+    )
+  <*> option
+    ( long    "node-port"  <> short 'n'
+   <> value   6881         <> showDefault
+   <> metavar "NUM"
+   <> help    "port to bind node of the specified client"
+    )
+
+data EnvOpts = EnvOpts
+  { testClient :: Maybe ClientName
+  , remoteOpts :: ClientOpts
+  , thisOpts   :: ClientOpts
+  }
+
+instance Default EnvOpts where
+  def = EnvOpts
+    { testClient = Nothing
+    , remoteOpts = defRemoteOpts
+    , thisOpts   = defThisOpts
+    }
+
+findConflicts :: EnvOpts -> [String]
+findConflicts EnvOpts {..}
+  | isNothing testClient = []
+  | peerPort remoteOpts == peerPort thisOpts = ["Peer port the same"]
+  | nodePort remoteOpts == nodePort thisOpts = ["Node port the same"]
+  |         otherwise        = []
+
+
+envOptsParser :: Parser EnvOpts
+envOptsParser = EnvOpts
+  <$> optional (strOption
+    ( long    "bittorrent-client"
+   <> metavar "CLIENT"
+   <> help    "torrent client to run"
+    ))
+  <*> clientOptsParser
+  <*> clientOptsParser
+
+envOptsInfo :: ParserInfo EnvOpts
+envOptsInfo = info (helper <*> envOptsParser)
+   ( fullDesc
+  <> progDesc "The bittorrent library testsuite"
+  <> header   ""
+   )
+
+-- do not modify this while test suite is running because spec items
+-- can run in parallel
+envOptsRef :: IORef EnvOpts
+envOptsRef = unsafePerformIO (newIORef def)
+
+-- | Should be used from spec items.
+getEnvOpts :: IO EnvOpts
+getEnvOpts = readIORef envOptsRef
+
+getThisOpts :: IO ClientOpts
+getThisOpts = thisOpts <$> getEnvOpts
+
+-- | Return 'Nothing' if remote client is not running.
+getRemoteOpts :: IO (Maybe ClientOpts)
+getRemoteOpts = return Nothing
+
+withRemote :: (ClientOpts -> Expectation) -> Expectation
+withRemote action = do
+  mopts <- getRemoteOpts
+  case mopts of
+    Nothing   -> pendingWith "Remote client isn't running"
+    Just opts -> action opts
+
+-- TODO fix EnvOpts parsing
+
+-- | Should be used by test suite driver.
+getOpts :: IO (EnvOpts, [String])
+getOpts = do
+  args <- getArgs
+--  case runParser SkipOpts envOptsParser args) (prefs idm) of
+  case (Right (def, args), ()) of
+    (Left   err                , _ctx) -> exitFailure
+    (Right (envOpts, hspecOpts), _ctx) -> do
+      let conflicts = findConflicts envOpts
+      unless (L.null conflicts) $ do
+        forM_ conflicts putStrLn
+        exitFailure
+
+      writeIORef envOptsRef envOpts
+      return (envOpts, hspecOpts)
\ No newline at end of file
diff --git a/tests/Main.hs b/tests/Main.hs
index 63281cf3..6577e6f4 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -1,37 +1,76 @@
+{-# LANGUAGE RecordWildCards #-}
 module Main where
-
-import Spec
+import Control.Exception
+import Control.Monad
+import Data.Functor
+import Data.List
+import Data.Maybe
 import System.Exit
 import System.Environment
 import System.Process
 import System.Directory
-import Control.Exception
-import Data.List
-import Data.Maybe
-import Data.Functor
+import Text.Printf
+
+import Config
+import Spec
+
+
+type Command = String
+type Descr = (ClientName, ClientOpts -> FilePath -> Command)
+
+torrents :: [FilePath]
+torrents =
+    [ "dapper-dvd-amd64-iso.torrent"
+    , "pkg.torrent"
+    , "testfile.torrent"
+    ]
+
+clients :: [Descr]
+clients =
+  [ ("rtorrent"
+    , \ ClientOpts {..} tfile -> printf
+     "rtorrent -p %i-%i -O dht=on -O dht_port=%i -O session=rtorrent-sessiondir %s"
+     (fromEnum peerPort) (fromEnum peerPort) (fromEnum nodePort) tfile
+    )
+  ]
+
+sessionName :: String -- screen session name
+sessionName = "bittorrent-testsuite"
+
+setupEnv :: EnvOpts -> IO (Maybe ())
+setupEnv EnvOpts {..}
+  | Just client <- testClient
+  , Just mkCmd  <- lookup client clients = do
+    let runner = printf "screen -dm -S %s %s" sessionName
+                 (mkCmd remoteOpts "testfile.torrent")
+    dir <- getCurrentDirectory
+    _   <- createProcess (shell runner) { cwd = Just (dir ++ "/res") }
+    return (Just ())
+
+  | Just client <- testClient = do
+    printf "Bad client `%s`, use one of %s" client (show (fst <$> clients))
+    return Nothing
+
+  | isNothing testClient = do
+    printf "Running without remote client"
+    return (Just ())
+
+terminateEnv :: IO ()
+terminateEnv = do
+  printf "closing screen session: %s" sessionName
+  _ <- system (printf "screen -S %s -X quit" sessionName)
+  return ()
 
-clients :: [(String, String)]
-clients = [
- ("rtorrent","rtorrent -p 51234-51234 -O dht=on -O dht_port=6881 -O session=rtorrent-sessiondir testfile.torrent") ]
+runTestSuite :: [String] -> IO ExitCode
+runTestSuite args = do
+  printf "running hspec test suite with args: %s\n" (show args)
+  catch (withArgs args hspecMain >> return ExitSuccess) return
 
 main :: IO ()
 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"
-                   dir <- getCurrentDirectory
-                   _ <- createProcess (shell cmd) { cwd = Just (dir ++ "/res") }
-                   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 ()
+  (envOpts, suiteArgs) <- getOpts
+  running <- setupEnv     envOpts
+  code    <- runTestSuite suiteArgs
+  when (isJust running) $ do
+    terminateEnv
+  exitWith code