blob: 204d1656a5f56d5dd779e861cffdf6089aba38f2 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
{-# LANGUAGE RecordWildCards #-}
module Main where
import Control.Exception
import Control.Monad
import Data.Functor
import Data.Maybe
import System.Exit
import System.Environment
import System.Process
import System.Directory
import Text.Printf
import Test.Hspec
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\n" client (show (fst <$> clients))
return Nothing
| otherwise = do
_ <- printf "Running without remote client\n"
return (Just ())
terminateEnv :: IO ()
terminateEnv = do
_ <- printf "closing screen session: %s\n" sessionName
_ <- system (printf "screen -S %s -X quit" sessionName)
return ()
runTestSuite :: [String] -> IO ExitCode
runTestSuite args = do
_ <- printf "running hspec test suite with args: %s\n" (show args)
catch (withArgs args (hspec spec) >> return ExitSuccess) return
main :: IO ()
main = do
(envOpts, suiteArgs) <- getOpts
running <- setupEnv envOpts
code <- runTestSuite suiteArgs
when (isJust running) $ do
terminateEnv
exitWith code
|
