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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
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)
|
