summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--bittorrent.cabal1
-rw-r--r--src/Data/Torrent/Client.hs29
-rw-r--r--tests/Data/Torrent/ClientSpec.hs6
3 files changed, 32 insertions, 4 deletions
diff --git a/bittorrent.cabal b/bittorrent.cabal
index 846b5b16..3c9c0d38 100644
--- a/bittorrent.cabal
+++ b/bittorrent.cabal
@@ -98,6 +98,7 @@ library
98 , data-default 98 , data-default
99 , IntervalMap 99 , IntervalMap
100 , intset 100 , intset
101 , split
101 , text >= 0.11.0 102 , text >= 0.11.0
102 , unordered-containers 103 , unordered-containers
103 , vector 104 , vector
diff --git a/src/Data/Torrent/Client.hs b/src/Data/Torrent/Client.hs
index a7e94513..f38f7a5c 100644
--- a/src/Data/Torrent/Client.hs
+++ b/src/Data/Torrent/Client.hs
@@ -34,10 +34,14 @@ import Data.ByteString as BS
34import Data.ByteString.Char8 as BC 34import Data.ByteString.Char8 as BC
35import Data.Default 35import Data.Default
36import Data.List as L 36import Data.List as L
37import Data.List.Split as L
38import Data.Maybe
37import Data.Monoid 39import Data.Monoid
40import Data.String
38import Data.Text as T 41import Data.Text as T
39import Data.Version 42import Data.Version
40import Text.PrettyPrint hiding ((<>)) 43import Text.PrettyPrint hiding ((<>))
44import Text.Read (readMaybe)
41import Paths_bittorrent (version) 45import Paths_bittorrent (version)
42 46
43 47
@@ -111,6 +115,15 @@ data ClientImpl =
111-- | Used to represent a not recognized implementation 115-- | Used to represent a not recognized implementation
112instance Default ClientImpl where 116instance Default ClientImpl where
113 def = IUnknown 117 def = IUnknown
118 {-# INLINE def #-}
119
120instance IsString ClientImpl where
121 fromString str
122 | Just impl <- L.lookup str alist = impl
123 | otherwise = error $ "fromString: not recognized " ++ str
124 where
125 alist = L.map mk [minBound..maxBound]
126 mk x = (L.tail $ show x, x)
114 127
115-- | Format client implementation info in human-readable form. 128-- | Format client implementation info in human-readable form.
116ppClientImpl :: ClientImpl -> Doc 129ppClientImpl :: ClientImpl -> Doc
@@ -119,6 +132,14 @@ ppClientImpl = text . L.tail . show
119-- | Just the '0' version. 132-- | Just the '0' version.
120instance Default Version where 133instance Default Version where
121 def = Version [0] [] 134 def = Version [0] []
135 {-# INLINE def #-}
136
137instance IsString Version where
138 fromString str
139 | Just nums <- chunkNums str = Version nums []
140 | otherwise = error $ "fromString: invalid version string " ++ str
141 where
142 chunkNums = sequence . L.map readMaybe . L.linesBy ('.' ==)
122 143
123-- | Format client implementation version in human-readable form. 144-- | Format client implementation version in human-readable form.
124ppVersion :: Version -> Doc 145ppVersion :: Version -> Doc
@@ -134,6 +155,14 @@ data ClientInfo = ClientInfo {
134-- | Unrecognized client implementation. 155-- | Unrecognized client implementation.
135instance Default ClientInfo where 156instance Default ClientInfo where
136 def = ClientInfo def def 157 def = ClientInfo def def
158 {-# INLINE def #-}
159
160instance IsString ClientInfo where
161 fromString str
162 | _ : ver <- _ver = ClientInfo (fromString impl) (fromString ver)
163 | otherwise = error $ "fromString: invalid client info string" ++ str
164 where
165 (impl, _ver) = L.span ((/=) '-') str
137 166
138-- | Format client info in human-readable form. 167-- | Format client info in human-readable form.
139ppClientInfo :: ClientInfo -> Doc 168ppClientInfo :: ClientInfo -> Doc
diff --git a/tests/Data/Torrent/ClientSpec.hs b/tests/Data/Torrent/ClientSpec.hs
index 85ace5e0..890ee95e 100644
--- a/tests/Data/Torrent/ClientSpec.hs
+++ b/tests/Data/Torrent/ClientSpec.hs
@@ -10,7 +10,5 @@ spec :: Spec
10spec = do 10spec = do
11 describe "client info" $ do 11 describe "client info" $ do
12 it "decode azureus encoded peer id" $ do 12 it "decode azureus encoded peer id" $ do
13 clientInfo "-AZ2060-xxxxxxxxxxxx" `shouldBe` 13 clientInfo "-AZ2060-xxxxxxxxxxxx" `shouldBe` "Azureus-2060"
14 ClientInfo IAzureus (Version [2060] []) 14 clientInfo "-BS0000-xxxxxxxxxxxx" `shouldBe` "BTSlave-0"
15 clientInfo "-BS0000-xxxxxxxxxxxx" `shouldBe`
16 ClientInfo IBTSlave (Version [0] [])