summaryrefslogtreecommitdiff
path: root/src/Data
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /src/Data
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'src/Data')
-rw-r--r--src/Data/BEncode/Pretty.hs81
-rw-r--r--src/Data/Bits/ByteString.hs132
-rw-r--r--src/Data/Digest/CRC32C.hs100
-rw-r--r--src/Data/IntervalSet.hs129
-rw-r--r--src/Data/MinMaxPSQ.hs112
-rw-r--r--src/Data/PacketBuffer.hs148
-rw-r--r--src/Data/PacketQueue.hs217
-rw-r--r--src/Data/Sized.hs14
-rw-r--r--src/Data/TableMethods.hs105
-rw-r--r--src/Data/Torrent.hs1347
-rw-r--r--src/Data/Tox/Message.hs84
-rw-r--r--src/Data/Tox/Msg.hs311
-rw-r--r--src/Data/Tox/Onion.hs1029
-rw-r--r--src/Data/Tox/Relay.hs232
-rw-r--r--src/Data/Word64Map.hs66
-rw-r--r--src/Data/Wrapper/PSQ.hs91
-rw-r--r--src/Data/Wrapper/PSQInt.hs53
17 files changed, 0 insertions, 4251 deletions
diff --git a/src/Data/BEncode/Pretty.hs b/src/Data/BEncode/Pretty.hs
deleted file mode 100644
index 8beb101b..00000000
--- a/src/Data/BEncode/Pretty.hs
+++ /dev/null
@@ -1,81 +0,0 @@
1{-# LANGUAGE CPP #-}
2module Data.BEncode.Pretty where -- (showBEncode) where
3
4import Data.BEncode.Types
5import qualified Data.ByteString as BS
6import qualified Data.ByteString.Lazy as BL
7import Data.Text (Text)
8import qualified Data.Text as T
9import Data.Text.Encoding
10import qualified Data.ByteString.Base16 as Base16
11#ifdef BENCODE_AESON
12import Data.BEncode.BDict hiding (map)
13import Data.Aeson.Types hiding (parse)
14import Data.Aeson.Encode.Pretty
15import qualified Data.HashMap.Strict as HashMap
16import qualified Data.Vector as Vector
17import Data.Foldable as Foldable
18#endif
19
20{-
21unhex :: Text -> BS.ByteString
22unhex t = BS.pack $ map unhex1 [0 .. BS.length nibs `div` 2]
23 where
24 nibs = encodeUtf8 t
25 unhex1 i = unnib (BS.index nibs (i * 2)) * 0x10
26 + unnib (BS.index nibs (i * 2 + 1))
27 unnib a | a <= 0x39 = a - 0x30
28 | otherwise = a - (0x41 - 10)
29
30hex :: BS.ByteString -> Text
31hex bs = T.concat $ map (T.pack . printf "%02X") $ BS.unpack bs
32-}
33
34#ifdef BENCODE_AESON
35
36quote_chr :: Char
37quote_chr = ' '
38
39quote :: Text -> Text
40quote t = quote_chr `T.cons` t `T.snoc` quote_chr
41
42encodeByteString :: BS.ByteString -> Text
43encodeByteString s = either (const . decodeUtf8 $ Base16.encode s) quote $ decodeUtf8' s
44
45decodeByteString :: Text -> BS.ByteString
46decodeByteString s
47 | T.head s==quote_chr = encodeUtf8 (T.takeWhile (/=quote_chr) $ T.drop 1 s)
48 | otherwise = fst (Base16.decode (encodeUtf8 s))
49
50instance ToJSON BValue where
51 toJSON (BInteger x) = Number $ fromIntegral x
52 toJSON (BString s) = String $ encodeByteString s
53 toJSON (BList xs) = Array $ Vector.fromList $ map toJSON xs
54 toJSON (BDict d) = toJSON d
55
56instance ToJSON a => ToJSON (BDictMap a) where
57 toJSON d = Object $ HashMap.fromList $ map convert $ toAscList d
58 where
59 convert (k,v) = (encodeByteString k,toJSON v)
60
61instance FromJSON BValue where
62 parseJSON (Number x) = pure $ BInteger (truncate x)
63 parseJSON (Bool x) = pure $ BInteger $ if x then 1 else 0
64 parseJSON (String s) = pure $ BString $ decodeByteString s
65 parseJSON (Array v) = BList <$> traverse parseJSON (Foldable.toList v)
66 parseJSON (Object d) = BDict <$> parseJSON (Object d)
67 parseJSON (Null) = pure $ BDict Nil
68
69instance FromJSON v => FromJSON (BDictMap v) where
70 parseJSON (Object d) = fromAscList <$> traverse convert (HashMap.toList d)
71 where
72 convert (k,v) = (,) (decodeByteString k) <$> parseJSON v
73 parseJSON _ = fail "Not a BDict"
74#endif
75
76showBEncode :: BValue -> BL.ByteString
77#ifdef BENCODE_AESON
78showBEncode b = encodePretty $ toJSON b
79#else
80showBEncode b = BL8.pack (show b)
81#endif
diff --git a/src/Data/Bits/ByteString.hs b/src/Data/Bits/ByteString.hs
deleted file mode 100644
index bf0316fd..00000000
--- a/src/Data/Bits/ByteString.hs
+++ /dev/null
@@ -1,132 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3-------------------------------------------------------------------------------
4-- |
5-- Module : Data.Bits.ByteString
6-- Copyright : (c) 2016 Michael Carpenter
7-- License : BSD3
8-- Maintainer : Michael Carpenter <oldmanmike.dev@gmail.com>
9-- Stability : experimental
10-- Portability : portable
11--
12-------------------------------------------------------------------------------
13module Data.Bits.ByteString where
14
15import Data.Bits
16import qualified Data.ByteString as B
17import Data.Word
18
19instance Bits B.ByteString where
20
21 (.&.) a b = B.pack $ B.zipWith (.&.) a b
22 {-# INLINE (.&.) #-}
23
24 (.|.) a b = B.pack $ B.zipWith (.|.) a b
25 {-# INLINE (.|.) #-}
26
27 xor a b = B.pack $ B.zipWith xor a b
28 {-# INLINE xor #-}
29
30 complement = B.map complement
31 {-# INLINE complement #-}
32
33 shift x i
34 | i < 0 = x `shiftR` (-i)
35 | i > 0 = x `shiftL` i
36 | otherwise = x
37 {-# INLINE shift #-}
38
39 shiftR bs 0 = bs
40 shiftR "" _ = B.empty
41 shiftR bs i
42 | i `mod` 8 == 0 =
43 B.take (B.length bs) $ B.append
44 (B.replicate (i `div` 8) 0)
45 (B.drop (i `div` 8) bs)
46 | i `mod` 8 /= 0 =
47 B.pack $ take (B.length bs)
48 $ (replicate (i `div` 8) (0 :: Word8))
49 ++ (go (i `mod` 8) 0 $ B.unpack (B.take (B.length bs - (i `div` 8)) bs))
50 where
51 go _ _ [] = []
52 go j w1 (w2:wst) = (maskR j w1 w2) : go j w2 wst
53 maskR j w1 w2 = (shiftL w1 (8-j)) .|. (shiftR w2 j)
54 shiftR _ _ = error "I can't believe you've done this."
55 {-# INLINE shiftR #-}
56
57 shiftL bs 0 = bs
58 shiftL "" _ = B.empty
59 shiftL bs i
60 | i `mod` 8 == 0 =
61 B.take (B.length bs) $ B.append
62 (B.drop (i `div` 8) bs)
63 (B.replicate (i `div` 8) 0)
64 | i `mod` 8 /= 0 =
65 B.pack $ drop ((i `div` 8) - B.length bs)
66 $ (tail (go (i `mod` 8) 0 $ B.unpack (B.drop (i `div` 8) bs)))
67 ++ (replicate (i `div` 8) 0)
68 where
69 go j w1 [] = [shiftL w1 j]
70 go j w1 (w2:wst) = (maskL j w1 w2) : go j w2 wst
71 maskL j w1 w2 = (shiftL w1 j) .|. (shiftR w2 (8-j))
72 shiftL _ _ = error "I can't believe you've done this."
73 {-# INLINE shiftL #-}
74
75 rotate x i
76 | i < 0 = x `rotateR` (-i)
77 | i > 0 = x `rotateL` i
78 | otherwise = x
79 {-# INLINE rotate #-}
80
81 rotateR bs 0 = bs
82 rotateR bs i
83 | B.length bs == 0 = B.empty
84 | B.length bs == 1 = B.singleton (rotateR (bs `B.index` 0) i)
85 | B.length bs > 1 = do
86 let shiftedWords =
87 B.append
88 (B.drop (nWholeWordsToShift i) bs)
89 (B.take (nWholeWordsToShift i) bs)
90 let tmpShiftedBits = (shiftR shiftedWords (i `mod` 8))
91 let rotatedBits = (shiftL (B.last shiftedWords) (8 - (i `mod` 8))) .|. (B.head tmpShiftedBits)
92 rotatedBits `B.cons` (B.tail tmpShiftedBits)
93 where
94 nWholeWordsToShift n = (B.length bs - (n `div` 8))
95 rotateR _ _ = error "I can't believe you've done this."
96 {-# INLINE rotateR #-}
97
98 rotateL bs 0 = bs
99 rotateL bs i
100 | B.length bs == 0 = B.empty
101 | B.length bs == 1 = B.singleton (rotateL (bs `B.index` 0) i)
102 | i `mod` 8 == 0 = B.append
103 (B.drop (i `div` 8) bs)
104 (B.take (i `div` 8) bs)
105 | B.length bs > 1 = do
106 let shiftedWords =
107 B.append
108 (B.drop (i `div` 8) bs)
109 (B.take (i `div` 8) bs)
110 let tmpShiftedBits = (shiftL shiftedWords (i `mod` 8))
111 let rotatedBits = (shiftR (B.head shiftedWords) (8 - (i `mod` 8))) .|. (B.last tmpShiftedBits)
112 (B.init tmpShiftedBits) `B.snoc` rotatedBits
113 rotateL _ _ = error "I can't believe you've done this."
114 {-# INLINE rotateL #-}
115
116 bitSize x = 8 * B.length x
117 {-# INLINE bitSize #-}
118
119 bitSizeMaybe x = Just (8 * B.length x)
120 {-# INLINE bitSizeMaybe #-}
121
122 isSigned _ = False
123 {-# INLINE isSigned #-}
124
125 testBit x i = testBit (B.index x (B.length x - (i `div` 8) - 1)) (i `mod` 8)
126 {-# INLINE testBit #-}
127
128 bit i = (bit $ mod i 8) `B.cons` (B.replicate (div i 8) (255 :: Word8))
129 {-# INLINE bit #-}
130
131 popCount x = sum $ map popCount $ B.unpack x
132 {-# INLINE popCount #-}
diff --git a/src/Data/Digest/CRC32C.hs b/src/Data/Digest/CRC32C.hs
deleted file mode 100644
index 18c1314f..00000000
--- a/src/Data/Digest/CRC32C.hs
+++ /dev/null
@@ -1,100 +0,0 @@
1module Data.Digest.CRC32C
2 ( crc32c
3 , crc32c_update
4 ) where
5
6import Data.Bits
7import Data.ByteString (ByteString)
8import Data.Word
9import Data.Array.Base (unsafeAt)
10import Data.Array.Unboxed
11
12import qualified Data.ByteString as B
13
14
15crc32c :: ByteString -> Word32
16crc32c = crc32c_update 0
17
18crc32c_update :: Word32 -> ByteString -> Word32
19crc32c_update crc bs = flipd $ step (flipd crc) bs
20 where
21 flipd = xor 0xffffffff
22
23step :: Word32 -> ByteString -> Word32
24step crc bs = B.foldl step' crc bs
25 where
26 step' acc b = let x = table !!! ((acc .&. 0xff) `xor` fromIntegral b)
27 in x `xor` (acc `shiftR` 8)
28{-# INLINEABLE step #-}
29
30(!!!) :: (IArray a e, Ix i, Integral i) => a i e -> i -> e
31arr !!! i = unsafeAt arr $ fromIntegral i
32{-# INLINEABLE (!!!) #-}
33
34table :: UArray Word32 Word32
35table = listArray (0,255) $
36 [ 0x00000000, 0xf26b8303, 0xe13b70f7, 0x1350f3f4
37 , 0xc79a971f, 0x35f1141c, 0x26a1e7e8, 0xd4ca64eb
38 , 0x8ad958cf, 0x78b2dbcc, 0x6be22838, 0x9989ab3b
39 , 0x4d43cfd0, 0xbf284cd3, 0xac78bf27, 0x5e133c24
40 , 0x105ec76f, 0xe235446c, 0xf165b798, 0x030e349b
41 , 0xd7c45070, 0x25afd373, 0x36ff2087, 0xc494a384
42 , 0x9a879fa0, 0x68ec1ca3, 0x7bbcef57, 0x89d76c54
43 , 0x5d1d08bf, 0xaf768bbc, 0xbc267848, 0x4e4dfb4b
44 , 0x20bd8ede, 0xd2d60ddd, 0xc186fe29, 0x33ed7d2a
45 , 0xe72719c1, 0x154c9ac2, 0x061c6936, 0xf477ea35
46 , 0xaa64d611, 0x580f5512, 0x4b5fa6e6, 0xb93425e5
47 , 0x6dfe410e, 0x9f95c20d, 0x8cc531f9, 0x7eaeb2fa
48 , 0x30e349b1, 0xc288cab2, 0xd1d83946, 0x23b3ba45
49 , 0xf779deae, 0x05125dad, 0x1642ae59, 0xe4292d5a
50 , 0xba3a117e, 0x4851927d, 0x5b016189, 0xa96ae28a
51 , 0x7da08661, 0x8fcb0562, 0x9c9bf696, 0x6ef07595
52 , 0x417b1dbc, 0xb3109ebf, 0xa0406d4b, 0x522bee48
53 , 0x86e18aa3, 0x748a09a0, 0x67dafa54, 0x95b17957
54 , 0xcba24573, 0x39c9c670, 0x2a993584, 0xd8f2b687
55 , 0x0c38d26c, 0xfe53516f, 0xed03a29b, 0x1f682198
56 , 0x5125dad3, 0xa34e59d0, 0xb01eaa24, 0x42752927
57 , 0x96bf4dcc, 0x64d4cecf, 0x77843d3b, 0x85efbe38
58 , 0xdbfc821c, 0x2997011f, 0x3ac7f2eb, 0xc8ac71e8
59 , 0x1c661503, 0xee0d9600, 0xfd5d65f4, 0x0f36e6f7
60 , 0x61c69362, 0x93ad1061, 0x80fde395, 0x72966096
61 , 0xa65c047d, 0x5437877e, 0x4767748a, 0xb50cf789
62 , 0xeb1fcbad, 0x197448ae, 0x0a24bb5a, 0xf84f3859
63 , 0x2c855cb2, 0xdeeedfb1, 0xcdbe2c45, 0x3fd5af46
64 , 0x7198540d, 0x83f3d70e, 0x90a324fa, 0x62c8a7f9
65 , 0xb602c312, 0x44694011, 0x5739b3e5, 0xa55230e6
66 , 0xfb410cc2, 0x092a8fc1, 0x1a7a7c35, 0xe811ff36
67 , 0x3cdb9bdd, 0xceb018de, 0xdde0eb2a, 0x2f8b6829
68 , 0x82f63b78, 0x709db87b, 0x63cd4b8f, 0x91a6c88c
69 , 0x456cac67, 0xb7072f64, 0xa457dc90, 0x563c5f93
70 , 0x082f63b7, 0xfa44e0b4, 0xe9141340, 0x1b7f9043
71 , 0xcfb5f4a8, 0x3dde77ab, 0x2e8e845f, 0xdce5075c
72 , 0x92a8fc17, 0x60c37f14, 0x73938ce0, 0x81f80fe3
73 , 0x55326b08, 0xa759e80b, 0xb4091bff, 0x466298fc
74 , 0x1871a4d8, 0xea1a27db, 0xf94ad42f, 0x0b21572c
75 , 0xdfeb33c7, 0x2d80b0c4, 0x3ed04330, 0xccbbc033
76 , 0xa24bb5a6, 0x502036a5, 0x4370c551, 0xb11b4652
77 , 0x65d122b9, 0x97baa1ba, 0x84ea524e, 0x7681d14d
78 , 0x2892ed69, 0xdaf96e6a, 0xc9a99d9e, 0x3bc21e9d
79 , 0xef087a76, 0x1d63f975, 0x0e330a81, 0xfc588982
80 , 0xb21572c9, 0x407ef1ca, 0x532e023e, 0xa145813d
81 , 0x758fe5d6, 0x87e466d5, 0x94b49521, 0x66df1622
82 , 0x38cc2a06, 0xcaa7a905, 0xd9f75af1, 0x2b9cd9f2
83 , 0xff56bd19, 0x0d3d3e1a, 0x1e6dcdee, 0xec064eed
84 , 0xc38d26c4, 0x31e6a5c7, 0x22b65633, 0xd0ddd530
85 , 0x0417b1db, 0xf67c32d8, 0xe52cc12c, 0x1747422f
86 , 0x49547e0b, 0xbb3ffd08, 0xa86f0efc, 0x5a048dff
87 , 0x8ecee914, 0x7ca56a17, 0x6ff599e3, 0x9d9e1ae0
88 , 0xd3d3e1ab, 0x21b862a8, 0x32e8915c, 0xc083125f
89 , 0x144976b4, 0xe622f5b7, 0xf5720643, 0x07198540
90 , 0x590ab964, 0xab613a67, 0xb831c993, 0x4a5a4a90
91 , 0x9e902e7b, 0x6cfbad78, 0x7fab5e8c, 0x8dc0dd8f
92 , 0xe330a81a, 0x115b2b19, 0x020bd8ed, 0xf0605bee
93 , 0x24aa3f05, 0xd6c1bc06, 0xc5914ff2, 0x37faccf1
94 , 0x69e9f0d5, 0x9b8273d6, 0x88d28022, 0x7ab90321
95 , 0xae7367ca, 0x5c18e4c9, 0x4f48173d, 0xbd23943e
96 , 0xf36e6f75, 0x0105ec76, 0x12551f82, 0xe03e9c81
97 , 0x34f4f86a, 0xc69f7b69, 0xd5cf889d, 0x27a40b9e
98 , 0x79b737ba, 0x8bdcb4b9, 0x988c474d, 0x6ae7c44e
99 , 0xbe2da0a5, 0x4c4623a6, 0x5f16d052, 0xad7d5351
100 ]
diff --git a/src/Data/IntervalSet.hs b/src/Data/IntervalSet.hs
deleted file mode 100644
index f1205274..00000000
--- a/src/Data/IntervalSet.hs
+++ /dev/null
@@ -1,129 +0,0 @@
1module Data.IntervalSet
2 ( IntSet
3 , null
4 , empty
5 , insert
6 , delete
7 , interval
8 , toIntervals
9 , nearestOutsider
10 , Data.IntervalSet.lookup
11 ) where
12
13import Prelude hiding (null)
14import qualified Data.IntMap.Strict as IntMap
15 ;import Data.IntMap.Strict (IntMap)
16import qualified Data.List as List
17import Data.Ord
18
19
20-- A set of integers.
21newtype IntSet = IntSet (IntMap Interval)
22 deriving Show
23
24-- Note: the intervalMin is not stored here but is the lookup key in an IntMap.
25data Interval = Interval
26 { intervalMax :: {-# UNPACK #-} !Int -- ^ Maximum value contained in this interval.
27 , intervalNext :: {-# UNPACK #-} !Int -- ^ Minimum value in next interval if there is one.
28 }
29 deriving Show
30
31null :: IntSet -> Bool
32null (IntSet m) = IntMap.null m
33
34empty :: IntSet
35empty = IntSet IntMap.empty
36
37
38insert :: Int -> IntSet -> IntSet
39insert x (IntSet m) = IntSet $ case IntMap.lookupLE x m of
40 Just (lb,Interval mx ub)
41 | x <= mx -> m
42 | otherwise -> case ub == maxBound of
43
44 True | x == mx + 1 -> IntMap.insert lb (Interval x maxBound) m
45 | otherwise -> IntMap.insert lb (Interval mx x)
46 $ IntMap.insert x (Interval x maxBound) m
47
48 False | mx + 2 == ub -> let (Just v', m')
49 = IntMap.updateLookupWithKey (\_ _ -> Nothing) ub m
50 in IntMap.insert lb v' m'
51 | mx + 1 == x -> IntMap.insert lb (Interval x ub) m
52 | otherwise -> IntMap.insert lb (Interval mx x)
53 $ if ub == x + 1
54 then let (Just v', m')
55 = IntMap.updateLookupWithKey
56 (\_ _ -> Nothing) ub m
57 in IntMap.insert x v' m'
58 else IntMap.insert x (Interval x ub) m
59
60 Nothing -> case IntMap.minViewWithKey m of
61
62 Just ((ub,v),m')
63 | x + 1 == ub -> IntMap.insert x v m'
64 | otherwise -> IntMap.insert x (Interval x ub) m
65
66 Nothing -> IntMap.singleton x (Interval x maxBound)
67
68member :: Int -> IntSet -> Bool
69member x (IntSet m) = case IntMap.lookupLE x m of
70 Just (lb,Interval mx _) -> x <= mx
71 Nothing -> False
72
73nearestOutsider :: Int -> IntSet -> Maybe Int
74nearestOutsider x (IntSet m)
75 | List.null xs = Nothing -- There are no integers outside the set!
76 | otherwise = Just $ List.minimumBy (comparing (\y -> abs (x - y))) xs
77 where
78 xs = case IntMap.lookupLE x m of
79 Nothing -> [x]
80 Just (lb,Interval mx ub)
81 -> if ub < maxBound
82 then case () of
83 () | x > mx -> [x]
84 | minBound < lb -> [lb-1, mx+1, ub-1]
85 | otherwise -> [mx+1, ub-1]
86 else case () of
87 () | x > mx -> [x]
88 | minBound < lb && mx < maxBound -> [lb-1, mx+1]
89 | minBound < lb -> [lb-1]
90 | mx < maxBound -> [mx+1]
91 | otherwise -> []
92
93-- Note this could possibly benefit from a intervalPrev field.
94delete :: Int -> IntSet -> IntSet
95delete x (IntSet m) = IntSet $ case IntMap.lookupLE x m of
96 Nothing -> m
97 Just (lb,Interval mx nxt) -> case compare x mx of
98
99 GT -> m
100
101 EQ | lb < mx -> IntMap.insert lb (Interval (mx - 1) nxt) m
102 | otherwise -> case IntMap.lookupLE (x-1) m of -- no intervalPrev
103 Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' nxt)
104 $ IntMap.delete lb m
105 Nothing -> IntMap.delete lb m
106
107 LT -> let m' = IntMap.insert (x+1) (Interval mx nxt) m
108 in if lb < x
109 then IntMap.insert lb (Interval (x - 1) (x+1)) m'
110 else if x == minBound
111 then IntMap.delete minBound m'
112 else case IntMap.lookupLE (x-1) m' of -- no intervalPrev
113 Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' (x+1))
114 $ IntMap.delete lb m'
115 Nothing -> IntMap.delete lb m'
116
117toIntervals :: IntSet -> [(Int,Int)]
118toIntervals (IntSet m) = List.map (\(lb,(Interval mx _)) -> (lb,mx))
119 $ IntMap.toList m
120
121interval :: Int -> Int -> IntSet
122interval lb mx
123 | lb <= mx = IntSet $ IntMap.singleton lb (Interval mx maxBound)
124 | otherwise = IntSet IntMap.empty
125
126lookup :: Int -> IntSet -> Maybe (Int,Int)
127lookup k (IntSet m) = case IntMap.lookupLE k m of
128 Nothing -> Nothing
129 Just (lb,Interval mx _) -> Just (lb,mx)
diff --git a/src/Data/MinMaxPSQ.hs b/src/Data/MinMaxPSQ.hs
deleted file mode 100644
index e7d7c760..00000000
--- a/src/Data/MinMaxPSQ.hs
+++ /dev/null
@@ -1,112 +0,0 @@
1{-# LANGUAGE BangPatterns, PatternSynonyms #-}
2module Data.MinMaxPSQ
3 ( module Data.MinMaxPSQ
4 , Binding'
5 , pattern Binding
6 ) where
7
8import Data.Ord
9import qualified Data.Wrapper.PSQ as PSQ
10 ;import Data.Wrapper.PSQ as PSQ hiding (insert, insert', null, size)
11import Prelude hiding (null, take)
12
13data MinMaxPSQ' k p v = MinMaxPSQ !Int !(PSQ' k p v) !(PSQ' k (Down p) v)
14type MinMaxPSQ k p = MinMaxPSQ' k p ()
15
16empty :: MinMaxPSQ' k p v
17empty = MinMaxPSQ 0 PSQ.empty PSQ.empty
18
19singleton' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v
20singleton' k v p = MinMaxPSQ 1 (PSQ.singleton' k v p) (PSQ.singleton' k v (Down p))
21
22null :: MinMaxPSQ' k p v -> Bool
23null (MinMaxPSQ sz _ _) = sz==0
24{-# INLINE null #-}
25
26size :: MinMaxPSQ' k p v -> Int
27size (MinMaxPSQ sz _ _) = sz
28{-# INLINE size #-}
29
30toList :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> [Binding' k p v]
31toList (MinMaxPSQ _ nq xq) = PSQ.toList nq
32
33fromList :: (PSQKey k, Ord p) => [Binding' k p v] -> MinMaxPSQ' k p v
34fromList kps = let nq = PSQ.fromList kps
35 xq = PSQ.fromList $ map (\(Binding k v p) -> Binding k v (Down p)) kps
36 in MinMaxPSQ (PSQ.size nq) nq xq
37
38findMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v)
39findMin (MinMaxPSQ _ nq xq) = PSQ.findMin nq
40
41findMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v)
42findMax (MinMaxPSQ _ nq xq) = fmap (\(Binding k v (Down p)) -> Binding k v p) $ PSQ.findMin xq
43
44insert :: (PSQKey k, Ord p) => k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p
45insert k p (MinMaxPSQ sz nq xq) = case PSQ.insertView k p () nq of
46 (Just _ ,nq') -> MinMaxPSQ sz nq' (PSQ.insert k (Down p) xq)
47 (Nothing,nq') -> MinMaxPSQ (sz+1) nq' (PSQ.insert k (Down p) xq)
48
49insert' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
50insert' k v p (MinMaxPSQ sz nq xq) = case PSQ.insertView k p v nq of
51 (Just _ ,nq') -> MinMaxPSQ sz nq' (PSQ.insert' k v (Down p) xq)
52 (Nothing,nq') -> MinMaxPSQ (sz+1) nq' (PSQ.insert' k v (Down p) xq)
53
54delete :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
55delete k q@(MinMaxPSQ sz nq xq) = case PSQ.deleteView k nq of
56 Just (_,_,nq') -> MinMaxPSQ (sz - 1) nq' (PSQ.delete k xq)
57 Nothing -> q
58
59deleteMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v
60deleteMin q@(MinMaxPSQ sz nq xq) = case PSQ.minView nq of
61 Just (Binding k _ _, nq') -> MinMaxPSQ (sz - 1) nq' (PSQ.delete k xq)
62 Nothing -> q
63
64deleteMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v
65deleteMax q@(MinMaxPSQ sz nq xq) = case PSQ.minView xq of
66 Just (Binding k _ _, xq') -> MinMaxPSQ (sz - 1) (PSQ.delete k nq) xq'
67 Nothing -> q
68
69minView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v)
70minView (MinMaxPSQ sz nq xq) = fmap (\(Binding k v p, nq') -> (Binding k v p, MinMaxPSQ (sz-1) nq' (PSQ.delete k xq)))
71 $ PSQ.minView nq
72
73maxView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v)
74maxView (MinMaxPSQ sz nq xq) = fmap (\(Binding k v (Down p), xq') -> (Binding k v p, MinMaxPSQ (sz-1) (PSQ.delete k nq) xq'))
75 $ PSQ.minView xq
76
77-- | Maintains a bounded 'MinMaxPSQ' by deleting the maximum element if the
78-- insertion would cause the queue to have too many elements.
79insertTake :: (PSQKey k, Ord p) => Int -> k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p
80insertTake n k p q
81 | size q < n = insert k p q
82 | size q == n = insert k p $ deleteMax q
83 | otherwise = take n $ insert k p q
84
85-- | Maintains a bounded 'MinMaxPSQ\'' by deleting the maximum element if the
86-- insertion would cause the queue to have too many elements.
87insertTake' :: (PSQKey k, Ord p) => Int -> k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
88insertTake' n k v p q
89 | size q < n = insert' k v p q
90 | size q == n = insert' k v p $ deleteMax q
91 | otherwise = take n $ insert' k v p q
92
93
94-- | Truncate the 'MinMaxPSQ' to the given number of lowest priority elements.
95take :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
96take !n !q | (size q <= n) = q
97 | null q = q
98 | otherwise = take n $ deleteMax q
99
100-- | Like 'take', except it provides a list deleted bindings.
101takeView :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> ( [Binding' k p v], MinMaxPSQ' k p v )
102takeView !n !q | (size q <= n) = ([], q)
103 | null q = ([], q)
104 | otherwise = let Just (x,q') = maxView q
105 (xs,q'') = takeView n q'
106 ys = x:xs
107 in (ys, ys `seq` q'')
108
109
110
111lookup' :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> Maybe (p, v)
112lookup' k (MinMaxPSQ _ q _) = PSQ.lookup k q
diff --git a/src/Data/PacketBuffer.hs b/src/Data/PacketBuffer.hs
deleted file mode 100644
index 17745664..00000000
--- a/src/Data/PacketBuffer.hs
+++ /dev/null
@@ -1,148 +0,0 @@
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE DeriveFunctor #-}
3module Data.PacketBuffer
4 ( PacketBuffer
5 , newPacketBuffer
6 , PacketOutboundEvent(..)
7 , PacketInboundEvent(..)
8 , grokOutboundPacket
9 , grokInboundPacket
10 , awaitReadyPacket
11 , packetNumbersToRequest
12 , expectingSequenceNumber
13 , nextToSendSequenceNumber
14 , retrieveForResend
15 , decompressSequenceNumbers
16 , compressSequenceNumbers
17 , pbReport
18 ) where
19
20import Data.PacketQueue as Q
21import DPut
22import DebugTag
23
24import Control.Concurrent.STM
25import Control.Monad
26import Data.Maybe
27import Data.Word
28
29data PacketBuffer a b = PacketBuffer
30 { inQueue :: PacketQueue a
31 , outBuffer :: PacketQueue b }
32
33-- | Initialize the packet buffers. Note, the capacity of the inbound packet
34-- queue is currently hardcoded to 200 packets and the capacity of the outbound
35-- buffer is hardcoded to 400 packets.
36newPacketBuffer :: STM (PacketBuffer a b)
37newPacketBuffer = PacketBuffer <$> Q.new 200 0
38 <*> Q.new 400 0
39
40-- | Input for 'grokPacket'.
41data PacketOutboundEvent b
42 = PacketSent { poSeqNum :: Word32 -- ^ Sequence number for payload.
43 , poSentPayload :: b -- ^ Payload packet we sent to them.
44 }
45 deriving Functor
46
47data PacketInboundEvent a
48 = PacketReceived { peSeqNum :: Word32 -- ^ Sequence number for payload.
49 , peReceivedPayload :: a -- ^ Payload packet they sent to us.
50 , peAcknowledgedNum :: Word32 -- ^ Earliest sequence number they've seen from us.
51 }
52 | PacketReceivedLossy { peSeqNum :: Word32 -- ^ Sequence number for lossy packet.
53 , peReceivedPayload :: a -- ^ Payload packet they sent to us (ignored).
54 , peAcknowledgedNum :: Word32 -- ^ Earliest sequence number they've seen from us.
55 }
56 deriving Functor
57
58-- | Whenever a packet is received or sent (but not resent) from the network,
59-- this function should be called to update the relevant buffers.
60--
61-- On outgoing packets, if the outbound buffer is full, this will return
62-- True. In this case, the caller may retry to enable blocking until
63-- 'grokInboundPacket' is called in another thread.
64grokOutboundPacket :: PacketBuffer a b -> PacketOutboundEvent b -> STM (Bool,(Word32,Word32))
65grokOutboundPacket (PacketBuffer _ outb) (PacketSent seqno a)
66 = do (n,r) <- Q.enqueue outb seqno a
67 return (n/=0,(n,r))
68
69grokInboundPacket :: PacketBuffer a b -> PacketInboundEvent a -> STM ()
70grokInboundPacket (PacketBuffer inb outb) (PacketReceived seqno a ack)
71 = do Q.enqueue inb seqno a
72 Q.dropPacketsBefore outb ack
73grokInboundPacket (PacketBuffer inb outb) (PacketReceivedLossy seqno _ ack)
74 = do Q.observeOutOfBand inb seqno
75 Q.dropPacketsBefore outb ack
76
77-- | Wait until an inbound packet is ready to process. Any necessary
78-- re-ordering will have been done.
79awaitReadyPacket :: PacketBuffer a b -> STM a
80awaitReadyPacket (PacketBuffer inb _) = Q.dequeue inb
81
82-- | Obtain a list of sequence numbers that may have been dropped. This would
83-- be any number not yet received that is prior to the maxium sequence number
84-- we have received. For convenience, a lowerbound for the missing squence numbers
85-- is also returned as the second item of the pair.
86packetNumbersToRequest :: PacketBuffer a b -> STM ([Word32],Word32)
87packetNumbersToRequest (PacketBuffer inb _) = do
88 ns <- Q.getMissing inb
89 lb <- Q.getLastDequeuedPlus1 inb
90 return (ns,lb)
91
92expectingSequenceNumber :: PacketBuffer a b -> STM Word32
93expectingSequenceNumber (PacketBuffer inb _ ) = Q.getLastDequeuedPlus1 inb
94
95nextToSendSequenceNumber :: PacketBuffer a b -> STM Word32
96nextToSendSequenceNumber (PacketBuffer _ outb) = Q.getLastEnqueuedPlus1 outb
97
98-- | Retrieve already-sent packets by their sequence numbers. See
99-- 'decompressSequenceNumbers' to obtain the sequence number list from a
100-- compressed encoding. There is no need to call 'grokPacket' when sending the
101-- packets returned from this call.
102retrieveForResend :: PacketBuffer a b -> [Word32] -> STM [(Word32,b)]
103retrieveForResend (PacketBuffer _ outb) seqnos =
104 catMaybes <$> forM seqnos (\no -> fmap (no,) <$> Q.lookup outb no)
105
106-- | Expand a compressed set of sequence numbers. The first sequence number is
107-- given directly and the rest are computed using 8-bit offsets. This is
108-- normally used to obtain input for 'retrieveForResend'.
109decompressSequenceNumbers :: Word32 -> [Word8] -> [Word32]
110decompressSequenceNumbers baseno ns = foldr doOne (const []) ns (baseno-1)
111 where
112 doOne :: Word8 -> (Word32 -> [Word32]) -> Word32 -> [Word32]
113 doOne 0 f addend = f (addend + 255)
114 doOne x f addend = let y = fromIntegral x + addend
115 in y : f y
116
117compressSequenceNumbers :: Word32 -> [Word32] -> [Word8]
118compressSequenceNumbers baseno xs = foldr doOne (const []) xs (baseno-1)
119 where
120 doOne :: Word32 -> (Word32 -> [Word8]) -> Word32 -> [Word8]
121 doOne y f addend = case y - addend of
122 x | x < 255 -> fromIntegral x : f y
123 | otherwise -> 0 : doOne y f (addend + 255)
124
125{-
126compressSequenceNumbers :: Word32 -> [Word32] -> [Word8]
127compressSequenceNumbers seqno xs = let r = map fromIntegral (reduceToSums ys >>= makeZeroes)
128 in dtrace XNetCrypto ("compressSequenceNumbers " ++ show seqno ++ show xs ++ " --> "++show r) r
129 where
130 ys = Prelude.map (subtract (seqno - 1)) xs
131 reduceToSums [] = []
132 reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs)
133 makeZeroes :: Word32 -> [Word32]
134 -- makeZeroes 0 = []
135 makeZeroes x
136 = let (d,m)= x `divMod` 255
137 zeros= Prelude.replicate (fromIntegral d) 0
138 in zeros ++ [m]
139-}
140
141pbReport :: String -> PacketBuffer a b -> STM String
142pbReport what (PacketBuffer inb outb) = do
143 inb_seqno <- getLastDequeuedPlus1 inb
144 inb_buffend <- getLastEnqueuedPlus1 inb
145 outb_seqno <- getLastDequeuedPlus1 outb
146 outb_bufend <- getLastEnqueuedPlus1 outb
147 return $ "PacketBuffer<"++what++"> Inbound" ++ show (inb_seqno, inb_buffend)
148 ++" Outbound" ++ show (outb_seqno, outb_bufend)
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
deleted file mode 100644
index 15a3b436..00000000
--- a/src/Data/PacketQueue.hs
+++ /dev/null
@@ -1,217 +0,0 @@
1-- | This module is useful for implementing a lossess protocol on top of a
2-- lossy datagram style protocol. It implements a buffer in which packets may
3-- be stored out of order, but from which they are extracted in the proper
4-- sequence.
5{-# LANGUAGE NamedFieldPuns #-}
6module Data.PacketQueue
7 ( PacketQueue
8 , getCapacity
9 , getLastDequeuedPlus1
10 , getLastEnqueuedPlus1
11 , new
12 , dequeue
13 , dropPacketsLogic
14 , dropPacketsBefore
15 , getMissing
16 -- , dequeueOrGetMissing
17 -- , markButNotDequeue
18 , enqueue
19 , observeOutOfBand
20 , packetQueueViewList
21 -- , mapQ
22 , Data.PacketQueue.lookup
23 ) where
24
25import Control.Concurrent.STM
26import Control.Monad
27import Data.Word
28import Data.Array.MArray
29import Data.Maybe
30
31data PacketQueue a = PacketQueue
32 { pktq :: TArray Word32 (Maybe a)
33 , seqno :: TVar Word32 -- (buffer_start)
34 , qsize :: Word32
35 , buffend :: TVar Word32 -- on incoming, next packet they'll send + 1
36 -- i.e. one more than the largest seen sequence number.
37 -- Written by:
38 -- observeOutOfBand
39 -- dropPacketsBefore
40 -- enqueue
41 }
42
43-- | Obtain a list of non-empty slots in the 'PacketQueue'. The numeric value
44-- is an index into the underlying array, not a sequence number.
45packetQueueViewList :: PacketQueue a -> STM [(Word32,a)]
46packetQueueViewList p = do
47 let f (n,Nothing) = Nothing
48 f (n,Just x) = Just (n,x)
49 catMaybes . map f <$> getAssocs (pktq p)
50
51-- | This returns the earliest sequence number with a slot in the queue.
52getLastDequeuedPlus1 :: PacketQueue a -> STM Word32
53getLastDequeuedPlus1 PacketQueue {seqno} = readTVar seqno
54
55-- | This returns the least upper bound of sequence numbers that have been
56-- enqueued.
57getLastEnqueuedPlus1 :: PacketQueue a -> STM Word32
58getLastEnqueuedPlus1 PacketQueue {buffend} = readTVar buffend
59
60
61-- | This is the number of consequetive sequence numbers, starting at
62-- 'getLastDequeuedPlus1' that can be stored in the queue
63getCapacity :: Applicative m => PacketQueue t -> m Word32
64getCapacity (PacketQueue { qsize }) = pure qsize
65
66-- | Create a new PacketQueue.
67new :: Word32 -- ^ Capacity of queue.
68 -> Word32 -- ^ Initial sequence number.
69 -> STM (PacketQueue a)
70new capacity seqstart = do
71 let cap = if capacity `mod` 2 == 0 then capacity else capacity + 1
72 q <- newArray (0,cap - 1) Nothing
73 seqv <- newTVar seqstart
74 bufe <- newTVar seqstart
75 return PacketQueue
76 { pktq = q
77 , seqno = seqv
78 , qsize = cap
79 , buffend = bufe
80 }
81
82-- | Update the packet queue given:
83--
84-- * packet queue
85--
86-- * the number of next lossless packet they intend to send you
87--
88-- This behaves exactly like 'enqueue' except that no packet data is written to
89-- the queue.
90observeOutOfBand :: PacketQueue a -> Word32-> STM ()
91observeOutOfBand PacketQueue { seqno, qsize, buffend } numberOfNextLosslessPacketThatTheyWillSend = do
92 low <- readTVar seqno
93 let proj = numberOfNextLosslessPacketThatTheyWillSend - low
94 -- Ignore packet if out of range.
95 when ( proj < qsize) $ do
96 modifyTVar' buffend (\be -> if be - low <= proj then numberOfNextLosslessPacketThatTheyWillSend + 1 else be)
97
98-- | If seqno < buffend then return expected packet numbers for all
99-- the Nothings in the array between them.
100-- Otherwise, return empty list.
101getMissing :: PacketQueue a -> STM [Word32]
102getMissing PacketQueue { pktq, seqno, qsize, buffend } = do
103 seqno0 <- readTVar seqno
104 buffend0 <- readTVar buffend
105 -- note relying on fact that [ b .. a ] is null when a < b
106 let indices = take (fromIntegral qsize) $ [ seqno0 .. buffend0 - 1]
107 maybes <- forM indices $ \i -> do
108 x <- readArray pktq $ i `mod` qsize
109 return (i,x)
110 let nums = map fst . filter (isNothing . snd) $ maybes
111 return nums
112
113-- -- | If seqno < buffend then return expected packet numbers for all
114-- -- the Nothings in the array between them.
115-- -- Otherwise, behave as 'dequeue' would.
116-- -- TODO: Do we need this function? Delete it if not.
117-- dequeueOrGetMissing :: PacketQueue a -> STM (Either [Word32] a)
118-- dequeueOrGetMissing PacketQueue { pktq, seqno, qsize, buffend } = do
119-- seqno0 <- readTVar seqno
120-- buffend0 <- readTVar buffend
121-- if seqno0 < buffend0
122-- then do
123-- maybes <- mapM (readArray pktq) (take (fromIntegral qsize) $ map (`mod` qsize) [ seqno0 .. buffend0 ])
124-- let nums = map fst . filter (isNothing . snd) $ zip [buffend0 ..] maybes
125-- return (Left nums)
126-- else do
127-- let i = seqno0 `mod` qsize
128-- x <- maybe retry return =<< readArray pktq i
129-- writeArray pktq i Nothing
130-- modifyTVar' seqno succ
131-- return (Right x)
132
133-- | Retry until the next expected packet is enqueued. Then return it.
134dequeue :: PacketQueue a -> STM a
135dequeue PacketQueue { pktq, seqno, qsize } = do
136 i0 <- readTVar seqno
137 let i = i0 `mod` qsize
138 x <- maybe retry return =<< readArray pktq i
139 writeArray pktq i Nothing
140 modifyTVar' seqno succ
141 return x
142
143-- | Helper to 'dropPacketsBefore'.
144dropPacketsLogic :: Word32 -> Word32 -> Word32 -> (Maybe Word32, Word32, [(Word32,Word32)])
145dropPacketsLogic qsize low no0 =
146 let no = no0 - 1 -- Unsigned: could overflow
147 proj = no - low -- Unsigned: could overflow
148 in if proj < qsize
149 then
150 let ilow = low `mod` qsize
151 i = no `mod` qsize
152 ranges = if ilow <= i then [(ilow, i)]
153 else [(0,i),(ilow,qsize-1)]
154 in (Nothing,no0,ranges) -- Clear some, but not all, slots.
155 else (Nothing,low,[]) -- out of bounds, do nothing -- (Just no0, no0, [(0,qsize - 1)]) -- Reset to empty queue.
156
157
158-- | Drop all packets preceding the given packet number.
159dropPacketsBefore :: PacketQueue a -> Word32 -> STM ()
160dropPacketsBefore PacketQueue{ pktq, seqno, qsize, buffend } no0 = do
161 low <- readTVar seqno
162 let (mbuffend, no, ranges) = dropPacketsLogic qsize low no0
163 mapM_ (writeTVar buffend) mbuffend
164 writeTVar seqno no
165 forM_ ranges $ \(lo,hi) -> forM_ [lo .. hi] $ \i -> writeArray pktq i Nothing
166
167
168-- -- | Like dequeue, but marks as viewed rather than removing
169-- markButNotDequeue :: PacketQueue (Bool,a) -> STM a
170-- markButNotDequeue PacketQueue { pktq, seqno, qsize } = do
171-- i0 <- readTVar seqno
172-- let i = i0 `mod` qsize
173-- (b,x) <- maybe retry return =<< readArray pktq i
174-- writeArray pktq i (Just (True,x))
175-- modifyTVar' seqno succ
176-- return x
177
178-- | Enqueue a packet. Packets need not be enqueued in order as long as there
179-- is spare capacity in the queue. If there is not, the packet will be
180-- silently discarded without blocking. (Unless this is an Overwrite-queue, in
181-- which case, the packets will simply wrap around overwriting the old ones.)
182--
183-- If the packet was enqueued, (0,i) will be retuned where /i/ is the index at
184-- which the new packet was stored in the buffer. If the queue was full, the
185-- first of the returned pair will be non-zero.
186enqueue :: PacketQueue a -- ^ The packet queue.
187 -> Word32 -- ^ Sequence number of the packet.
188 -> a -- ^ The packet.
189 -> STM (Word32,Word32)
190enqueue PacketQueue{ pktq, seqno, qsize, buffend} no x = do
191 low <- readTVar seqno
192 let proj = no - low
193 -- Ignore packet if out of range.
194 when ( proj < qsize) $ do
195 let i = no `mod` qsize
196 writeArray pktq i (Just x)
197 modifyTVar' buffend (\be -> if be - low <= proj then no + 1 else be)
198 return (proj `divMod` qsize)
199
200-- | Obtain the packet with the given sequence number if it is stored in the
201-- queue, otherwise /Nothing/ is returned without blocking.
202lookup :: PacketQueue a -> Word32 -> STM (Maybe a)
203lookup PacketQueue{ pktq, seqno, qsize } no = do
204 low <- readTVar seqno
205 let proj = no - low
206 if proj < qsize
207 then let i = no `mod` qsize
208 in readArray pktq i
209 else return Nothing
210
211-- -- | For each item in the queue, modify or delete it.
212-- mapQ :: (a -> Maybe a) -> PacketQueue a -> STM ()
213-- mapQ f PacketQueue{pktq} = do
214-- (z,n) <- getBounds pktq
215-- forM_ [z .. n] $ \i -> do
216-- e <- readArray pktq i
217-- writeArray pktq i (e>>=f)
diff --git a/src/Data/Sized.hs b/src/Data/Sized.hs
deleted file mode 100644
index 0d3d5845..00000000
--- a/src/Data/Sized.hs
+++ /dev/null
@@ -1,14 +0,0 @@
1module Data.Sized where
2
3import Data.Typeable
4
5
6-- | Info about a type's serialized length. Either the length is known
7-- independently of the value, or the length depends on the value.
8data Size a
9 = VarSize (a -> Int)
10 | ConstSize !Int
11 deriving Typeable
12
13class Sized a where size :: Size a
14
diff --git a/src/Data/TableMethods.hs b/src/Data/TableMethods.hs
deleted file mode 100644
index e4208a69..00000000
--- a/src/Data/TableMethods.hs
+++ /dev/null
@@ -1,105 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE PartialTypeSignatures #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
8module Data.TableMethods where
9
10import Data.Functor.Contravariant
11import Data.Time.Clock.POSIX
12import Data.Word
13import qualified Data.IntMap.Strict as IntMap
14 ;import Data.IntMap.Strict (IntMap)
15import qualified Data.Map.Strict as Map
16 ;import Data.Map.Strict (Map)
17import qualified Data.Word64Map as W64Map
18 ;import Data.Word64Map (Word64Map)
19
20import Data.Wrapper.PSQ as PSQ
21
22type Priority = POSIXTime
23
24data OptionalPriority t tid x
25 = NoPriority
26 | HasPriority (Priority -> t x -> ([(tid, Priority, x)], t x))
27
28-- | The standard lookup table methods.
29data TableMethods t tid = TableMethods
30 { -- | Insert a new /tid/ entry into the transaction table.
31 tblInsert :: forall a. tid -> a -> Priority -> t a -> t a
32 -- | Delete transaction /tid/ from the transaction table.
33 , tblDelete :: forall a. tid -> t a -> t a
34 -- | Lookup the value associated with transaction /tid/.
35 , tblLookup :: forall a. tid -> t a -> Maybe a
36 }
37
38data QMethods t tid x = QMethods
39 { qTbl :: TableMethods t tid
40 , qAtMostView :: OptionalPriority t tid x
41 }
42
43vanillaTable :: TableMethods t tid -> QMethods t tid x
44vanillaTable tbl = QMethods tbl NoPriority
45
46priorityTable :: TableMethods t tid
47 -> (Priority -> t x -> ([(k, Priority, x)], t x))
48 -> (k -> x -> tid)
49 -> QMethods t tid x
50priorityTable tbl atmost f = QMethods
51 { qTbl = tbl
52 , qAtMostView = HasPriority $ \p t -> case atmost p t of
53 (es,t') -> (map (\(k,p,a) -> (f k a, p, a)) es, t')
54 }
55
56-- | Methods for using 'Data.IntMap'.
57intMapMethods :: TableMethods IntMap Int
58intMapMethods = TableMethods
59 { tblInsert = \tid a p -> IntMap.insert tid a
60 , tblDelete = IntMap.delete
61 , tblLookup = IntMap.lookup
62 }
63
64-- | Methods for using 'Data.Word64Map'.
65w64MapMethods :: TableMethods Word64Map Word64
66w64MapMethods = TableMethods
67 { tblInsert = \tid a p -> W64Map.insert tid a
68 , tblDelete = W64Map.delete
69 , tblLookup = W64Map.lookup
70 }
71
72-- | Methods for using 'Data.Map'
73mapMethods :: Ord tid => TableMethods (Map tid) tid
74mapMethods = TableMethods
75 { tblInsert = \tid a p -> Map.insert tid a
76 , tblDelete = Map.delete
77 , tblLookup = Map.lookup
78 }
79
80-- psqMethods :: PSQKey tid => QMethods (HashPSQ tid Priority) tid x
81psqMethods :: PSQKey k => (tid -> k) -> (k -> x -> tid) -> QMethods (PSQ' k Priority) tid x
82psqMethods g f = priorityTable (contramap g tbl) PSQ.atMostView f
83 where
84 tbl :: PSQKey tid => TableMethods (PSQ' tid Priority) tid
85 tbl = TableMethods
86 { tblInsert = PSQ.insert'
87 , tblDelete = PSQ.delete
88 , tblLookup = \tid t -> case PSQ.lookup tid t of
89 Just (p,a) -> Just a
90 Nothing -> Nothing
91 }
92
93
94-- | Change the key type for a lookup table implementation.
95--
96-- This can be used with 'intMapMethods' or 'mapMethods' to restrict lookups to
97-- only a part of the generated /tid/ value. This is useful for /tid/ types
98-- that are especially large due their use for other purposes, such as secure
99-- nonces for encryption.
100instance Contravariant (TableMethods t) where
101 -- contramap :: (tid -> t1) -> TableMethods t t1 -> TableMethods t tid
102 contramap f (TableMethods ins del lookup) =
103 TableMethods (\k p v t -> ins (f k) p v t)
104 (\k t -> del (f k) t)
105 (\k t -> lookup (f k) t)
diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs
deleted file mode 100644
index 32c709be..00000000
--- a/src/Data/Torrent.hs
+++ /dev/null
@@ -1,1347 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- Torrent file contains metadata about files and folders but not
9-- content itself. The files are bencoded dictionaries. There is
10-- also other info which is used to help join the swarm.
11--
12-- This module provides torrent metainfo serialization and info hash
13-- extraction.
14--
15-- For more info see:
16-- <http://www.bittorrent.org/beps/bep_0003.html#metainfo-files>,
17-- <https://wiki.theory.org/BitTorrentSpecification#Metainfo_File_Structure>
18--
19{-# LANGUAGE CPP #-}
20{-# LANGUAGE NamedFieldPuns #-}
21{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE MultiParamTypeClasses #-}
23{-# LANGUAGE BangPatterns #-}
24{-# LANGUAGE GeneralizedNewtypeDeriving #-}
25{-# LANGUAGE StandaloneDeriving #-}
26{-# LANGUAGE DeriveDataTypeable #-}
27{-# LANGUAGE DeriveFunctor #-}
28{-# LANGUAGE DeriveFoldable #-}
29{-# LANGUAGE DeriveTraversable #-}
30{-# LANGUAGE TemplateHaskell #-}
31{-# OPTIONS -fno-warn-orphans #-}
32module Data.Torrent
33 ( -- * InfoHash
34 -- $infohash
35 InfoHash(..)
36 , textToInfoHash
37 , longHex
38 , shortHex
39
40 -- * File layout
41 -- ** FileInfo
42 , FileOffset
43 , FileSize
44 , FileInfo (..)
45#ifdef USE_lens
46 , fileLength
47 , filePath
48 , fileMD5Sum
49#endif
50
51 -- ** Layout info
52 , LayoutInfo (..)
53#ifdef USE_lens
54 , singleFile
55 , multiFile
56 , rootDirName
57#endif
58 , joinFilePath
59 , isSingleFile
60 , isMultiFile
61 , suggestedName
62 , contentLength
63 , fileCount
64 , blockCount
65
66 -- ** Flat layout info
67 , FileLayout
68 , flatLayout
69 , accumPositions
70 , fileOffset
71
72 -- ** Internal
73 , sizeInBase
74
75 -- * Pieces
76 -- ** Attributes
77 , PieceIx
78 , PieceCount
79 , PieceSize
80 , minPieceSize
81 , maxPieceSize
82 , defaultPieceSize
83 , PieceHash
84
85 -- ** Piece data
86 , Piece (..)
87 , pieceSize
88 , hashPiece
89
90 -- ** Piece control
91 , HashList (..)
92 , PieceInfo (..)
93#ifdef USE_lens
94 , pieceLength
95 , pieceHashes
96#endif
97 , pieceCount
98
99 -- ** Validation
100 , pieceHash
101 , checkPieceLazy
102
103 -- * Info dictionary
104 , InfoDict (..)
105#ifdef USE_lens
106 , infohash
107 , layoutInfo
108 , pieceInfo
109 , isPrivate
110#endif
111#ifdef VERSION_bencoding
112 , infoDictionary
113#endif
114
115 -- * Torrent file
116 , Torrent(..)
117
118#ifdef USE_lens
119 -- ** Lenses
120 , announce
121 , announceList
122 , comment
123 , createdBy
124 , creationDate
125 , encoding
126 , infoDict
127 , publisher
128 , publisherURL
129 , signature
130#endif
131
132 -- ** Utils
133 , nullTorrent
134 , typeTorrent
135 , torrentExt
136 , isTorrentPath
137#ifdef VERSION_bencoding
138 , fromFile
139 , toFile
140#endif
141
142 -- * Magnet
143 -- $magnet-link
144 , Magnet(..)
145 , nullMagnet
146 , simpleMagnet
147 , detailedMagnet
148 , parseMagnet
149 , renderMagnet
150
151 -- ** URN
152 , URN (..)
153 , NamespaceId
154 , btih
155 , infohashURN
156 , parseURN
157 , renderURN
158 ) where
159
160import Prelude hiding ((<>))
161import Control.Applicative
162import Control.DeepSeq
163import Control.Exception
164-- import Control.Lens
165import Control.Monad
166import Crypto.Hash
167#ifdef VERSION_bencoding
168import Data.BEncode as BE
169import Data.BEncode.Types as BE
170#endif
171import Data.Bits
172#ifdef VERSION_bits_extras
173import Data.Bits.Extras
174#endif
175import qualified Data.ByteArray as Bytes
176import Data.ByteString as BS
177import Data.ByteString.Base16 as Base16
178import Data.ByteString.Base32 as Base32
179import Data.ByteString.Base64 as Base64
180import Data.ByteString.Char8 as BC (pack, unpack)
181import Data.ByteString.Lazy as BL
182import Data.Char
183import Data.Convertible
184import Data.Default
185import Data.Hashable as Hashable
186import Data.Int
187import Data.List as L
188import Data.Map as M
189import Data.Maybe
190import Data.Serialize as S
191import Data.String
192import Data.Text as T
193import Data.Text.Encoding as T
194import Data.Text.Read
195import Data.Time.Clock.POSIX
196import Data.Typeable
197import Network (HostName)
198import Network.HTTP.Types.QueryLike
199import Network.HTTP.Types.URI
200import Network.URI
201import Text.ParserCombinators.ReadP as P
202import Text.PrettyPrint as PP
203import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
204import System.FilePath
205import System.Posix.Types
206
207import Network.Address
208
209
210{-----------------------------------------------------------------------
211-- Info hash
212-----------------------------------------------------------------------}
213-- TODO
214--
215-- data Word160 = Word160 {-# UNPACK #-} !Word64
216-- {-# UNPACK #-} !Word64
217-- {-# UNPACK #-} !Word32
218--
219-- newtype InfoHash = InfoHash Word160
220--
221-- reason: bytestring have overhead = 8 words, while infohash have length 20 bytes
222
223-- $infohash
224--
225-- Infohash is a unique identifier of torrent.
226
227-- | Exactly 20 bytes long SHA1 hash of the info part of torrent file.
228newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString }
229 deriving (Eq, Ord, Typeable)
230
231infoHashLen :: Int
232infoHashLen = 20
233
234-- | Meaningless placeholder value.
235instance Default InfoHash where
236 def = "0123456789012345678901234567890123456789"
237
238-- | Hash raw bytes. (no encoding)
239instance Hashable InfoHash where
240 hashWithSalt s (InfoHash ih) = hashWithSalt s ih
241 {-# INLINE hashWithSalt #-}
242
243#ifdef VERSION_bencoding
244-- | Convert to\/from raw bencoded string. (no encoding)
245instance BEncode InfoHash where
246 toBEncode = toBEncode . getInfoHash
247 fromBEncode be = InfoHash <$> fromBEncode be
248#endif
249
250#if 0
251instance TableKey KMessageOf InfoHash where
252 toNodeId = either (error msg) id . S.decode . S.encode
253 where -- TODO unsafe coerse?
254 msg = "tableKey: impossible"
255#endif
256
257
258-- | Convert to\/from raw bytestring. (no encoding)
259instance Serialize InfoHash where
260 put (InfoHash ih) = putByteString ih
261 {-# INLINE put #-}
262
263 get = InfoHash <$> getBytes infoHashLen
264 {-# INLINE get #-}
265
266-- | Convert to raw query value. (no encoding)
267instance QueryValueLike InfoHash where
268 toQueryValue (InfoHash ih) = Just ih
269 {-# INLINE toQueryValue #-}
270
271-- | Convert to base16 encoded string.
272instance Show InfoHash where
273 show (InfoHash ih) = BC.unpack (Base16.encode ih)
274
275-- | Convert to base16 encoded Doc string.
276instance Pretty InfoHash where
277 pPrint = text . show
278
279-- | Read base16 encoded string.
280instance Read InfoHash where
281 readsPrec _ = readP_to_S $ do
282 str <- replicateM (infoHashLen * 2) (satisfy isHexDigit)
283 return $ InfoHash $ decodeIH str
284 where
285 decodeIH = BS.pack . L.map fromHex . pair
286 fromHex (a, b) = read $ '0' : 'x' : a : b : []
287
288 pair (a : b : xs) = (a, b) : pair xs
289 pair _ = []
290
291-- | Convert raw bytes to info hash.
292instance Convertible BS.ByteString InfoHash where
293 safeConvert bs
294 | BS.length bs == infoHashLen = pure (InfoHash bs)
295 | otherwise = convError "invalid length" bs
296
297-- | Parse infohash from base16\/base32\/base64 encoded string.
298instance Convertible Text InfoHash where
299 safeConvert t
300 | 20 == hashLen = pure (InfoHash hashStr)
301 | 26 <= hashLen && hashLen <= 28 =
302 case Base64.decode hashStr of
303 Left msg -> convError ("invalid base64 encoding " ++ msg) t
304 Right ihStr -> safeConvert ihStr
305
306 | hashLen == 32 =
307 case Base32.decode hashStr of
308 Left msg -> convError msg t
309 Right ihStr -> safeConvert ihStr
310
311 | hashLen == 40 =
312 let (ihStr, inv) = Base16.decode hashStr
313 in if BS.length inv /= 0
314 then convError "invalid base16 encoding" t
315 else safeConvert ihStr
316
317 | otherwise = convError "invalid length" t
318 where
319 hashLen = BS.length hashStr
320 hashStr = T.encodeUtf8 t
321
322-- | Decode from base16\/base32\/base64 encoded string.
323instance IsString InfoHash where
324 fromString = either (error . prettyConvertError) id . safeConvert . T.pack
325
326ignoreErrorMsg :: Either a b -> Maybe b
327ignoreErrorMsg = either (const Nothing) Just
328
329-- | Tries both base16 and base32 while decoding info hash.
330--
331-- Use 'safeConvert' for detailed error messages.
332--
333textToInfoHash :: Text -> Maybe InfoHash
334textToInfoHash = ignoreErrorMsg . safeConvert
335
336-- | Hex encode infohash to text, full length.
337longHex :: InfoHash -> Text
338longHex = T.decodeUtf8 . Base16.encode . getInfoHash
339
340-- | The same as 'longHex', but only first 7 characters.
341shortHex :: InfoHash -> Text
342shortHex = T.take 7 . longHex
343
344{-----------------------------------------------------------------------
345-- File info
346-----------------------------------------------------------------------}
347
348-- | Size of a file in bytes.
349type FileSize = FileOffset
350
351#ifdef VERSION_bencoding
352deriving instance BEncode FileOffset
353#endif
354
355-- | Contain metainfo about one single file.
356data FileInfo a = FileInfo {
357 fiLength :: {-# UNPACK #-} !FileSize
358 -- ^ Length of the file in bytes.
359
360 -- TODO unpacked MD5 sum
361 , fiMD5Sum :: !(Maybe BS.ByteString)
362 -- ^ 32 character long MD5 sum of the file. Used by third-party
363 -- tools, not by bittorrent protocol itself.
364
365 , fiName :: !a
366 -- ^ One or more string elements that together represent the
367 -- path and filename. Each element in the list corresponds to
368 -- either a directory name or (in the case of the last element)
369 -- the filename. For example, the file:
370 --
371 -- > "dir1/dir2/file.ext"
372 --
373 -- would consist of three string elements:
374 --
375 -- > ["dir1", "dir2", "file.ext"]
376 --
377 } deriving (Show, Read, Eq, Typeable
378 , Functor, Foldable
379 )
380
381#ifdef USE_lens
382makeLensesFor
383 [ ("fiLength", "fileLength")
384 , ("fiMD5Sum", "fileMD5Sum")
385 , ("fiName" , "filePath" )
386 ]
387 ''FileInfo
388#endif
389
390instance NFData a => NFData (FileInfo a) where
391 rnf FileInfo {..} = rnf fiName
392 {-# INLINE rnf #-}
393
394#ifdef VERSION_bencoding
395instance BEncode (FileInfo [BS.ByteString]) where
396 toBEncode FileInfo {..} = toDict $
397 "length" .=! fiLength
398 .: "md5sum" .=? fiMD5Sum
399 .: "path" .=! fiName
400 .: endDict
401 {-# INLINE toBEncode #-}
402
403 fromBEncode = fromDict $ do
404 FileInfo <$>! "length"
405 <*>? "md5sum"
406 <*>! "path"
407 {-# INLINE fromBEncode #-}
408
409type Put a = a -> BDict -> BDict
410#endif
411
412#ifdef VERSION_bencoding
413putFileInfoSingle :: Data.Torrent.Put (FileInfo BS.ByteString)
414putFileInfoSingle FileInfo {..} cont =
415 "length" .=! fiLength
416 .: "md5sum" .=? fiMD5Sum
417 .: "name" .=! fiName
418 .: cont
419
420getFileInfoSingle :: BE.Get (FileInfo BS.ByteString)
421getFileInfoSingle = do
422 FileInfo <$>! "length"
423 <*>? "md5sum"
424 <*>! "name"
425
426instance BEncode (FileInfo BS.ByteString) where
427 toBEncode = toDict . (`putFileInfoSingle` endDict)
428 {-# INLINE toBEncode #-}
429
430 fromBEncode = fromDict getFileInfoSingle
431 {-# INLINE fromBEncode #-}
432#endif
433
434instance Pretty (FileInfo BS.ByteString) where
435 pPrint FileInfo {..} =
436 "Path: " <> text (T.unpack (T.decodeUtf8 fiName))
437 $$ "Size: " <> text (show fiLength)
438 $$ maybe PP.empty ppMD5 fiMD5Sum
439 where
440 ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5))
441
442-- | Join file path.
443joinFilePath :: FileInfo [BS.ByteString] -> FileInfo BS.ByteString
444joinFilePath = fmap (BS.intercalate "/")
445
446{-----------------------------------------------------------------------
447-- Layout info
448-----------------------------------------------------------------------}
449
450-- | Original (found in torrent file) layout info is either:
451--
452-- * Single file with its /name/.
453--
454-- * Multiple files with its relative file /paths/.
455--
456data LayoutInfo
457 = SingleFile
458 { -- | Single file info.
459 liFile :: !(FileInfo BS.ByteString)
460 }
461 | MultiFile
462 { -- | List of the all files that torrent contains.
463 liFiles :: ![FileInfo [BS.ByteString]]
464
465 -- | The /suggested/ name of the root directory in which to
466 -- store all the files.
467 , liDirName :: !BS.ByteString
468 } deriving (Show, Read, Eq, Typeable)
469
470#ifdef USE_lens
471makeLensesFor
472 [ ("liFile" , "singleFile" )
473 , ("liFiles" , "multiFile" )
474 , ("liDirName", "rootDirName")
475 ]
476 ''LayoutInfo
477#endif
478
479instance NFData LayoutInfo where
480 rnf SingleFile {..} = ()
481 rnf MultiFile {..} = rnf liFiles
482
483-- | Empty multifile layout.
484instance Default LayoutInfo where
485 def = MultiFile [] ""
486
487#ifdef VERSION_bencoding
488getLayoutInfo :: BE.Get LayoutInfo
489getLayoutInfo = single <|> multi
490 where
491 single = SingleFile <$> getFileInfoSingle
492 multi = MultiFile <$>! "files" <*>! "name"
493
494putLayoutInfo :: Data.Torrent.Put LayoutInfo
495putLayoutInfo SingleFile {..} = putFileInfoSingle liFile
496putLayoutInfo MultiFile {..} = \ cont ->
497 "files" .=! liFiles
498 .: "name" .=! liDirName
499 .: cont
500
501instance BEncode LayoutInfo where
502 toBEncode = toDict . (`putLayoutInfo` endDict)
503 fromBEncode = fromDict getLayoutInfo
504#endif
505
506instance Pretty LayoutInfo where
507 pPrint SingleFile {..} = pPrint liFile
508 pPrint MultiFile {..} = vcat $ L.map (pPrint . joinFilePath) liFiles
509
510-- | Test if this is single file torrent.
511isSingleFile :: LayoutInfo -> Bool
512isSingleFile SingleFile {} = True
513isSingleFile _ = False
514{-# INLINE isSingleFile #-}
515
516-- | Test if this is multifile torrent.
517isMultiFile :: LayoutInfo -> Bool
518isMultiFile MultiFile {} = True
519isMultiFile _ = False
520{-# INLINE isMultiFile #-}
521
522-- | Get name of the torrent based on the root path piece.
523suggestedName :: LayoutInfo -> BS.ByteString
524suggestedName (SingleFile FileInfo {..}) = fiName
525suggestedName MultiFile {..} = liDirName
526{-# INLINE suggestedName #-}
527
528-- | Find sum of sizes of the all torrent files.
529contentLength :: LayoutInfo -> FileSize
530contentLength SingleFile { liFile = FileInfo {..} } = fiLength
531contentLength MultiFile { liFiles = tfs } = L.sum (L.map fiLength tfs)
532
533-- | Get number of all files in torrent.
534fileCount :: LayoutInfo -> Int
535fileCount SingleFile {..} = 1
536fileCount MultiFile {..} = L.length liFiles
537
538-- | Find number of blocks of the specified size. If torrent size is
539-- not a multiple of block size then the count is rounded up.
540blockCount :: Int -> LayoutInfo -> Int
541blockCount blkSize ci = contentLength ci `sizeInBase` blkSize
542
543------------------------------------------------------------------------
544
545-- | File layout specifies the order and the size of each file in the
546-- storage. Note that order of files is highly important since we
547-- coalesce all the files in the given order to get the linear block
548-- address space.
549--
550type FileLayout a = [(FilePath, a)]
551
552-- | Extract files layout from torrent info with the given root path.
553flatLayout
554 :: FilePath -- ^ Root path for the all torrent files.
555 -> LayoutInfo -- ^ Torrent content information.
556 -> FileLayout FileSize -- ^ The all file paths prefixed with the given root.
557flatLayout prefixPath SingleFile { liFile = FileInfo {..} }
558 = [(prefixPath </> BC.unpack fiName, fiLength)]
559flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles
560 where -- TODO use utf8 encoding in name
561 mkPath FileInfo {..} = (_path, fiLength)
562 where
563 _path = prefixPath </> BC.unpack liDirName
564 </> joinPath (L.map BC.unpack fiName)
565
566-- | Calculate offset of each file based on its length, incrementally.
567accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize)
568accumPositions = go 0
569 where
570 go !_ [] = []
571 go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs
572
573-- | Gives global offset of a content file for a given full path.
574fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset
575fileOffset = L.lookup
576{-# INLINE fileOffset #-}
577
578------------------------------------------------------------------------
579
580-- | Divide and round up.
581sizeInBase :: Integral a => a -> Int -> Int
582sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align
583 where
584 align = if n `mod` fromIntegral b == 0 then 0 else 1
585{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-}
586{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-}
587
588{-----------------------------------------------------------------------
589-- Piece attributes
590-----------------------------------------------------------------------}
591
592-- | Zero-based index of piece in torrent content.
593type PieceIx = Int
594
595-- | Size of piece in bytes. Should be a power of 2.
596--
597-- NOTE: Have max and min size constrained to wide used
598-- semi-standard values. This bounds should be used to make decision
599-- about piece size for new torrents.
600--
601type PieceSize = Int
602
603-- | Number of pieces in torrent or a part of torrent.
604type PieceCount = Int
605
606defaultBlockSize :: Int
607defaultBlockSize = 16 * 1024
608
609-- | Optimal number of pieces in torrent.
610optimalPieceCount :: PieceCount
611optimalPieceCount = 1000
612{-# INLINE optimalPieceCount #-}
613
614-- | Piece size should not be less than this value.
615minPieceSize :: Int
616minPieceSize = defaultBlockSize * 4
617{-# INLINE minPieceSize #-}
618
619-- | To prevent transfer degradation piece size should not exceed this
620-- value.
621maxPieceSize :: Int
622maxPieceSize = 4 * 1024 * 1024
623{-# INLINE maxPieceSize #-}
624
625toPow2 :: Int -> Int
626#ifdef VERSION_bits_extras
627toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x)
628#else
629toPow2 x = bit $ fromIntegral (countLeadingZeros (0 :: Int) - countLeadingZeros x)
630#endif
631
632-- | Find the optimal piece size for a given torrent size.
633defaultPieceSize :: Int64 -> Int
634defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc
635 where
636 pc = fromIntegral (x `div` fromIntegral optimalPieceCount)
637
638{-----------------------------------------------------------------------
639-- Piece data
640-----------------------------------------------------------------------}
641
642type PieceHash = BS.ByteString
643
644hashsize :: Int
645hashsize = 20
646{-# INLINE hashsize #-}
647
648-- TODO check if pieceLength is power of 2
649-- | Piece payload should be strict or lazy bytestring.
650data Piece a = Piece
651 { -- | Zero-based piece index in torrent.
652 pieceIndex :: {-# UNPACK #-} !PieceIx
653
654 -- | Payload.
655 , pieceData :: !a
656 } deriving (Show, Read, Eq, Functor, Typeable)
657
658instance NFData a => NFData (Piece a) where
659 rnf (Piece a b) = rnf a `seq` rnf b
660
661-- | Payload bytes are omitted.
662instance Pretty (Piece a) where
663 pPrint Piece {..} = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex)
664
665-- | Get size of piece in bytes.
666pieceSize :: Piece BL.ByteString -> PieceSize
667pieceSize Piece {..} = fromIntegral (BL.length pieceData)
668
669-- | Get piece hash.
670hashPiece :: Piece BL.ByteString -> PieceHash
671hashPiece Piece {..} = Bytes.convert (hashlazy pieceData :: Digest SHA1)
672
673{-----------------------------------------------------------------------
674-- Piece control
675-----------------------------------------------------------------------}
676
677-- | A flat array of SHA1 hash for each piece.
678newtype HashList = HashList { unHashList :: BS.ByteString }
679 deriving ( Show, Read, Eq, Typeable
680#ifdef VERSION_bencoding
681 , BEncode
682#endif
683 )
684
685-- | Empty hash list.
686instance Default HashList where
687 def = HashList ""
688
689-- | Part of torrent file used for torrent content validation.
690data PieceInfo = PieceInfo
691 { piPieceLength :: {-# UNPACK #-} !PieceSize
692 -- ^ Number of bytes in each piece.
693
694 , piPieceHashes :: !HashList
695 -- ^ Concatenation of all 20-byte SHA1 hash values.
696 } deriving (Show, Read, Eq, Typeable)
697
698#ifdef USE_lens
699-- | Number of bytes in each piece.
700makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo
701
702-- | Concatenation of all 20-byte SHA1 hash values.
703makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo
704#endif
705
706instance NFData PieceInfo where
707 rnf (PieceInfo a (HashList b)) = rnf a `seq` rnf b
708
709instance Default PieceInfo where
710 def = PieceInfo 1 def
711
712
713#ifdef VERSION_bencoding
714putPieceInfo :: Data.Torrent.Put PieceInfo
715putPieceInfo PieceInfo {..} cont =
716 "piece length" .=! piPieceLength
717 .: "pieces" .=! piPieceHashes
718 .: cont
719
720getPieceInfo :: BE.Get PieceInfo
721getPieceInfo = do
722 PieceInfo <$>! "piece length"
723 <*>! "pieces"
724
725instance BEncode PieceInfo where
726 toBEncode = toDict . (`putPieceInfo` endDict)
727 fromBEncode = fromDict getPieceInfo
728#endif
729
730-- | Hashes are omitted.
731instance Pretty PieceInfo where
732 pPrint PieceInfo {..} = "Piece size: " <> int piPieceLength
733
734slice :: Int -> Int -> BS.ByteString -> BS.ByteString
735slice start len = BS.take len . BS.drop start
736{-# INLINE slice #-}
737
738-- | Extract validation hash by specified piece index.
739pieceHash :: PieceInfo -> PieceIx -> PieceHash
740pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashList piPieceHashes)
741
742-- | Find count of pieces in the torrent. If torrent size is not a
743-- multiple of piece size then the count is rounded up.
744pieceCount :: PieceInfo -> PieceCount
745pieceCount PieceInfo {..} = BS.length (unHashList piPieceHashes) `quot` hashsize
746
747-- | Test if this is last piece in torrent content.
748isLastPiece :: PieceInfo -> PieceIx -> Bool
749isLastPiece ci i = pieceCount ci == succ i
750
751-- | Validate piece with metainfo hash.
752checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool
753checkPieceLazy pinfo @ PieceInfo {..} Piece {..}
754 = (fromIntegral (BL.length pieceData) == piPieceLength
755 || isLastPiece pinfo pieceIndex)
756 && Bytes.convert (hashlazy pieceData :: Digest SHA1) == pieceHash pinfo pieceIndex
757
758{-----------------------------------------------------------------------
759-- Info dictionary
760-----------------------------------------------------------------------}
761
762{- note that info hash is actually reduntant field
763 but it's better to keep it here to avoid heavy recomputations
764-}
765
766-- | Info part of the .torrent file contain info about each content file.
767data InfoDict = InfoDict
768 { idInfoHash :: !InfoHash
769 -- ^ SHA1 hash of the (other) 'DictInfo' fields.
770
771 , idLayoutInfo :: !LayoutInfo
772 -- ^ File layout (name, size, etc) information.
773
774 , idPieceInfo :: !PieceInfo
775 -- ^ Content validation information.
776
777 , idPrivate :: !Bool
778 -- ^ If set the client MUST publish its presence to get other
779 -- peers ONLY via the trackers explicity described in the
780 -- metainfo file.
781 --
782 -- BEP 27: <http://www.bittorrent.org/beps/bep_0027.html>
783 } deriving (Show, Read, Eq, Typeable)
784
785#ifdef VERISON_lens
786makeLensesFor
787 [ ("idInfoHash" , "infohash" )
788 , ("idLayoutInfo", "layoutInfo")
789 , ("idPieceInfo" , "pieceInfo" )
790 , ("idPrivate" , "isPrivate" )
791 ]
792 ''InfoDict
793#endif
794
795instance NFData InfoDict where
796 rnf InfoDict {..} = rnf idLayoutInfo
797
798instance Hashable InfoDict where
799 hashWithSalt = Hashable.hashUsing idInfoHash
800 {-# INLINE hashWithSalt #-}
801
802-- | Hash lazy bytestring using SHA1 algorithm.
803hashLazyIH :: BL.ByteString -> InfoHash
804hashLazyIH = either (const (error msg)) id . safeConvert . (Bytes.convert :: Digest SHA1 -> BS.ByteString) . hashlazy
805 where
806 msg = "Infohash.hash: impossible: SHA1 is always 20 bytes long"
807
808#ifdef VERSION_bencoding
809-- | Empty info dictionary with zero-length content.
810instance Default InfoDict where
811 def = infoDictionary def def False
812
813-- | Smart constructor: add a info hash to info dictionary.
814infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict
815infoDictionary li pinfo private = InfoDict ih li pinfo private
816 where
817 ih = hashLazyIH $ BE.encode $ InfoDict def li pinfo private
818
819getPrivate :: BE.Get Bool
820getPrivate = (Just True ==) <$>? "private"
821
822putPrivate :: Bool -> BDict -> BDict
823putPrivate False = id
824putPrivate True = \ cont -> "private" .=! True .: cont
825
826instance BEncode InfoDict where
827 toBEncode InfoDict {..} = toDict $
828 putLayoutInfo idLayoutInfo $
829 putPieceInfo idPieceInfo $
830 putPrivate idPrivate $
831 endDict
832
833 fromBEncode dict = (`fromDict` dict) $ do
834 InfoDict ih <$> getLayoutInfo
835 <*> getPieceInfo
836 <*> getPrivate
837 where
838 ih = hashLazyIH (BE.encode dict)
839#endif
840
841ppPrivacy :: Bool -> Doc
842ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public"
843
844--ppAdditionalInfo :: InfoDict -> Doc
845--ppAdditionalInfo layout = PP.empty
846
847instance Pretty InfoDict where
848 pPrint InfoDict {..} =
849 pPrint idLayoutInfo $$
850 pPrint idPieceInfo $$
851 ppPrivacy idPrivate
852
853{-----------------------------------------------------------------------
854-- Torrent info
855-----------------------------------------------------------------------}
856-- TODO add torrent file validation
857
858-- | Metainfo about particular torrent.
859data Torrent = Torrent
860 { tAnnounce :: !(Maybe URI)
861 -- ^ The URL of the tracker.
862
863 , tAnnounceList :: !(Maybe [[URI]])
864 -- ^ Announce list add multiple tracker support.
865 --
866 -- BEP 12: <http://www.bittorrent.org/beps/bep_0012.html>
867
868 , tComment :: !(Maybe Text)
869 -- ^ Free-form comments of the author.
870
871 , tCreatedBy :: !(Maybe Text)
872 -- ^ Name and version of the program used to create the .torrent.
873
874 , tCreationDate :: !(Maybe POSIXTime)
875 -- ^ Creation time of the torrent, in standard UNIX epoch.
876
877 , tEncoding :: !(Maybe Text)
878 -- ^ String encoding format used to generate the pieces part of
879 -- the info dictionary in the .torrent metafile.
880
881 , tInfoDict :: !InfoDict
882 -- ^ Info about each content file.
883
884 , tNodes :: !(Maybe [NodeAddr HostName])
885 -- ^ This key should be set to the /K closest/ nodes in the
886 -- torrent generating client's routing table. Alternatively, the
887 -- key could be set to a known good 'Network.Address.Node'
888 -- such as one operated by the person generating the torrent.
889 --
890 -- Please do not automatically add \"router.bittorrent.com\" to
891 -- this list because different bittorrent software may prefer to
892 -- use different bootstrap node.
893
894 , tPublisher :: !(Maybe URI)
895 -- ^ Containing the RSA public key of the publisher of the
896 -- torrent. Private counterpart of this key that has the
897 -- authority to allow new peers onto the swarm.
898
899 , tPublisherURL :: !(Maybe URI)
900 , tSignature :: !(Maybe BS.ByteString)
901 -- ^ The RSA signature of the info dictionary (specifically, the
902 -- encrypted SHA-1 hash of the info dictionary).
903 } deriving (Show, Eq, Typeable)
904
905#ifdef USE_lens
906makeLensesFor
907 [ ("tAnnounce" , "announce" )
908 , ("tAnnounceList", "announceList")
909 , ("tComment" , "comment" )
910 , ("tCreatedBy" , "createdBy" )
911 , ("tCreationDate", "creationDate")
912 , ("tEncoding" , "encoding" )
913 , ("tInfoDict" , "infoDict" )
914 , ("tPublisher" , "publisher" )
915 , ("tPublisherURL", "publisherURL")
916 , ("tSignature" , "signature" )
917 ]
918 ''Torrent
919#endif
920
921instance NFData Torrent where
922 rnf Torrent {..} = rnf tInfoDict
923
924#ifdef VERSION_bencoding
925-- TODO move to bencoding
926instance BEncode URI where
927 toBEncode uri = toBEncode (BC.pack (uriToString id uri ""))
928 {-# INLINE toBEncode #-}
929
930 fromBEncode (BString s) | Just url <- parseURI (BC.unpack s) = return url
931 fromBEncode b = decodingError $ "url <" ++ show b ++ ">"
932 {-# INLINE fromBEncode #-}
933
934--pico2uni :: Pico -> Uni
935--pico2uni = undefined
936
937-- TODO move to bencoding
938instance BEncode POSIXTime where
939 toBEncode pt = toBEncode (floor pt :: Integer)
940 fromBEncode (BInteger i) = return $ fromIntegral i
941 fromBEncode _ = decodingError $ "POSIXTime"
942
943-- TODO to bencoding package
944instance {-# OVERLAPPING #-} BEncode String where
945 toBEncode = toBEncode . T.pack
946 fromBEncode v = T.unpack <$> fromBEncode v
947
948instance BEncode Torrent where
949 toBEncode Torrent {..} = toDict $
950 "announce" .=? tAnnounce
951 .: "announce-list" .=? tAnnounceList
952 .: "comment" .=? tComment
953 .: "created by" .=? tCreatedBy
954 .: "creation date" .=? tCreationDate
955 .: "encoding" .=? tEncoding
956 .: "info" .=! tInfoDict
957 .: "nodes" .=? tNodes
958 .: "publisher" .=? tPublisher
959 .: "publisher-url" .=? tPublisherURL
960 .: "signature" .=? tSignature
961 .: endDict
962
963 fromBEncode = fromDict $ do
964 Torrent <$>? "announce"
965 <*>? "announce-list"
966 <*>? "comment"
967 <*>? "created by"
968 <*>? "creation date"
969 <*>? "encoding"
970 <*>! "info"
971 <*>? "nodes"
972 <*>? "publisher"
973 <*>? "publisher-url"
974 <*>? "signature"
975#endif
976
977(<:>) :: Doc -> Doc -> Doc
978name <:> v = name <> ":" <+> v
979
980(<:>?) :: Doc -> Maybe Doc -> Doc
981_ <:>? Nothing = PP.empty
982name <:>? (Just d) = name <:> d
983
984instance Pretty Torrent where
985 pPrint Torrent {..} =
986 "InfoHash: " <> pPrint (idInfoHash tInfoDict)
987 $$ hang "General" 4 generalInfo
988 $$ hang "Tracker" 4 trackers
989 $$ pPrint tInfoDict
990 where
991 trackers = case tAnnounceList of
992 Nothing -> text (show tAnnounce)
993 Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs
994 where
995 ppTier (n, xs) = "Tier #" <> int n <:> vcat (L.map (text . show) xs)
996
997 generalInfo =
998 "Comment" <:>? ((text . T.unpack) <$> tComment) $$
999 "Created by" <:>? ((text . T.unpack) <$> tCreatedBy) $$
1000 "Created on" <:>? ((text . show . posixSecondsToUTCTime)
1001 <$> tCreationDate) $$
1002 "Encoding" <:>? ((text . T.unpack) <$> tEncoding) $$
1003 "Publisher" <:>? ((text . show) <$> tPublisher) $$
1004 "Publisher URL" <:>? ((text . show) <$> tPublisherURL) $$
1005 "Signature" <:>? ((text . show) <$> tSignature)
1006
1007#ifdef VERSION_bencoding
1008-- | No files, no trackers, no nodes, etc...
1009instance Default Torrent where
1010 def = nullTorrent def
1011#endif
1012
1013-- | A simple torrent contains only required fields.
1014nullTorrent :: InfoDict -> Torrent
1015nullTorrent info = Torrent
1016 Nothing Nothing Nothing Nothing Nothing Nothing
1017 info Nothing Nothing Nothing Nothing
1018
1019-- | Mime type of torrent files.
1020typeTorrent :: BS.ByteString
1021typeTorrent = "application/x-bittorrent"
1022
1023-- | Extension usually used for torrent files.
1024torrentExt :: String
1025torrentExt = "torrent"
1026
1027-- | Test if this path has proper extension.
1028isTorrentPath :: FilePath -> Bool
1029isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt
1030
1031#ifdef VERSION_bencoding
1032-- | Read and decode a .torrent file.
1033fromFile :: FilePath -> IO Torrent
1034fromFile filepath = do
1035 contents <- BS.readFile filepath
1036 case BE.decode contents of
1037 Right !t -> return t
1038 Left msg -> throwIO $ userError $ msg ++ " while reading torrent file"
1039
1040-- | Encode and write a .torrent file.
1041toFile :: FilePath -> Torrent -> IO ()
1042toFile filepath = BL.writeFile filepath . BE.encode
1043#endif
1044
1045{-----------------------------------------------------------------------
1046-- URN
1047-----------------------------------------------------------------------}
1048
1049-- | Namespace identifier determines the syntactic interpretation of
1050-- namespace-specific string.
1051type NamespaceId = [Text]
1052
1053-- | BitTorrent Info Hash (hence the name) namespace
1054-- identifier. Namespace-specific string /should/ be a base16\/base32
1055-- encoded SHA1 hash of the corresponding torrent /info/ dictionary.
1056--
1057btih :: NamespaceId
1058btih = ["btih"]
1059
1060-- | URN is pesistent location-independent identifier for
1061-- resources. In particular, URNs are used represent torrent names
1062-- as a part of magnet link, see 'Data.Torrent.Magnet.Magnet' for
1063-- more info.
1064--
1065data URN = URN
1066 { urnNamespace :: NamespaceId -- ^ a namespace identifier;
1067 , urnString :: Text -- ^ a corresponding
1068 -- namespace-specific string.
1069 } deriving (Eq, Ord, Typeable)
1070
1071-----------------------------------------------------------------------
1072
1073instance Convertible URN InfoHash where
1074 safeConvert u @ URN {..}
1075 | urnNamespace /= btih = convError "invalid namespace" u
1076 | otherwise = safeConvert urnString
1077
1078-- | Make resource name for torrent with corresponding
1079-- infohash. Infohash is base16 (hex) encoded.
1080--
1081infohashURN :: InfoHash -> URN
1082infohashURN = URN btih . longHex
1083
1084-- | Meaningless placeholder value.
1085instance Default URN where
1086 def = infohashURN def
1087
1088------------------------------------------------------------------------
1089
1090-- | Render URN to its text representation.
1091renderURN :: URN -> Text
1092renderURN URN {..}
1093 = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString]
1094
1095instance Pretty URN where
1096 pPrint = text . T.unpack . renderURN
1097
1098instance Show URN where
1099 showsPrec n = showsPrec n . T.unpack . renderURN
1100
1101instance QueryValueLike URN where
1102 toQueryValue = toQueryValue . renderURN
1103 {-# INLINE toQueryValue #-}
1104
1105-----------------------------------------------------------------------
1106
1107_unsnoc :: [a] -> Maybe ([a], a)
1108_unsnoc [] = Nothing
1109_unsnoc xs = Just (L.init xs, L.last xs)
1110
1111instance Convertible Text URN where
1112 safeConvert t = case T.split (== ':') t of
1113 uriScheme : body
1114 | T.toLower uriScheme == "urn" ->
1115 case _unsnoc body of
1116 Just (namespace, val) -> pure URN
1117 { urnNamespace = namespace
1118 , urnString = val
1119 }
1120 Nothing -> convError "missing URN string" body
1121 | otherwise -> convError "invalid URN scheme" uriScheme
1122 [] -> convError "missing URN scheme" t
1123
1124instance IsString URN where
1125 fromString = either (error . prettyConvertError) id
1126 . safeConvert . T.pack
1127
1128-- | Try to parse an URN from its text representation.
1129--
1130-- Use 'safeConvert' for detailed error messages.
1131--
1132parseURN :: Text -> Maybe URN
1133parseURN = either (const Nothing) pure . safeConvert
1134
1135{-----------------------------------------------------------------------
1136-- Magnet
1137-----------------------------------------------------------------------}
1138-- $magnet-link
1139--
1140-- Magnet URI scheme is an standard defining Magnet links. Magnet
1141-- links are refer to resources by hash, in particular magnet links
1142-- can refer to torrent using corresponding infohash. In this way,
1143-- magnet links can be used instead of torrent files.
1144--
1145-- This module provides bittorrent specific implementation of magnet
1146-- links.
1147--
1148-- For generic magnet uri scheme see:
1149-- <http://magnet-uri.sourceforge.net/magnet-draft-overview.txt>,
1150-- <http://www.iana.org/assignments/uri-schemes/prov/magnet>
1151--
1152-- Bittorrent specific details:
1153-- <http://www.bittorrent.org/beps/bep_0009.html>
1154--
1155
1156-- TODO multiple exact topics
1157-- TODO render/parse supplement for URI/query
1158
1159-- | An URI used to identify torrent.
1160data Magnet = Magnet
1161 { -- | Torrent infohash hash. Can be used in DHT queries if no
1162 -- 'tracker' provided.
1163 exactTopic :: !InfoHash -- TODO InfoHash -> URN?
1164
1165 -- | A filename for the file to download. Can be used to
1166 -- display name while waiting for metadata.
1167 , displayName :: Maybe Text
1168
1169 -- | Size of the resource in bytes.
1170 , exactLength :: Maybe Integer
1171
1172 -- | URI pointing to manifest, e.g. a list of further items.
1173 , manifest :: Maybe Text
1174
1175 -- | Search string.
1176 , keywordTopic :: Maybe Text
1177
1178 -- | A source to be queried after not being able to find and
1179 -- download the file in the bittorrent network in a defined
1180 -- amount of time.
1181 , acceptableSource :: Maybe URI
1182
1183 -- | Direct link to the resource.
1184 , exactSource :: Maybe URI
1185
1186 -- | URI to the tracker.
1187 , tracker :: Maybe URI
1188
1189 -- | Additional or experimental parameters.
1190 , supplement :: Map Text Text
1191 } deriving (Eq, Ord, Typeable)
1192
1193instance QueryValueLike Integer where
1194 toQueryValue = toQueryValue . show
1195
1196instance QueryValueLike URI where
1197 toQueryValue = toQueryValue . show
1198
1199instance QueryLike Magnet where
1200 toQuery Magnet {..} =
1201 [ ("xt", toQueryValue $ infohashURN exactTopic)
1202 , ("dn", toQueryValue displayName)
1203 , ("xl", toQueryValue exactLength)
1204 , ("mt", toQueryValue manifest)
1205 , ("kt", toQueryValue keywordTopic)
1206 , ("as", toQueryValue acceptableSource)
1207 , ("xs", toQueryValue exactSource)
1208 , ("tr", toQueryValue tracker)
1209 ]
1210
1211instance QueryValueLike Magnet where
1212 toQueryValue = toQueryValue . renderMagnet
1213
1214instance Convertible QueryText Magnet where
1215 safeConvert xs = do
1216 urnStr <- getTextMsg "xt" "exact topic not defined" xs
1217 infoHash <- convertVia (error "safeConvert" :: URN) urnStr
1218 return Magnet
1219 { exactTopic = infoHash
1220 , displayName = getText "dn" xs
1221 , exactLength = getText "xl" xs >>= getInt
1222 , manifest = getText "mt" xs
1223 , keywordTopic = getText "kt" xs
1224 , acceptableSource = getText "as" xs >>= getURI
1225 , exactSource = getText "xs" xs >>= getURI
1226 , tracker = getText "tr" xs >>= getURI
1227 , supplement = M.empty
1228 }
1229 where
1230 getInt = either (const Nothing) (Just . fst) . signed decimal
1231 getURI = parseURI . T.unpack
1232 getText p = join . L.lookup p
1233 getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps
1234
1235magnetScheme :: URI
1236magnetScheme = URI
1237 { uriScheme = "magnet:"
1238 , uriAuthority = Nothing
1239 , uriPath = ""
1240 , uriQuery = ""
1241 , uriFragment = ""
1242 }
1243
1244isMagnetURI :: URI -> Bool
1245isMagnetURI u = u { uriQuery = "" } == magnetScheme
1246
1247-- | Can be used instead of 'parseMagnet'.
1248instance Convertible URI Magnet where
1249 safeConvert u @ URI {..}
1250 | not (isMagnetURI u) = convError "this is not a magnet link" u
1251 | otherwise = safeConvert $ parseQueryText $ BC.pack uriQuery
1252
1253-- | Can be used instead of 'renderMagnet'.
1254instance Convertible Magnet URI where
1255 safeConvert m = pure $ magnetScheme
1256 { uriQuery = BC.unpack $ renderQuery True $ toQuery m }
1257
1258instance Convertible String Magnet where
1259 safeConvert str
1260 | Just uri <- parseURI str = safeConvert uri
1261 | otherwise = convError "unable to parse uri" str
1262
1263------------------------------------------------------------------------
1264
1265-- | Meaningless placeholder value.
1266instance Default Magnet where
1267 def = Magnet
1268 { exactTopic = def
1269 , displayName = Nothing
1270 , exactLength = Nothing
1271 , manifest = Nothing
1272 , keywordTopic = Nothing
1273 , acceptableSource = Nothing
1274 , exactSource = Nothing
1275 , tracker = Nothing
1276 , supplement = M.empty
1277 }
1278
1279-- | Set 'exactTopic' ('xt' param) only, other params are empty.
1280nullMagnet :: InfoHash -> Magnet
1281nullMagnet u = Magnet
1282 { exactTopic = u
1283 , displayName = Nothing
1284 , exactLength = Nothing
1285 , manifest = Nothing
1286 , keywordTopic = Nothing
1287 , acceptableSource = Nothing
1288 , exactSource = Nothing
1289 , tracker = Nothing
1290 , supplement = M.empty
1291 }
1292
1293-- | Like 'nullMagnet' but also include 'displayName' ('dn' param).
1294simpleMagnet :: Torrent -> Magnet
1295simpleMagnet Torrent {tInfoDict = InfoDict {..}}
1296 = (nullMagnet idInfoHash)
1297 { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo
1298 }
1299
1300-- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and
1301-- 'tracker' ('tr' param).
1302--
1303detailedMagnet :: Torrent -> Magnet
1304detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce}
1305 = (simpleMagnet t)
1306 { exactLength = Just $ fromIntegral $ contentLength idLayoutInfo
1307 , tracker = tAnnounce
1308 }
1309
1310-----------------------------------------------------------------------
1311
1312parseMagnetStr :: String -> Maybe Magnet
1313parseMagnetStr = either (const Nothing) Just . safeConvert
1314
1315renderMagnetStr :: Magnet -> String
1316renderMagnetStr = show . (convert :: Magnet -> URI)
1317
1318instance Pretty Magnet where
1319 pPrint = PP.text . renderMagnetStr
1320
1321instance Show Magnet where
1322 show = renderMagnetStr
1323 {-# INLINE show #-}
1324
1325instance Read Magnet where
1326 readsPrec _ xs
1327 | Just m <- parseMagnetStr mstr = [(m, rest)]
1328 | otherwise = []
1329 where
1330 (mstr, rest) = L.break (== ' ') xs
1331
1332instance IsString Magnet where
1333 fromString str = fromMaybe (error msg) $ parseMagnetStr str
1334 where
1335 msg = "unable to parse magnet: " ++ str
1336
1337-- | Try to parse magnet link from urlencoded string. Use
1338-- 'safeConvert' to find out error location.
1339--
1340parseMagnet :: Text -> Maybe Magnet
1341parseMagnet = parseMagnetStr . T.unpack
1342{-# INLINE parseMagnet #-}
1343
1344-- | Render magnet link to urlencoded string
1345renderMagnet :: Magnet -> Text
1346renderMagnet = T.pack . renderMagnetStr
1347{-# INLINE renderMagnet #-}
diff --git a/src/Data/Tox/Message.hs b/src/Data/Tox/Message.hs
deleted file mode 100644
index 9f1ce339..00000000
--- a/src/Data/Tox/Message.hs
+++ /dev/null
@@ -1,84 +0,0 @@
1-- | This module assigns meaningful symbolic names to Tox message ids and
2-- classifies messages as lossy or lossless.
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE ViewPatterns #-}
6module Data.Tox.Message where
7
8import Data.Word
9
10-- | The one-byte type code prefix that classifies a 'CryptoMessage'.
11newtype MessageID = MessageID Word8 deriving (Eq,Enum,Ord,Bounded)
12pattern Padding = MessageID 0 -- ^ 0 padding (skipped until we hit a non zero (data id) byte)
13pattern PacketRequest = MessageID 1 -- ^ 1 packet request packet (lossy packet)
14pattern KillPacket = MessageID 2 -- ^ 2 connection kill packet (lossy packet)
15pattern UnspecifiedPacket003 = MessageID 3 -- ^ 3+ unspecified
16pattern PING = MessageID 16 -- ^ 16+ reserved for Messenger usage (lossless packets)
17-- TODO: rename to ALIVE 16
18-- SHARE_RELAYS 17
19-- FRIEND_REQUESTS 18
20pattern ONLINE = MessageID 24 -- 1 byte
21pattern OFFLINE = MessageID 25 -- 1 byte
22-- LOSSLESS_RANGE_SIZE 32
23pattern NICKNAME = MessageID 48 -- up to 129 bytes
24pattern STATUSMESSAGE = MessageID 49 -- up to 1008 bytes
25pattern USERSTATUS = MessageID 50 -- 2 bytes
26pattern TYPING = MessageID 51 -- 2 bytes
27-- LOSSY_RANGE_SIZE 63
28pattern MESSAGE = MessageID 64 -- up to 1373 bytes
29pattern ACTION = MessageID 65 -- up to 1373 bytes
30pattern MSI = MessageID 69
31pattern FILE_SENDREQUEST = MessageID 80 -- 1+1+4+8+32+max255 = up to 301
32pattern FILE_CONTROL = MessageID 81 -- 8 bytes if seek, otherwise 4
33pattern FILE_DATA = MessageID 82 -- up to 1373
34pattern INVITE_GROUPCHAT = MessageID 95
35pattern INVITE_GROUPCHAT0 = MessageID 96 -- 0x60
36-- TODO: rename to INVITE_CONFERENCE 96
37pattern ONLINE_PACKET = MessageID 97 -- 0x61
38pattern DIRECT_GROUPCHAT = MessageID 98 -- 0x62
39-- TODO: rename to DIRECT_CONFERENCE 98
40pattern MESSAGE_GROUPCHAT = MessageID 99 -- 0x63
41-- TODO: rename to MESSAGE_CONFERENCE 99
42-- LOSSLESS_RANGE_START 160
43pattern MessengerLossy192 = MessageID 192 -- ^ 192+ reserved for Messenger usage (lossy packets)
44pattern LOSSY_GROUPCHAT = MessageID 199 -- 0xC7
45pattern Messenger255 = MessageID 255 -- ^ 255 reserved for Messenger usage (lossless packet)
46
47instance Show MessageID where
48 show Padding = "Padding"
49 show PacketRequest = "PacketRequest"
50 show KillPacket = "KillPacket"
51 show UnspecifiedPacket003 = "UnspecifiedPacket003"
52 show PING = "PING"
53 show ONLINE = "ONLINE"
54 show OFFLINE = "OFFLINE"
55 show NICKNAME = "NICKNAME"
56 show STATUSMESSAGE = "STATUSMESSAGE"
57 show USERSTATUS = "USERSTATUS"
58 show TYPING = "TYPING"
59 show MESSAGE = "MESSAGE"
60 show ACTION = "ACTION"
61 show MSI = "MSI"
62 show FILE_SENDREQUEST = "FILE_SENDREQUEST"
63 show FILE_CONTROL = "FILE_CONTROL"
64 show FILE_DATA = "FILE_DATA"
65 show INVITE_GROUPCHAT = "INVITE_GROUPCHAT"
66 show ONLINE_PACKET = "ONLINE_PACKET"
67 show DIRECT_GROUPCHAT = "DIRECT_GROUPCHAT"
68 show MESSAGE_GROUPCHAT = "MESSAGE_GROUPCHAT"
69 show MessengerLossy192 = "MessengerLossy192"
70 show LOSSY_GROUPCHAT = "LOSSY_GROUPCHAT"
71 show Messenger255 = "Messenger255"
72 show (MessageID n) = "MessageID " ++ show n
73
74data LossyOrLossless = Lossless | Lossy
75 deriving (Eq,Ord,Enum,Show,Bounded)
76
77-- | Classify a packet as lossy or lossless.
78lossyness :: MessageID -> LossyOrLossless
79lossyness (fromEnum -> x) | x < 3 = Lossy
80lossyness (fromEnum -> x) | {-16 <= x,-} x < 192 = Lossless
81lossyness (fromEnum -> x) | 192 <= x, x < 255 = Lossy
82lossyness (fromEnum -> 255) = Lossless
83
84
diff --git a/src/Data/Tox/Msg.hs b/src/Data/Tox/Msg.hs
deleted file mode 100644
index 66ec6eb1..00000000
--- a/src/Data/Tox/Msg.hs
+++ /dev/null
@@ -1,311 +0,0 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TypeFamilies #-}
11module Data.Tox.Msg where
12
13import Crypto.Error
14import qualified Crypto.PubKey.Ed25519 as Ed25519
15import Data.ByteArray as BA
16import Data.ByteString as B
17import Data.Dependent.Sum
18import Data.Functor.Contravariant
19import Data.Functor.Identity
20import Data.GADT.Compare
21import Data.GADT.Show
22import Data.Monoid
23import Data.Serialize
24import Data.Text as T
25import Data.Text.Encoding as T
26import Data.Typeable
27import Data.Word
28import GHC.TypeLits
29
30import Crypto.Tox
31import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers)
32import Network.Tox.NodeId
33
34newtype Unknown = Unknown B.ByteString deriving (Eq,Show)
35newtype Padded = Padded B.ByteString deriving (Eq,Show)
36
37-- The 'UserStatus' equivalent in Presence is:
38--
39-- data JabberShow = Offline
40-- | ExtendedAway
41-- | Away -- Tox equiv: Away (1)
42-- | DoNotDisturb -- Tox equiv: Busy (2)
43-- | Available -- Tox equiv: Online (0)
44-- | Chatty
45-- deriving (Show,Enum,Ord,Eq,Read)
46--
47-- The Enum instance on 'UserStatus' is not arbitrary. It corresponds
48-- to on-the-wire id numbers.
49data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum)
50
51instance Serialize UserStatus where
52 get = do
53 x <- get :: Get Word8
54 return (toEnum8 x)
55 put x = put (fromEnum8 x)
56
57
58newtype MissingPackets = MissingPackets [Word32]
59 deriving (Eq,Show)
60
61data Msg (n :: Nat) t where
62 Padding :: Msg 0 Padded
63 PacketRequest :: Msg 1 MissingPackets
64 KillPacket :: Msg 2 ()
65 ALIVE :: Msg 16 ()
66 SHARE_RELAYS :: Msg 17 Unknown
67 FRIEND_REQUESTS :: Msg 18 Unknown
68 ONLINE :: Msg 24 ()
69 OFFLINE :: Msg 25 ()
70 NICKNAME :: Msg 48 Text
71 STATUSMESSAGE :: Msg 49 Text
72 USERSTATUS :: Msg 50 UserStatus
73 TYPING :: Msg 51 Bool
74 MESSAGE :: Msg 64 Text
75 ACTION :: Msg 65 Text
76 MSI :: Msg 69 Unknown
77 FILE_SENDREQUEST :: Msg 80 Unknown
78 FILE_CONTROL :: Msg 81 Unknown
79 FILE_DATA :: Msg 82 Unknown
80 INVITE_GROUPCHAT :: Msg 95 Invite
81 INVITE_CONFERENCE :: Msg 96 Unknown
82 ONLINE_PACKET :: Msg 97 Unknown
83 DIRECT_CONFERENCE :: Msg 98 Unknown
84 MESSAGE_CONFERENCE :: Msg 99 Unknown
85 LOSSY_CONFERENCE :: Msg 199 Unknown
86
87deriving instance Show (Msg n a)
88
89msgbyte :: KnownNat n => Msg n a -> Word8
90msgbyte m = fromIntegral (natVal $ proxy m)
91 where proxy :: Msg n a -> Proxy n
92 proxy _ = Proxy
93
94data Pkt a where Pkt :: (KnownNat n, Packet a, KnownMsg n) => Msg n a -> Pkt a
95
96deriving instance (Show (Pkt a))
97
98type CryptoMessage = DSum Pkt Identity
99
100msgID (Pkt mid :=> Identity _) = M mid
101
102-- TODO
103instance GShow Pkt where gshowsPrec = showsPrec
104instance ShowTag Pkt Identity where
105 showTaggedPrec (Pkt _) = showsPrec
106
107instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
108instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
109
110someMsgVal :: KnownMsg n => Msg n a -> SomeMsg
111someMsgVal m = msgid (proxy m)
112 where proxy :: Msg n a -> Proxy n
113 proxy _ = Proxy
114
115class KnownMsg (n::Nat) where msgid :: proxy n -> SomeMsg
116
117instance KnownMsg 0 where msgid _ = M Padding
118instance KnownMsg 1 where msgid _ = M PacketRequest
119instance KnownMsg 2 where msgid _ = M KillPacket
120instance KnownMsg 16 where msgid _ = M ALIVE
121instance KnownMsg 17 where msgid _ = M SHARE_RELAYS
122instance KnownMsg 18 where msgid _ = M FRIEND_REQUESTS
123instance KnownMsg 24 where msgid _ = M ONLINE
124instance KnownMsg 25 where msgid _ = M OFFLINE
125instance KnownMsg 48 where msgid _ = M NICKNAME
126instance KnownMsg 49 where msgid _ = M STATUSMESSAGE
127instance KnownMsg 50 where msgid _ = M USERSTATUS
128instance KnownMsg 51 where msgid _ = M TYPING
129instance KnownMsg 64 where msgid _ = M MESSAGE
130instance KnownMsg 65 where msgid _ = M ACTION
131instance KnownMsg 69 where msgid _ = M MSI
132instance KnownMsg 80 where msgid _ = M FILE_SENDREQUEST
133instance KnownMsg 81 where msgid _ = M FILE_CONTROL
134instance KnownMsg 82 where msgid _ = M FILE_DATA
135instance KnownMsg 95 where msgid _ = M INVITE_GROUPCHAT
136instance KnownMsg 96 where msgid _ = M INVITE_CONFERENCE
137instance KnownMsg 97 where msgid _ = M ONLINE_PACKET
138instance KnownMsg 98 where msgid _ = M DIRECT_CONFERENCE
139instance KnownMsg 99 where msgid _ = M MESSAGE_CONFERENCE
140
141msgTag :: Word8 -> Maybe SomeMsg
142msgTag 0 = Just $ M Padding
143msgTag 1 = Just $ M PacketRequest
144msgTag 2 = Just $ M KillPacket
145msgTag 16 = Just $ M ALIVE
146msgTag 17 = Just $ M SHARE_RELAYS
147msgTag 18 = Just $ M FRIEND_REQUESTS
148msgTag 24 = Just $ M ONLINE
149msgTag 25 = Just $ M OFFLINE
150msgTag 48 = Just $ M NICKNAME
151msgTag 49 = Just $ M STATUSMESSAGE
152msgTag 50 = Just $ M USERSTATUS
153msgTag 51 = Just $ M TYPING
154msgTag 64 = Just $ M MESSAGE
155msgTag 65 = Just $ M ACTION
156msgTag 69 = Just $ M MSI
157msgTag 80 = Just $ M FILE_SENDREQUEST
158msgTag 81 = Just $ M FILE_CONTROL
159msgTag 82 = Just $ M FILE_DATA
160msgTag 95 = Just $ M INVITE_GROUPCHAT
161msgTag 96 = Just $ M INVITE_CONFERENCE
162msgTag 97 = Just $ M ONLINE_PACKET
163msgTag 98 = Just $ M DIRECT_CONFERENCE
164msgTag 99 = Just $ M MESSAGE_CONFERENCE
165msgTag _ = Nothing
166
167
168class (Typeable t, Eq t, Show t, Sized t) => Packet t where
169 getPacket :: Word32 -> Get t
170 putPacket :: Word32 -> t -> Put
171 default getPacket :: Serialize t => Word32 -> Get t
172 getPacket _ = get
173 default putPacket :: Serialize t => Word32 -> t -> Put
174 putPacket _ t = put t
175
176instance Sized UserStatus where size = ConstSize 1
177instance Packet UserStatus
178
179instance Sized () where size = ConstSize 0
180instance Packet () where
181 getPacket _ = return ()
182 putPacket _ _ = return ()
183
184instance Sized MissingPackets where size = VarSize $ \(MissingPackets ws) -> Prelude.length ws
185instance Packet MissingPackets where
186 getPacket seqno = do
187 bs <- B.unpack <$> (remaining >>= getBytes)
188 return $ MissingPackets (decompressSequenceNumbers seqno bs)
189 putPacket seqno (MissingPackets ws) = do
190 mapM_ putWord8 $ compressSequenceNumbers seqno ws
191
192instance Sized Unknown where size = VarSize $ \(Unknown bs) -> B.length bs
193instance Packet Unknown where
194 getPacket _ = Unknown <$> (remaining >>= getBytes)
195 putPacket _ (Unknown bs) = putByteString bs
196
197instance Sized Padded where size = VarSize $ \(Padded bs) -> B.length bs
198instance Packet Padded where
199 getPacket _ = Padded <$> (remaining >>= getBytes)
200 putPacket _ (Padded bs) = putByteString bs
201
202instance Sized Text where size = VarSize (B.length . T.encodeUtf8)
203instance Packet Text where
204 getPacket _ = T.decodeUtf8 <$> (remaining >>= getBytes)
205 putPacket _ = putByteString . T.encodeUtf8
206
207instance Sized Bool where size = ConstSize 1
208instance Packet Bool where
209 getPacket _ = (/= 0) <$> getWord8
210 putPacket _ False = putWord8 0
211 putPacket _ True = putWord8 1
212
213data SomeMsg where
214 M :: (KnownMsg n, KnownNat n, Packet t) => Msg n t -> SomeMsg
215
216instance Eq SomeMsg where
217 M m == M n = msgbyte m == msgbyte n
218
219instance Show SomeMsg where
220 show (M m) = show m
221
222toEnum8 :: (Enum a, Integral word8) => word8 -> a
223toEnum8 = toEnum . fromIntegral
224
225fromEnum8 :: Enum a => a -> Word8
226fromEnum8 = fromIntegral . fromEnum
227
228data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded)
229
230someLossyness (M m) = lossyness m
231
232lossyness :: KnownNat n => Msg n t -> LossyOrLossless
233lossyness m = case msgbyte m of
234 x | x < 3 -> Lossy
235 | {-16 <= x,-} x < 192 -> Lossless
236 | 192 <= x, x < 255 -> Lossy
237 | otherwise -> Lossless
238
239
240newtype ChatID = ChatID Ed25519.PublicKey
241 deriving Eq
242
243instance Sized ChatID where size = ConstSize 32
244
245instance Serialize ChatID where
246 get = do
247 bs <- getBytes 32
248 case Ed25519.publicKey bs of
249 CryptoPassed ed -> return $ ChatID ed
250 CryptoFailed e -> fail (show e)
251 put (ChatID ed) = putByteString $ BA.convert ed
252
253instance Read ChatID where
254 readsPrec _ s
255 | Right bs <- parseToken32 s
256 , CryptoPassed ed <- Ed25519.publicKey bs
257 = [ (ChatID ed, Prelude.drop 43 s) ]
258 | otherwise = []
259
260instance Show ChatID where
261 show (ChatID ed) = showToken32 ed
262
263data InviteType = GroupInvite { groupName :: Text }
264 | AcceptedInvite
265 | ConfirmedInvite { inviteNodes :: [NodeInfo] }
266 deriving (Eq,Show)
267
268instance Sized InviteType where
269 size = VarSize $ \x -> case x of
270 GroupInvite name -> B.length (T.encodeUtf8 name)
271 AcceptedInvite -> 0
272 ConfirmedInvite ns -> 0 -- TODO: size of node list.
273
274data Invite = Invite
275 { inviteChatID :: ChatID
276 , inviteChatKey :: PublicKey
277 , invite :: InviteType
278 }
279 deriving (Eq,Show)
280
281instance Sized Invite where
282 size = contramap inviteChatID size
283 <> contramap (key2id . inviteChatKey) size
284 <> contramap invite size
285
286instance Serialize Invite where
287 get = do
288 group_packet_id <- getWord8 -- expecting 254=GP_FRIEND_INVITE
289 invite_type <- getWord8
290 chatid <- get
291 chatkey <- getPublicKey
292 Invite chatid chatkey <$> case invite_type of
293 0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state.
294 return $ GroupInvite $ decodeUtf8 bs
295 1 -> return AcceptedInvite
296 2 -> return $ ConfirmedInvite [] -- TODO: decode nodes
297
298 put x = do
299 putWord8 254 -- GP_FRIEND_INVITE
300 putWord8 $ case invite x of
301 GroupInvite {} -> 0 -- GROUP_INVITE
302 AcceptedInvite -> 1 -- GROUP_INVITE_ACCEPTED
303 ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION
304 put $ inviteChatID x
305 putPublicKey $ inviteChatKey x
306 case invite x of
307 GroupInvite name -> putByteString $ encodeUtf8 name
308 AcceptedInvite -> return ()
309 ConfirmedInvite ns -> return () -- TODO: encode nodes.
310
311instance Packet Invite where
diff --git a/src/Data/Tox/Onion.hs b/src/Data/Tox/Onion.hs
deleted file mode 100644
index bd802c75..00000000
--- a/src/Data/Tox/Onion.hs
+++ /dev/null
@@ -1,1029 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE PartialTypeSignatures #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19module Data.Tox.Onion where
20
21
22import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
23import Network.QueryResponse
24import Crypto.Tox hiding (encrypt,decrypt)
25import Network.Tox.NodeId
26import qualified Crypto.Tox as ToxCrypto
27import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo)
28
29import Control.Applicative
30import Control.Arrow
31import Control.Concurrent.STM
32import Control.Monad
33import qualified Data.ByteString as B
34 ;import Data.ByteString (ByteString)
35import Data.Data
36import Data.Function
37import Data.Functor.Contravariant
38import Data.Functor.Identity
39#if MIN_VERSION_iproute(1,7,4)
40import Data.IP hiding (fromSockAddr)
41#else
42import Data.IP
43#endif
44import Data.Maybe
45import Data.Monoid
46import Data.Serialize as S
47import Data.Type.Equality
48import Data.Typeable
49import Data.Word
50import GHC.Generics ()
51import GHC.TypeLits
52import Network.Socket
53import qualified Text.ParserCombinators.ReadP as RP
54import Data.Hashable
55import DPut
56import DebugTag
57import Data.Word64Map (fitsInInt)
58import Data.Bits (shiftR,shiftL)
59import qualified Rank2
60
61type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
62
63type UDPTransport = Transport String SockAddr ByteString
64
65
66getOnionAsymm :: Get (Asymm (Encrypted DataToRoute))
67getOnionAsymm = getAliasedAsymm
68
69putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put
70putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a
71
72data OnionMessage (f :: * -> *)
73 = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8)))
74 | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) -- XXX: Why is Nonce8 transmitted in the clear?
75 | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm
76 | OnionToRouteResponse (Asymm (Encrypted DataToRoute))
77
78deriving instance ( Eq (f (AnnounceRequest, Nonce8))
79 , Eq (f AnnounceResponse)
80 , Eq (f DataToRoute)
81 ) => Eq (OnionMessage f)
82
83deriving instance ( Ord (f (AnnounceRequest, Nonce8))
84 , Ord (f AnnounceResponse)
85 , Ord (f DataToRoute)
86 ) => Ord (OnionMessage f)
87
88deriving instance ( Show (f (AnnounceRequest, Nonce8))
89 , Show (f AnnounceResponse)
90 , Show (f DataToRoute)
91 ) => Show (OnionMessage f)
92
93instance Data (OnionMessage Encrypted) where
94 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
95 toConstr _ = error "OnionMessage.toConstr"
96 gunfold _ _ = error "OnionMessage.gunfold"
97#if MIN_VERSION_base(4,2,0)
98 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage"
99#else
100 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionMessage"
101#endif
102
103instance Rank2.Functor OnionMessage where
104 f <$> m = mapPayload (Proxy :: Proxy Serialize) f m
105
106instance Payload Serialize OnionMessage where
107 mapPayload _ f (OnionAnnounce a) = OnionAnnounce (fmap f a)
108 mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a)
109 mapPayload _ f (OnionToRoute k a) = OnionToRoute k a
110 mapPayload _ f (OnionToRouteResponse a) = OnionToRouteResponse a
111
112
113msgNonce :: OnionMessage f -> Nonce24
114msgNonce (OnionAnnounce a) = asymmNonce a
115msgNonce (OnionAnnounceResponse _ n24 _) = n24
116msgNonce (OnionToRoute _ a) = asymmNonce a
117msgNonce (OnionToRouteResponse a) = asymmNonce a
118
119data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey
120 deriving (Eq,Show)
121
122data OnionDestination r
123 = OnionToOwner
124 { onionNodeInfo :: NodeInfo
125 , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us.
126 }
127 | OnionDestination
128 { onionAliasSelector' :: AliasSelector
129 , onionNodeInfo :: NodeInfo
130 , onionRouteSpec :: Maybe r -- ^ Our own onion-path.
131 }
132 deriving Show
133
134onionAliasSelector :: OnionDestination r -> AliasSelector
135onionAliasSelector (OnionToOwner {} ) = SearchingAlias
136onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel
137
138onionKey :: OnionDestination r -> PublicKey
139onionKey od = id2key . nodeId $ onionNodeInfo od
140
141instance Sized (OnionMessage Encrypted) where
142 size = VarSize $ \case
143 OnionAnnounce a -> case size of ConstSize n -> n + 1
144 VarSize f -> f a + 1
145 OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33
146 VarSize f -> f x + 33
147 OnionToRoute pubkey a -> case size of ConstSize n -> n + 33
148 VarSize f -> f a + 33
149 OnionToRouteResponse a -> case size of ConstSize n -> n + 1
150 VarSize f -> f a + 1
151
152instance Serialize (OnionMessage Encrypted) where
153 get = do
154 typ <- get
155 case typ :: Word8 of
156 0x83 -> OnionAnnounce <$> getAliasedAsymm
157 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm
158 t -> fail ("Unknown onion payload: " ++ show t)
159 `fromMaybe` getOnionReply t
160 put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAsymm a
161 put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a
162 put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
163 put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAsymm a
164
165onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r)
166onionToOwner asymm ret3 saddr = do
167 ni <- nodeInfo (key2id $ senderKey asymm) saddr
168 return $ OnionToOwner ni ret3
169-- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr
170
171
172onion :: Sized msg =>
173 ByteString
174 -> SockAddr
175 -> Get (Asymm (Encrypted msg) -> t)
176 -> Either String (t, OnionDestination r)
177onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
178 oaddr <- onionToOwner asymm ret3 saddr
179 return (f asymm, oaddr)
180
181parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r)))
182 -> (ByteString, SockAddr)
183 -> IO (Either (OnionMessage Encrypted,OnionDestination r)
184 (ByteString,SockAddr))
185parseOnionAddr lookupSender (msg,saddr)
186 | Just (typ,bs) <- B.uncons msg
187 , let right = Right (msg,saddr)
188 query = return . either (const right) Left
189 = case typ of
190 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request
191 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request
192 _ -> case flip runGet bs <$> getOnionReply typ of
193 Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do
194 maddr <- lookupSender saddr n8
195 maybe (return right) -- Response unsolicited or too late.
196 (return . Left . \od -> (msg,od))
197 maddr
198 Just (Right msg@(OnionToRouteResponse asym)) -> do
199 let ni = asymNodeInfo saddr asym
200 return $ Left (msg, OnionDestination SearchingAlias ni Nothing)
201 _ -> return right
202
203getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted))
204getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get
205getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm
206getOnionReply _ = Nothing
207
208putOnionMsg :: OnionMessage Encrypted -> Put
209putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a
210putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a
211putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
212putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a
213
214newtype RouteId = RouteId Int
215 deriving Show
216
217
218-- We used to derive the RouteId from the Nonce8 associated with the query.
219-- This is problematic because a nonce generated by toxcore will not validate
220-- if it is received via a different route than it was issued. This is
221-- described by the Tox spec:
222--
223-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current
224-- time, some secret bytes generated when the instance is created, the
225-- current time divided by a 20 second timeout, the public key of the
226-- requester and the source ip/port that the packet was received from. Since
227-- the ip/port that the packet was received from is in the `ping_id`, the
228-- announce packets being sent with a ping id must be sent using the same
229-- path as the packet that we received the `ping_id` from or announcing will
230-- fail.
231--
232-- The original idea was:
233--
234-- > routeId :: Nonce8 -> RouteId
235-- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12
236--
237-- Instead, we'll just hash the destination node id.
238routeId :: NodeId -> RouteId
239routeId nid = RouteId $ mod (hash nid) 12
240
241
242
243forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport
244forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP }
245
246forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a
247forwardAwait crypto udp sendTCP kont = do
248 fix $ \another -> do
249 awaitMessage udp $ \case
250 m@(Just (Right (bs,saddr))) -> case B.head bs of
251 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another
252 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another
253 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another
254 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another
255 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another
256 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another
257 _ -> kont m
258 m -> kont m
259
260forward :: forall c b b1. (Serialize b, Show b) =>
261 (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
262forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs
263
264class SumToThree a b
265
266instance SumToThree N0 N3
267instance SumToThree (S a) b => SumToThree a (S b)
268
269class ( Serialize (ReturnPath n)
270 , Serialize (ReturnPath (S n))
271 , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
272 , ThreeMinus n ~ S (ThreeMinus (S n))
273 ) => LessThanThree n
274
275instance LessThanThree N0
276instance LessThanThree N1
277instance LessThanThree N2
278
279type family ThreeMinus n where
280 ThreeMinus N3 = N0
281 ThreeMinus N2 = N1
282 ThreeMinus N1 = N2
283 ThreeMinus N0 = N3
284
285-- n = 0, 1, 2
286data OnionRequest n = OnionRequest
287 { onionNonce :: Nonce24
288 , onionForward :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
289 , pathFromOwner :: ReturnPath n
290 }
291 deriving (Eq,Ord)
292
293
294{-
295instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n)
296 , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
297 ) => Data (OnionRequest n) where
298 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
299 toConstr _ = error "OnionRequest.toConstr"
300 gunfold _ _ = error "OnionRequest.gunfold"
301#if MIN_VERSION_base(4,2,0)
302 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionRequest"
303#else
304 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionRequest"
305#endif
306-}
307
308
309instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where
310 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
311 toConstr _ = error "OnionResponse.toConstr"
312 gunfold _ _ = error "OnionResponse.gunfold"
313#if MIN_VERSION_base(4,2,0)
314 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionResponse"
315#else
316 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionResponse"
317#endif
318
319deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
320 , KnownNat (PeanoNat n)
321 ) => Show (OnionRequest n)
322
323instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce.
324 size = contramap onionNonce size
325 <> contramap onionForward size
326 <> contramap pathFromOwner size
327
328instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
329 , Sized (ReturnPath n)
330 , Serialize (ReturnPath n)
331 , Typeable n
332 ) => Serialize (OnionRequest n) where
333 get = do
334 -- TODO share code with 'getOnionRequest'
335 n24 <- case eqT :: Maybe (n :~: N3) of
336 Just Refl -> return $ Nonce24 zeros24
337 Nothing -> get
338 cnt <- remaining
339 let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
340 fwd <- isolate fwdsize get
341 rpath <- get
342 return $ OnionRequest n24 fwd rpath
343 put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
344
345-- getRequest :: _
346-- getRequest = OnionRequest <$> get <*> get <*> get
347
348-- n = 1, 2, 3
349-- Attributed (Encrypted (
350
351data OnionResponse n = OnionResponse
352 { pathToOwner :: ReturnPath n
353 , msgToOwner :: OnionMessage Encrypted
354 }
355 deriving (Eq,Ord)
356
357deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)
358
359instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
360 get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
361 . getOnionReply)
362 put (OnionResponse p m) = put p >> putOnionMsg m
363
364instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where
365 size = contramap pathToOwner size <> contramap msgToOwner size
366
367data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
368 | TCPIndex { tcpIndex :: Int, unaddressed :: a }
369 deriving (Eq,Ord,Show)
370
371instance (Typeable a, Serialize a) => Data (Addressed a) where
372 gfoldl f z a = z (either error id . S.decode) `f` S.encode a
373 toConstr _ = error "Addressed.toConstr"
374 gunfold _ _ = error "Addressed.gunfold"
375#if MIN_VERSION_base(4,2,0)
376 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.Addressed"
377#else
378 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.Addressed"
379#endif
380
381instance Sized a => Sized (Addressed a) where
382 size = case size :: Size a of
383 ConstSize n -> ConstSize $ 1{-family-} + 16{-ip-} + 2{-port-} + n
384 VarSize f -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x)
385
386getForwardAddr :: S.Get SockAddr
387getForwardAddr = do
388 addrfam <- S.get :: S.Get Word8
389 ip <- getIP addrfam
390 case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
391 IPv6 _ -> return ()
392 port <- S.get :: S.Get PortNumber
393 return $ setPort port $ toSockAddr ip
394
395
396putForwardAddr :: SockAddr -> S.Put
397putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
398 port <- sockAddrPort saddr
399 ip <- fromSockAddr $ either id id $ either4or6 saddr
400 return $ do
401 case ip of
402 IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
403 IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
404 S.put port
405
406addrToIndex :: SockAddr -> Int
407addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) =
408 if fitsInInt (Proxy :: Proxy Word64)
409 then fromIntegral lo + (fromIntegral hi `shiftL` 32)
410 else fromIntegral lo
411addrToIndex _ = 0
412
413indexToAddr :: Int -> SockAddr
414indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0
415
416-- Note, toxcore would check an address family byte here to detect a TCP-bound
417-- packet, but we instead use the IPv6 id and rely on the port number being
418-- zero. Since it will be symmetrically encrypted for our eyes only, it's not
419-- important to conform on this point.
420instance Serialize a => Serialize (Addressed a) where
421 get = do saddr <- getForwardAddr
422 a <- get
423 case sockAddrPort saddr of
424 Just 0 -> return $ TCPIndex (addrToIndex saddr) a
425 _ -> return $ Addressed saddr a
426 put (Addressed addr x) = putForwardAddr addr >> put x
427 put (TCPIndex idx x) = putForwardAddr (indexToAddr idx) >> put x
428
429data N0
430data S n
431type N1 = S N0
432type N2 = S N1
433type N3 = S N2
434
435deriving instance Data N0
436deriving instance Data n => Data (S n)
437
438class KnownPeanoNat n where
439 peanoVal :: p n -> Int
440
441instance KnownPeanoNat N0 where
442 peanoVal _ = 0
443instance KnownPeanoNat n => KnownPeanoNat (S n) where
444 peanoVal _ = 1 + peanoVal (Proxy :: Proxy n)
445
446type family PeanoNat p where
447 PeanoNat N0 = 0
448 PeanoNat (S n) = 1 + PeanoNat n
449
450data ReturnPath n where
451 NoReturnPath :: ReturnPath N0
452 ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)
453
454deriving instance Eq (ReturnPath n)
455deriving instance Ord (ReturnPath n)
456
457-- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
458instance Sized (ReturnPath N0) where size = ConstSize 0
459instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
460 size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
461 in error "non-constant ReturnPath size")
462 (size :: Size (ReturnPath n))
463
464{-
465instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
466 size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
467-}
468
469instance Serialize (ReturnPath N0) where get = pure NoReturnPath
470 put NoReturnPath = pure ()
471
472instance Serialize (ReturnPath N1) where
473 get = ReturnPath <$> get <*> get
474 put (ReturnPath n24 p) = put n24 >> put p
475
476instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
477 get = ReturnPath <$> get <*> get
478 put (ReturnPath n24 p) = put n24 >> put p
479
480
481{-
482-- This doesn't work because it tried to infer it for (0 - 1)
483instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where
484 get = ReturnPath <$> get <*> get
485 put (ReturnPath n24 p) = put n24 >> put p
486-}
487
488instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
489 show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))
490
491
492-- instance KnownNat n => Serialize (ReturnPath n) where
493-- -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
494-- get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
495-- put (ReturnPath bs) = putByteString bs
496
497
498data Forwarding n msg where
499 NotForwarded :: msg -> Forwarding N0 msg
500 Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg
501
502deriving instance Eq msg => Eq (Forwarding n msg)
503deriving instance Ord msg => Ord (Forwarding n msg)
504
505instance Show msg => Show (Forwarding N0 msg) where
506 show (NotForwarded x) = "NotForwarded "++show x
507
508instance ( KnownNat (PeanoNat (S n))
509 , Show (Encrypted (Addressed (Forwarding n msg)))
510 ) => Show (Forwarding (S n) msg) where
511 show (Forwarding k a) = unwords [ "Forwarding"
512 , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")"
513 , show (key2id k)
514 , show a
515 ]
516
517instance Sized msg => Sized (Forwarding N0 msg)
518 where size = case size :: Size msg of
519 ConstSize n -> ConstSize n
520 VarSize f -> VarSize $ \(NotForwarded x) -> f x
521
522instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
523 where size = ConstSize 32
524 <> contramap (\(Forwarding _ e) -> e)
525 (size :: Size (Encrypted (Addressed (Forwarding n msg))))
526
527instance Serialize msg => Serialize (Forwarding N0 msg) where
528 get = NotForwarded <$> get
529 put (NotForwarded msg) = put msg
530
531instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
532 get = Forwarding <$> getPublicKey <*> get
533 put (Forwarding k x) = putPublicKey k >> put x
534
535{-
536rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)),
537 Serialize (ReturnPath n),
538 Serialize
539 (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) =>
540 TransportCrypto
541 -> (forall x. x -> Addressed x)
542 -> OnionRequest n
543 -> IO (Either String (OnionRequest (S n), SockAddr))
544rewrap crypto saddr (OnionRequest nonce msg rpath) = do
545 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
546 <*> transportNewNonce crypto )
547 peeled <- peelOnion crypto nonce msg
548 return $ peeled >>= \case
549 Addressed dst msg'
550 -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst)
551 _ -> Left "Onion forward to TCP client?"
552-}
553
554handleOnionRequest :: forall a proxy n.
555 ( LessThanThree n
556 , KnownPeanoNat n
557 , Sized (ReturnPath n)
558 , Typeable n
559 ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a
560handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
561 let n = peanoVal rpath
562 dput XOnion $ "handleOnionRequest " ++ show n
563 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
564 <*> transportNewNonce crypto )
565 peeled <- peelOnion crypto nonce msg
566 let showDestination = case saddr () of
567 Addressed a _ -> either show show $ either4or6 a
568 TCPIndex i _ -> "TCP" ++ show [i]
569
570 case peeled of
571 Left e -> do
572 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
573 kont
574 Right (Addressed dst msg') -> do
575 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"]
576 sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
577 kont
578 Right (TCPIndex {}) -> do
579 dput XUnexpected "handleOnionRequest: Onion forward to TCP client?"
580 kont
581
582wrapSymmetric :: Serialize (ReturnPath n) =>
583 SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n)
584wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath)
585
586peelSymmetric :: Serialize (Addressed (ReturnPath n))
587 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
588peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain
589
590
591peelOnion :: Serialize (Addressed (Forwarding n t))
592 => TransportCrypto
593 -> Nonce24
594 -> Forwarding (S n) t
595 -> IO (Either String (Addressed (Forwarding n t)))
596peelOnion crypto nonce (Forwarding k fwd) = do
597 fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
598
599handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n), Typeable n) =>
600 proxy (S n)
601 -> TransportCrypto
602 -> SockAddr
603 -> UDPTransport
604 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send.
605 -> IO a
606 -> OnionResponse (S n)
607 -> IO a
608handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do
609 sym <- atomically $ transportSymmetric crypto
610 case peelSymmetric sym path of
611 Left e -> do
612 -- todo report encryption error
613 let n = peanoVal path
614 dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
615 kont
616 Right (Addressed dst path') -> do
617 sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
618 kont
619 Right (TCPIndex dst path') -> do
620 case peanoVal path' of
621 0 -> sendTCP dst msg
622 n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
623 kont
624
625
626data AnnounceRequest = AnnounceRequest
627 { announcePingId :: Nonce32 -- Ping ID
628 , announceSeeking :: NodeId -- Public key we are searching for
629 , announceKey :: NodeId -- Public key that we want those sending back data packets to use
630 }
631 deriving Show
632
633instance Sized AnnounceRequest where size = ConstSize (32*3)
634
635instance S.Serialize AnnounceRequest where
636 get = AnnounceRequest <$> S.get <*> S.get <*> S.get
637 put (AnnounceRequest p s k) = S.put (p,s,k)
638
639getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3)
640getOnionRequest = do
641 -- Assumes return path is constant size so that we can isolate
642 -- the variable-sized prefix.
643 cnt <- remaining
644 a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n)
645 getAliasedAsymm
646 path <- get
647 return (a,path)
648
649putRequest :: ( KnownPeanoNat n
650 , Serialize (OnionRequest n)
651 , Typeable n
652 ) => OnionRequest n -> Put
653putRequest req = do
654 let tag = 0x80 + fromIntegral (peanoVal req)
655 when (tag <= 0x82) (putWord8 tag)
656 put req
657
658putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
659putResponse resp = do
660 let tag = 0x8f - fromIntegral (peanoVal resp)
661 -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag
662 -- in it's Serialize instance.
663 when (tag /= 0x8f) (putWord8 tag)
664 put resp
665
666
667data KeyRecord = NotStored Nonce32
668 | SendBackKey PublicKey
669 | Acknowledged Nonce32
670 deriving Show
671
672instance Sized KeyRecord where size = ConstSize 33
673
674instance S.Serialize KeyRecord where
675 get = do
676 is_stored <- S.get :: S.Get Word8
677 case is_stored of
678 1 -> SendBackKey <$> getPublicKey
679 2 -> Acknowledged <$> S.get
680 _ -> NotStored <$> S.get
681 put (NotStored n32) = S.put (0 :: Word8) >> S.put n32
682 put (SendBackKey key) = S.put (1 :: Word8) >> putPublicKey key
683 put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
684
685data AnnounceResponse = AnnounceResponse
686 { is_stored :: KeyRecord
687 , announceNodes :: SendNodes
688 }
689 deriving Show
690
691instance Sized AnnounceResponse where
692 size = contramap is_stored size <> contramap announceNodes size
693
694getNodeList :: S.Get [NodeInfo]
695getNodeList = do
696 n <- S.get
697 (:) n <$> (getNodeList <|> pure [])
698
699instance S.Serialize AnnounceResponse where
700 get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
701 put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
702
703data DataToRoute = DataToRoute
704 { dataFromKey :: PublicKey -- Real public key of sender
705 , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c
706 }
707 deriving Show
708
709instance Sized DataToRoute where
710 size = ConstSize 32 <> contramap dataToRoute size
711
712instance Serialize DataToRoute where
713 get = DataToRoute <$> getPublicKey <*> get
714 put (DataToRoute k dta) = putPublicKey k >> put dta
715
716data OnionData
717 = -- | type 0x9c
718 --
719 -- We send this packet every 30 seconds if there is more than one peer (in
720 -- the 8) that says they our friend is announced on them. This packet can
721 -- also be sent through the DHT module as a DHT request packet (see DHT) if
722 -- we know the DHT public key of the friend and are looking for them in the
723 -- DHT but have not connected to them yet. 30 second is a reasonable
724 -- timeout to not flood the network with too many packets while making sure
725 -- the other will eventually receive the packet. Since packets are sent
726 -- through every peer that knows the friend, resending it right away
727 -- without waiting has a high likelihood of failure as the chances of
728 -- packet loss happening to all (up to to 8) packets sent is low.
729 --
730 -- If a friend is online and connected to us, the onion will stop all of
731 -- its actions for that friend. If the peer goes offline it will restart
732 -- searching for the friend as if toxcore was just started.
733 OnionDHTPublicKey DHTPublicKey
734 | -- | type 0x20
735 --
736 --
737 OnionFriendRequest FriendRequest -- 0x20
738 deriving (Eq,Show)
739
740instance Sized OnionData where
741 size = VarSize $ \case
742 OnionDHTPublicKey dhtpk -> case size of
743 ConstSize n -> n -- Override because OnionData probably
744 -- should be treated as variable sized.
745 VarSize f -> f dhtpk
746 -- FIXME: inconsitantly, we have to add in the tag byte for this case.
747 OnionFriendRequest req -> 1 + case size of
748 ConstSize n -> n
749 VarSize f -> f req
750
751instance Serialize OnionData where
752 get = do
753 tag <- get
754 case tag :: Word8 of
755 0x9c -> OnionDHTPublicKey <$> get
756 0x20 -> OnionFriendRequest <$> get
757 _ -> fail $ "Unknown onion data: "++show tag
758 put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
759 put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
760
761selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
762selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
763 = return (skey, pkey)
764selectKey crypto msg rpath = return $ aliasKey crypto rpath
765
766encrypt :: TransportCrypto
767 -> OnionMessage Identity
768 -> OnionDestination r
769 -> IO (OnionMessage Encrypted, OnionDestination r)
770encrypt crypto msg rpath = do
771 (skey,pkey) <- selectKey crypto msg rpath -- source key
772 let okey = onionKey rpath -- destination key
773 encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a
774 encipher1 sk pk n a = Composed $ do
775 secret <- lookupSharedSecret crypto sk pk n
776 return $ ToxCrypto.encrypt secret $ encodePlain a
777 encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a
778 encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d
779 m <- sequenceMessage $ transcode encipher msg
780 return (m, rpath)
781
782decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
783decrypt crypto msg addr = do
784 (skey,pkey) <- selectKey crypto msg addr
785 let decipher1 :: Serialize a =>
786 TransportCrypto -> SecretKey -> Nonce24
787 -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a))
788 -> (IO ∘ Either String ∘ Identity) a
789 decipher1 crypto k n arg = Composed $ do
790 let (sender,e) = either id (senderKey &&& asymmData) arg
791 secret <- lookupSharedSecret crypto k sender n
792 return $ Composed $ do
793 plain <- ToxCrypto.decrypt secret e
794 Identity <$> decodePlain plain
795 decipher :: Serialize a
796 => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a))
797 -> (IO ∘ Either String ∘ Identity) a
798 decipher = (\n -> decipher1 crypto skey n . left (senderkey addr))
799 foo <- sequenceMessage $ transcode decipher msg
800 return $ do
801 msg <- sequenceMessage foo
802 Right (msg, addr)
803
804senderkey :: OnionDestination r -> t -> (PublicKey, t)
805senderkey addr e = (onionKey addr, e)
806
807aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey)
808aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto
809aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto
810
811dhtKey :: TransportCrypto -> (SecretKey,PublicKey)
812dhtKey crypto = (transportSecret &&& transportPublic) crypto
813
814decryptMessage :: Serialize x =>
815 TransportCrypto
816 -> (SecretKey,PublicKey)
817 -> Nonce24
818 -> Either (PublicKey, Encrypted x)
819 (Asymm (Encrypted x))
820 -> IO ((Either String ∘ Identity) x)
821decryptMessage crypto (sk,pk) n arg = do
822 let (sender,e) = either id (senderKey &&& asymmData) arg
823 plain = Composed . fmap Identity . (>>= decodePlain)
824 secret <- lookupSharedSecret crypto sk sender n
825 return $ plain $ ToxCrypto.decrypt secret e
826
827sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
828sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
829sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
830sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a
831sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
832-- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
833
834transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g
835transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) }
836transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
837transcode f (OnionToRoute pub a) = OnionToRoute pub a
838transcode f (OnionToRouteResponse a) = OnionToRouteResponse a
839-- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) }
840
841
842data OnionRoute = OnionRoute
843 { routeAliasA :: SecretKey
844 , routeAliasB :: SecretKey
845 , routeAliasC :: SecretKey
846 , routeNodeA :: NodeInfo
847 , routeNodeB :: NodeInfo
848 , routeNodeC :: NodeInfo
849 , routeRelayPort :: Maybe PortNumber
850 }
851
852
853wrapOnion :: Serialize (Forwarding n msg) =>
854 TransportCrypto
855 -> SecretKey
856 -> Nonce24
857 -> PublicKey
858 -> SockAddr
859 -> Forwarding n msg
860 -> IO (Forwarding (S n) msg)
861wrapOnion crypto skey nonce destkey saddr fwd = do
862 let plain = encodePlain $ Addressed saddr fwd
863 secret <- lookupSharedSecret crypto skey destkey nonce
864 return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain
865
866wrapOnionPure :: Serialize (Forwarding n msg) =>
867 SecretKey
868 -> ToxCrypto.State
869 -> SockAddr
870 -> Forwarding n msg
871 -> Forwarding (S n) msg
872wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain)
873 where
874 plain = encodePlain $ Addressed saddr fwd
875
876
877
878-- TODO
879-- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
880--
881-- (1) DHT public key packet (0x9c)
882--
883-- (2) Friend request
884data Rendezvous = Rendezvous
885 { rendezvousKey :: PublicKey
886 , rendezvousNode :: NodeInfo
887 }
888 deriving Eq
889
890instance Show Rendezvous where
891 showsPrec d (Rendezvous k ni)
892 = showsPrec d (key2id k)
893 . (':' :)
894 . showsPrec d ni
895
896instance Read Rendezvous where
897 readsPrec d = RP.readP_to_S $ do
898 rkstr <- RP.munch (/=':')
899 RP.char ':'
900 nistr <- RP.munch (const True)
901 return Rendezvous
902 { rendezvousKey = id2key $ read rkstr
903 , rendezvousNode = read nistr
904 }
905
906
907data AnnouncedRendezvous = AnnouncedRendezvous
908 { remoteUserKey :: PublicKey
909 , rendezvous :: Rendezvous
910 }
911 deriving Eq
912
913instance Show AnnouncedRendezvous where
914 showsPrec d (AnnouncedRendezvous remote rendez)
915 = showsPrec d (key2id remote)
916 . (':' :)
917 . showsPrec d rendez
918
919instance Read AnnouncedRendezvous where
920 readsPrec d = RP.readP_to_S $ do
921 ukstr <- RP.munch (/=':')
922 RP.char ':'
923 rkstr <- RP.munch (/=':')
924 RP.char ':'
925 nistr <- RP.munch (const True)
926 return AnnouncedRendezvous
927 { remoteUserKey = id2key $ read ukstr
928 , rendezvous = Rendezvous
929 { rendezvousKey = id2key $ read rkstr
930 , rendezvousNode = read nistr
931 }
932 }
933
934
935selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
936selectAlias crypto pkey = do
937 ks <- filter (\(sk,pk) -> pk == id2key pkey)
938 <$> userKeys crypto
939 maybe (return SearchingAlias)
940 (return . uncurry AnnouncingAlias)
941 (listToMaybe ks)
942
943
944parseDataToRoute
945 :: TransportCrypto
946 -> (OnionMessage Encrypted,OnionDestination r)
947 -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
948parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
949 ks <- atomically $ userKeys crypto
950
951 omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto)
952 (asymmNonce dta)
953 (Right dta) -- using Asymm{senderKey} as remote key
954 let eOuter = fmap runIdentity $ uncomposed omsg0
955
956 anyRight [] f = return $ Left "parseDataToRoute: no user key"
957 anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right)
958
959 -- TODO: We don't currently have a way to look up which user key we
960 -- announced using along this onion route. Therefore, for now, we will
961 -- try all our user keys to see if any can decrypt the packet.
962 eInner <- case eOuter of
963 Left e -> return $ Left e
964 Right dtr -> anyRight ks $ \(sk,pk) -> do
965 omsg0 <- decryptMessage crypto
966 (sk,pk)
967 (asymmNonce dta)
968 (Left (dataFromKey dtr, dataToRoute dtr))
969 return $ do
970 omsg <- fmap runIdentity . uncomposed $ omsg0
971 Right (pk,dtr,omsg)
972
973 let e = do
974 (pk,dtr,omsg) <- eInner
975 return ( (pk, omsg)
976 , AnnouncedRendezvous
977 (dataFromKey dtr)
978 $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
979 r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
980 -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
981 case e of
982 Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
983 Right _ -> return ()
984 dput XMisc $ unlines
985 [ "parseDataToRoute " ++ either id (const "Right") e
986 , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
987 , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
988 , " outer.me = " ++ show (key2id $ rendezvousPublic crypto)
989 , " outer.them = " ++ show (key2id $ senderKey dta)
990 ]
991 return r
992parseDataToRoute _ msg = return $ Right msg
993
994encodeDataToRoute :: TransportCrypto
995 -> ((PublicKey,OnionData),AnnouncedRendezvous)
996 -> IO (Maybe (OnionMessage Encrypted,OnionDestination r))
997encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do
998 nonce <- atomically $ transportNewNonce crypto
999 asel <- atomically $ selectAlias crypto (key2id me)
1000 let (sk,pk) = case asel of
1001 AnnouncingAlias sk pk -> (sk,pk)
1002 _ -> (onionAliasSecret crypto, onionAliasPublic crypto)
1003 innerSecret <- lookupSharedSecret crypto sk toxid nonce
1004 let plain = encodePlain $ DataToRoute { dataFromKey = pk
1005 , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg
1006 }
1007 outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce
1008 let dta = ToxCrypto.encrypt outerSecret plain
1009 dput XOnion $ unlines
1010 [ "encodeDataToRoute me=" ++ show (key2id me)
1011 , " dhtpk=" ++ case omsg of
1012 OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg)
1013 OnionFriendRequest fr -> "friend request"
1014 , " ns=" ++ case omsg of
1015 OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg)
1016 OnionFriendRequest fr -> "friend request"
1017 , " crypto inner.me =" ++ show (key2id pk)
1018 , " inner.you=" ++ show (key2id toxid)
1019 , " outer.me =" ++ show (key2id $ onionAliasPublic crypto)
1020 , " outer.you=" ++ show (key2id pub)
1021 , " " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni))
1022 , " " ++ show dta
1023 ]
1024 return $ Just ( OnionToRoute toxid -- Public key of destination node
1025 Asymm { senderKey = onionAliasPublic crypto
1026 , asymmNonce = nonce
1027 , asymmData = dta
1028 }
1029 , OnionDestination SearchingAlias ni Nothing )
diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
deleted file mode 100644
index c563db8d..00000000
--- a/src/Data/Tox/Relay.hs
+++ /dev/null
@@ -1,232 +0,0 @@
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Data.Tox.Relay where
11
12import Data.Aeson (ToJSON(..),FromJSON(..))
13import qualified Data.Aeson as JSON
14import Data.ByteString as B
15import Data.Data
16import Data.Functor.Contravariant
17import Data.Hashable
18import qualified Data.HashMap.Strict as HashMap
19import Data.Monoid
20import Data.Serialize
21import qualified Data.Vector as Vector
22import Data.Word
23import Network.Socket
24import qualified Rank2
25import qualified Text.ParserCombinators.ReadP as RP
26
27import Crypto.Tox
28import Data.Tox.Onion
29import qualified Network.Tox.NodeId as UDP
30
31newtype ConId = ConId Word8
32 deriving (Eq,Show,Ord,Data,Serialize)
33
34badcon :: ConId
35badcon = ConId 0
36
37-- Maps to a range -120 .. 119
38c2key :: ConId -> Maybe Int
39c2key (ConId x) | x < 16 = Nothing
40 | otherwise = Just $ case divMod (x - 15) 2 of
41 (q,0) -> negate $ fromIntegral q
42 (q,1) -> fromIntegral q
43
44-- Maps to range 16 .. 255
45-- negatives become odds
46key2c :: Int -> ConId
47key2c y = ConId $ if y < 0 then 15 + fromIntegral (negate y * 2)
48 else 16 + fromIntegral (y * 2)
49
50data RelayPacket
51 = RoutingRequest PublicKey
52 | RoutingResponse ConId PublicKey -- 0 for refusal, 16-255 for success.
53 | ConnectNotification ConId
54 | DisconnectNotification ConId
55 | RelayPing Nonce8
56 | RelayPong Nonce8
57 | OOBSend PublicKey ByteString
58 | OOBRecv PublicKey ByteString
59 | OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0)
60 | OnionPacketResponse (OnionMessage Encrypted)
61 -- 0x0A through 0x0F reserved for future use.
62 | RelayData ByteString ConId
63 deriving (Eq,Ord,Show,Data)
64
65newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 }
66 deriving (Eq,Ord,Show)
67
68pattern PingPacket = PacketNumber 4
69pattern OnionPacketID = PacketNumber 8
70
71packetNumber :: RelayPacket -> PacketNumber
72packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed.
73packetNumber rp = PacketNumber $ fromIntegral $ pred $ constrIndex $ toConstr rp
74
75instance Sized RelayPacket where
76 size = mappend (ConstSize 1) $ VarSize $ \x -> case x of
77 RoutingRequest k -> 32
78 RoutingResponse rpid k -> 33
79 ConnectNotification conid -> 1
80 DisconnectNotification conid -> 1
81 RelayPing pingid -> 8
82 RelayPong pingid -> 8
83 OOBSend k bs -> 32 + B.length bs
84 OOBRecv k bs -> 32 + B.length bs
85 OnionPacket n24 query -> 24 + case contramap (`asTypeOf` query) size of
86 ConstSize n -> n
87 VarSize f -> f query
88 OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of
89 ConstSize n -> n
90 VarSize f -> f answer
91 RelayData bs _ -> B.length bs
92
93instance Serialize RelayPacket where
94
95 get = do
96 pktid <- getWord8
97 case pktid of
98 0 -> RoutingRequest <$> getPublicKey
99 1 -> RoutingResponse <$> get <*> getPublicKey
100 2 -> ConnectNotification <$> get
101 3 -> DisconnectNotification <$> get
102 4 -> RelayPing <$> get
103 5 -> RelayPong <$> get
104 6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes)
105 7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes)
106 8 -> OnionPacket <$> get <*> get
107 9 -> OnionPacketResponse <$> get
108 conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes)
109
110 put rp = do
111 putWord8 $ packetNumberToWord8 $ packetNumber rp
112 case rp of
113 RoutingRequest k -> putPublicKey k
114 RoutingResponse rpid k -> put rpid >> putPublicKey k
115 ConnectNotification conid -> put conid
116 DisconnectNotification conid -> put conid
117 RelayPing pingid -> put pingid
118 RelayPong pingid -> put pingid
119 OOBSend k bs -> putPublicKey k >> putByteString bs
120 OOBRecv k bs -> putPublicKey k >> putByteString bs
121 OnionPacket n24 query -> put n24 >> put query
122 OnionPacketResponse answer -> put answer
123 RelayData bs _ -> putByteString bs
124
125-- | Initial client-to-server handshake message.
126newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData))
127
128deriving instance Show (f HelloData) => Show (Hello f)
129
130helloFrom :: Hello f -> PublicKey
131helloFrom (Hello x) = senderKey x
132
133helloNonce :: Hello f -> Nonce24
134helloNonce (Hello x) = asymmNonce x
135
136helloData :: Hello f -> f HelloData
137helloData (Hello x) = asymmData x
138
139instance Rank2.Functor Hello where
140 f <$> Hello (Asymm k n dta) = Hello $ Asymm k n (f dta)
141
142instance Payload Serialize Hello where
143 mapPayload _ f (Hello (Asymm k n dta)) = Hello $ Asymm k n (f dta)
144
145instance Rank2.Foldable Hello where
146 foldMap f (Hello (Asymm k n dta)) = f dta
147
148instance Rank2.Traversable Hello where
149 traverse f (Hello (Asymm k n dta)) = Hello . Asymm k n <$> f dta
150
151instance Sized (Hello Encrypted) where
152 size = ConstSize 56 <> contramap helloData size
153
154instance Serialize (Hello Encrypted) where
155 get = Hello <$> getAsymm
156 put (Hello asym) = putAsymm asym
157
158data HelloData = HelloData
159 { sessionPublicKey :: PublicKey
160 , sessionBaseNonce :: Nonce24
161 }
162 deriving Show
163
164instance Sized HelloData where size = ConstSize 56
165
166instance Serialize HelloData where
167 get = HelloData <$> getPublicKey <*> get
168 put (HelloData k n) = putPublicKey k >> put n
169
170-- | Handshake server-to-client response packet.
171data Welcome (f :: * -> *) = Welcome
172 { welcomeNonce :: Nonce24
173 , welcomeData :: f HelloData
174 }
175
176deriving instance Show (f HelloData) => Show (Welcome f)
177
178instance Rank2.Functor Welcome where
179 f <$> Welcome n dta = Welcome n (f dta)
180
181instance Payload Serialize Welcome where
182 mapPayload _ f (Welcome n dta) = Welcome n (f dta)
183
184instance Rank2.Foldable Welcome where
185 foldMap f (Welcome _ dta) = f dta
186
187instance Rank2.Traversable Welcome where
188 traverse f (Welcome n dta) = Welcome n <$> f dta
189
190instance Sized (Welcome Encrypted) where
191 size = ConstSize 24 <> contramap welcomeData size
192
193instance Serialize (Welcome Encrypted) where
194 get = Welcome <$> get <*> get
195 put (Welcome n dta) = put n >> put dta
196
197data NodeInfo = NodeInfo
198 { udpNodeInfo :: UDP.NodeInfo
199 , tcpPort :: PortNumber
200 }
201 deriving (Eq,Ord)
202
203instance Read NodeInfo where
204 readsPrec _ = RP.readP_to_S $ do
205 udp <- RP.readS_to_P reads
206 port <- RP.between (RP.char '{') (RP.char '}') $ do
207 mapM_ RP.char ("tcp:" :: String)
208 w16 <- RP.readS_to_P reads
209 return $ fromIntegral (w16 :: Word16)
210 return $ NodeInfo udp port
211
212instance ToJSON NodeInfo where
213 toJSON (NodeInfo udp port) = case (toJSON udp) of
214 JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
215 (JSON.Array $ Vector.fromList
216 [JSON.Number (fromIntegral port)])
217 tbl
218 x -> x -- Shouldn't happen.
219
220instance FromJSON NodeInfo where
221 parseJSON json = do
222 udp <- parseJSON json
223 port <- case json of
224 JSON.Object v -> do
225 portnum:_ <- v JSON..: "tcp_ports"
226 return (fromIntegral (portnum :: Word16))
227 _ -> fail "TCP.NodeInfo: Expected JSON object."
228 return $ NodeInfo udp port
229
230instance Hashable NodeInfo where
231 hashWithSalt s n = hashWithSalt s (udpNodeInfo n)
232
diff --git a/src/Data/Word64Map.hs b/src/Data/Word64Map.hs
deleted file mode 100644
index adc9c27e..00000000
--- a/src/Data/Word64Map.hs
+++ /dev/null
@@ -1,66 +0,0 @@
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE UnboxedTuples #-}
4module Data.Word64Map where
5
6import Data.Bits
7import qualified Data.IntMap as IntMap
8 ;import Data.IntMap (IntMap)
9import Data.Monoid
10import Data.Typeable
11import Data.Word
12
13-- | Since 'Int' may be 32 or 64 bits, this function is provided as a
14-- convenience to test if an integral type, such as 'Data.Word.Word64', can be
15-- safely transformed into an 'Int' for use with 'IntMap'.
16--
17-- Returns 'True' if the proxied type can be losslessly converted to 'Int' using
18-- 'fromIntegral'.
19fitsInInt :: forall proxy word. (Bounded word, Integral word) => proxy word -> Bool
20fitsInInt proxy = (original == casted)
21 where
22 original = div maxBound 2 :: word
23 casted = fromIntegral (fromIntegral original :: Int) :: word
24
25newtype Word64Map a = Word64Map (IntMap (IntMap a))
26
27size :: Word64Map a -> Int
28size (Word64Map m) = getSum $ foldMap (\n -> Sum (IntMap.size n)) m
29
30empty :: Word64Map a
31empty = Word64Map IntMap.empty
32
33-- Warning: This function assumes an 'Int' is either 64 or 32 bits.
34keyFrom64 :: Word64 -> (# Int,Int #)
35keyFrom64 w8 =
36 if fitsInInt (Proxy :: Proxy Word64)
37 then (# fromIntegral w8 , 0 #)
38 else (# fromIntegral (w8 `shiftR` 32), fromIntegral w8 #)
39{-# INLINE keyFrom64 #-}
40
41lookup :: Word64 -> Word64Map b -> Maybe b
42lookup w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 = do
43 m' <- IntMap.lookup hi m
44 IntMap.lookup lo m'
45{-# INLINE lookup #-}
46
47insert :: Word64 -> b -> Word64Map b -> Word64Map b
48insert w8 b (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
49 = Word64Map $ IntMap.alter (Just . maybe (IntMap.singleton lo b)
50 (IntMap.insert lo b))
51 hi
52 m
53{-# INLINE insert #-}
54
55delete :: Word64 -> Word64Map b -> Word64Map b
56delete w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
57 = Word64Map $ IntMap.alter (maybe Nothing
58 (\m' -> case IntMap.delete lo m' of
59 m'' | IntMap.null m'' -> Nothing
60 m'' -> Just m''))
61 hi
62 m
63{-# INLINE delete #-}
64
65
66
diff --git a/src/Data/Wrapper/PSQ.hs b/src/Data/Wrapper/PSQ.hs
deleted file mode 100644
index 4fdeec67..00000000
--- a/src/Data/Wrapper/PSQ.hs
+++ /dev/null
@@ -1,91 +0,0 @@
1{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
4module Data.Wrapper.PSQ
5#if 0
6 ( module Data.Wrapper.PSQ , module Data.PSQueue ) where
7
8import Data.PSQueue hiding (foldr, foldl)
9import qualified Data.PSQueue as PSQueue
10
11type PSQKey k = (Ord k)
12
13-- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface.
14fold' :: (Ord k, Ord p) => (k -> p -> () -> a -> a) -> a -> PSQ k p -> a
15fold' f a q = PSQueue.foldr f' a q
16 where
17 f' (k :-> prio) x = f k prio () x
18
19#else
20 ( module Data.Wrapper.PSQ , module HashPSQ ) where
21
22-- import Data.OrdPSQ as OrdPSQ hiding (insert, map, singleton, minView)
23-- import qualified Data.OrdPSQ as OrdPSQ
24
25import Data.Hashable
26import qualified Data.HashPSQ as Q
27 ;import Data.HashPSQ as HashPSQ hiding (insert, map, minView,
28 singleton)
29import Data.Time.Clock.POSIX (POSIXTime)
30
31-- type PSQ' k p v = HashPSQ k p v
32type PSQ' = HashPSQ
33type PSQ k p = PSQ' k p ()
34
35type Binding' k p v = (k,p,v)
36type Binding k p = Binding' k p ()
37
38type PSQKey k = (Hashable k, Ord k)
39
40pattern (:->) :: k -> p -> Binding k p
41pattern k :-> p <- (k,p,_) where k :-> p = (k,p,())
42
43-- I tried defining (::->) :: (k,v) -> p -> Binding' k p v
44-- but no luck...
45pattern Binding :: k -> v -> p -> Binding' k p v
46pattern Binding k v p <- (k,p,v) where Binding k v p = (k,p,v)
47
48key :: (k,p,v) -> k
49key (k,p,v) = k
50{-# INLINE key #-}
51
52prio :: (k,p,v) -> p
53prio (k,p,v) = p
54{-# INLINE prio #-}
55
56insert :: (PSQKey k, Ord p) => k -> p -> PSQ k p -> PSQ k p
57insert k p q = Q.insert k p () q
58{-# INLINE insert #-}
59
60insert' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v -> PSQ' k p v
61insert' k v p q = Q.insert k p v q
62{-# INLINE insert' #-}
63
64insertWith :: (PSQKey k, Ord p) => (p -> p -> p) -> k -> p -> PSQ k p -> PSQ k p
65insertWith f k p0 q = snd $ Q.alter f' k q
66 where
67 f' (Just (p,())) = ((),Just (f p0 p, ()))
68 f' Nothing = ((),Just (p0,()))
69{-# INLINE insertWith #-}
70
71singleton :: (PSQKey k, Ord p) => k -> p -> PSQ k p
72singleton k p = Q.singleton k p ()
73{-# INLINE singleton #-}
74
75singleton' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v
76singleton' k v p = Q.singleton k p v
77{-# INLINE singleton' #-}
78
79
80minView :: (PSQKey k, Ord p) => PSQ' k p v -> Maybe (Binding' k p v, PSQ' k p v)
81minView q = fmap (\(k,p,v,q') -> (Binding k v p, q')) $ Q.minView q
82{-# INLINE minView #-}
83
84
85-- | Utility to convert a 'POSIXTime' delta into microseconds suitable for
86-- passing to 'threadDelay'.
87toMicroseconds :: POSIXTime -> Int
88toMicroseconds = round . (* 1000) . (* 1000)
89
90
91#endif
diff --git a/src/Data/Wrapper/PSQInt.hs b/src/Data/Wrapper/PSQInt.hs
deleted file mode 100644
index 5badb8b2..00000000
--- a/src/Data/Wrapper/PSQInt.hs
+++ /dev/null
@@ -1,53 +0,0 @@
1{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
4module Data.Wrapper.PSQInt
5#if 0
6 ( module Data.Wrapper.PSQInt , module Data.PSQueue ) where
7
8import Data.PSQueue hiding (foldr, foldl, PSQ)
9import qualified Data.PSQueue as PSQueue
10
11type PSQ p = PSQueue.PSQ Int p
12
13-- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface.
14fold' :: (Ord p) => (Int -> p -> () -> a -> a) -> a -> PSQ p -> a
15fold' f a q = PSQueue.foldr f' a q
16 where
17 f' (k :-> prio) x = f k prio () x
18
19#else
20 ( module Data.Wrapper.PSQInt
21 , module IntPSQ
22 , module Data.Wrapper.PSQ
23 ) where
24
25import Data.Wrapper.PSQ (Binding, pattern (:->), key, prio, toMicroseconds)
26
27import Data.IntPSQ as IntPSQ hiding (insert, map, singleton, minView)
28import qualified Data.IntPSQ as Q
29
30type PSQ p = IntPSQ p ()
31
32type PSQKey = ()
33
34insert :: (Ord p) => Int -> p -> PSQ p -> PSQ p
35insert k p q = Q.insert k p () q
36{-# INLINE insert #-}
37
38insertWith :: (Ord p) => (p -> p -> p) -> Int -> p -> PSQ p -> PSQ p
39insertWith f k p0 q = snd $ Q.alter f' k q
40 where
41 f' (Just (p,())) = ((),Just (f p0 p, ()))
42 f' Nothing = ((),Nothing)
43{-# INLINE insertWith #-}
44
45singleton :: (Ord p) => Int -> p -> PSQ p
46singleton k p = Q.singleton k p ()
47{-# INLINE singleton #-}
48
49minView :: (Ord p) => PSQ p -> Maybe (Binding Int p, PSQ p)
50minView q = fmap (\(k,p,(),q') -> (k :-> p, q')) $ Q.minView q
51{-# INLINE minView #-}
52
53#endif
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:24:53 +0000