From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: 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 --- src/Data/BEncode/Pretty.hs | 81 --- src/Data/Bits/ByteString.hs | 132 ----- src/Data/Digest/CRC32C.hs | 100 ---- src/Data/IntervalSet.hs | 129 ----- src/Data/MinMaxPSQ.hs | 112 ---- src/Data/PacketBuffer.hs | 148 ----- src/Data/PacketQueue.hs | 217 ------- src/Data/Sized.hs | 14 - src/Data/TableMethods.hs | 105 ---- src/Data/Torrent.hs | 1347 ------------------------------------------- src/Data/Tox/Message.hs | 84 --- src/Data/Tox/Msg.hs | 311 ---------- src/Data/Tox/Onion.hs | 1029 --------------------------------- src/Data/Tox/Relay.hs | 232 -------- src/Data/Word64Map.hs | 66 --- src/Data/Wrapper/PSQ.hs | 91 --- src/Data/Wrapper/PSQInt.hs | 53 -- 17 files changed, 4251 deletions(-) delete mode 100644 src/Data/BEncode/Pretty.hs delete mode 100644 src/Data/Bits/ByteString.hs delete mode 100644 src/Data/Digest/CRC32C.hs delete mode 100644 src/Data/IntervalSet.hs delete mode 100644 src/Data/MinMaxPSQ.hs delete mode 100644 src/Data/PacketBuffer.hs delete mode 100644 src/Data/PacketQueue.hs delete mode 100644 src/Data/Sized.hs delete mode 100644 src/Data/TableMethods.hs delete mode 100644 src/Data/Torrent.hs delete mode 100644 src/Data/Tox/Message.hs delete mode 100644 src/Data/Tox/Msg.hs delete mode 100644 src/Data/Tox/Onion.hs delete mode 100644 src/Data/Tox/Relay.hs delete mode 100644 src/Data/Word64Map.hs delete mode 100644 src/Data/Wrapper/PSQ.hs delete mode 100644 src/Data/Wrapper/PSQInt.hs (limited to 'src/Data') 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 @@ -{-# LANGUAGE CPP #-} -module Data.BEncode.Pretty where -- (showBEncode) where - -import Data.BEncode.Types -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding -import qualified Data.ByteString.Base16 as Base16 -#ifdef BENCODE_AESON -import Data.BEncode.BDict hiding (map) -import Data.Aeson.Types hiding (parse) -import Data.Aeson.Encode.Pretty -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Vector as Vector -import Data.Foldable as Foldable -#endif - -{- -unhex :: Text -> BS.ByteString -unhex t = BS.pack $ map unhex1 [0 .. BS.length nibs `div` 2] - where - nibs = encodeUtf8 t - unhex1 i = unnib (BS.index nibs (i * 2)) * 0x10 - + unnib (BS.index nibs (i * 2 + 1)) - unnib a | a <= 0x39 = a - 0x30 - | otherwise = a - (0x41 - 10) - -hex :: BS.ByteString -> Text -hex bs = T.concat $ map (T.pack . printf "%02X") $ BS.unpack bs --} - -#ifdef BENCODE_AESON - -quote_chr :: Char -quote_chr = ' ' - -quote :: Text -> Text -quote t = quote_chr `T.cons` t `T.snoc` quote_chr - -encodeByteString :: BS.ByteString -> Text -encodeByteString s = either (const . decodeUtf8 $ Base16.encode s) quote $ decodeUtf8' s - -decodeByteString :: Text -> BS.ByteString -decodeByteString s - | T.head s==quote_chr = encodeUtf8 (T.takeWhile (/=quote_chr) $ T.drop 1 s) - | otherwise = fst (Base16.decode (encodeUtf8 s)) - -instance ToJSON BValue where - toJSON (BInteger x) = Number $ fromIntegral x - toJSON (BString s) = String $ encodeByteString s - toJSON (BList xs) = Array $ Vector.fromList $ map toJSON xs - toJSON (BDict d) = toJSON d - -instance ToJSON a => ToJSON (BDictMap a) where - toJSON d = Object $ HashMap.fromList $ map convert $ toAscList d - where - convert (k,v) = (encodeByteString k,toJSON v) - -instance FromJSON BValue where - parseJSON (Number x) = pure $ BInteger (truncate x) - parseJSON (Bool x) = pure $ BInteger $ if x then 1 else 0 - parseJSON (String s) = pure $ BString $ decodeByteString s - parseJSON (Array v) = BList <$> traverse parseJSON (Foldable.toList v) - parseJSON (Object d) = BDict <$> parseJSON (Object d) - parseJSON (Null) = pure $ BDict Nil - -instance FromJSON v => FromJSON (BDictMap v) where - parseJSON (Object d) = fromAscList <$> traverse convert (HashMap.toList d) - where - convert (k,v) = (,) (decodeByteString k) <$> parseJSON v - parseJSON _ = fail "Not a BDict" -#endif - -showBEncode :: BValue -> BL.ByteString -#ifdef BENCODE_AESON -showBEncode b = encodePretty $ toJSON b -#else -showBEncode b = BL8.pack (show b) -#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 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -------------------------------------------------------------------------------- --- | --- Module : Data.Bits.ByteString --- Copyright : (c) 2016 Michael Carpenter --- License : BSD3 --- Maintainer : Michael Carpenter --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------- -module Data.Bits.ByteString where - -import Data.Bits -import qualified Data.ByteString as B -import Data.Word - -instance Bits B.ByteString where - - (.&.) a b = B.pack $ B.zipWith (.&.) a b - {-# INLINE (.&.) #-} - - (.|.) a b = B.pack $ B.zipWith (.|.) a b - {-# INLINE (.|.) #-} - - xor a b = B.pack $ B.zipWith xor a b - {-# INLINE xor #-} - - complement = B.map complement - {-# INLINE complement #-} - - shift x i - | i < 0 = x `shiftR` (-i) - | i > 0 = x `shiftL` i - | otherwise = x - {-# INLINE shift #-} - - shiftR bs 0 = bs - shiftR "" _ = B.empty - shiftR bs i - | i `mod` 8 == 0 = - B.take (B.length bs) $ B.append - (B.replicate (i `div` 8) 0) - (B.drop (i `div` 8) bs) - | i `mod` 8 /= 0 = - B.pack $ take (B.length bs) - $ (replicate (i `div` 8) (0 :: Word8)) - ++ (go (i `mod` 8) 0 $ B.unpack (B.take (B.length bs - (i `div` 8)) bs)) - where - go _ _ [] = [] - go j w1 (w2:wst) = (maskR j w1 w2) : go j w2 wst - maskR j w1 w2 = (shiftL w1 (8-j)) .|. (shiftR w2 j) - shiftR _ _ = error "I can't believe you've done this." - {-# INLINE shiftR #-} - - shiftL bs 0 = bs - shiftL "" _ = B.empty - shiftL bs i - | i `mod` 8 == 0 = - B.take (B.length bs) $ B.append - (B.drop (i `div` 8) bs) - (B.replicate (i `div` 8) 0) - | i `mod` 8 /= 0 = - B.pack $ drop ((i `div` 8) - B.length bs) - $ (tail (go (i `mod` 8) 0 $ B.unpack (B.drop (i `div` 8) bs))) - ++ (replicate (i `div` 8) 0) - where - go j w1 [] = [shiftL w1 j] - go j w1 (w2:wst) = (maskL j w1 w2) : go j w2 wst - maskL j w1 w2 = (shiftL w1 j) .|. (shiftR w2 (8-j)) - shiftL _ _ = error "I can't believe you've done this." - {-# INLINE shiftL #-} - - rotate x i - | i < 0 = x `rotateR` (-i) - | i > 0 = x `rotateL` i - | otherwise = x - {-# INLINE rotate #-} - - rotateR bs 0 = bs - rotateR bs i - | B.length bs == 0 = B.empty - | B.length bs == 1 = B.singleton (rotateR (bs `B.index` 0) i) - | B.length bs > 1 = do - let shiftedWords = - B.append - (B.drop (nWholeWordsToShift i) bs) - (B.take (nWholeWordsToShift i) bs) - let tmpShiftedBits = (shiftR shiftedWords (i `mod` 8)) - let rotatedBits = (shiftL (B.last shiftedWords) (8 - (i `mod` 8))) .|. (B.head tmpShiftedBits) - rotatedBits `B.cons` (B.tail tmpShiftedBits) - where - nWholeWordsToShift n = (B.length bs - (n `div` 8)) - rotateR _ _ = error "I can't believe you've done this." - {-# INLINE rotateR #-} - - rotateL bs 0 = bs - rotateL bs i - | B.length bs == 0 = B.empty - | B.length bs == 1 = B.singleton (rotateL (bs `B.index` 0) i) - | i `mod` 8 == 0 = B.append - (B.drop (i `div` 8) bs) - (B.take (i `div` 8) bs) - | B.length bs > 1 = do - let shiftedWords = - B.append - (B.drop (i `div` 8) bs) - (B.take (i `div` 8) bs) - let tmpShiftedBits = (shiftL shiftedWords (i `mod` 8)) - let rotatedBits = (shiftR (B.head shiftedWords) (8 - (i `mod` 8))) .|. (B.last tmpShiftedBits) - (B.init tmpShiftedBits) `B.snoc` rotatedBits - rotateL _ _ = error "I can't believe you've done this." - {-# INLINE rotateL #-} - - bitSize x = 8 * B.length x - {-# INLINE bitSize #-} - - bitSizeMaybe x = Just (8 * B.length x) - {-# INLINE bitSizeMaybe #-} - - isSigned _ = False - {-# INLINE isSigned #-} - - testBit x i = testBit (B.index x (B.length x - (i `div` 8) - 1)) (i `mod` 8) - {-# INLINE testBit #-} - - bit i = (bit $ mod i 8) `B.cons` (B.replicate (div i 8) (255 :: Word8)) - {-# INLINE bit #-} - - popCount x = sum $ map popCount $ B.unpack x - {-# 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 @@ -module Data.Digest.CRC32C - ( crc32c - , crc32c_update - ) where - -import Data.Bits -import Data.ByteString (ByteString) -import Data.Word -import Data.Array.Base (unsafeAt) -import Data.Array.Unboxed - -import qualified Data.ByteString as B - - -crc32c :: ByteString -> Word32 -crc32c = crc32c_update 0 - -crc32c_update :: Word32 -> ByteString -> Word32 -crc32c_update crc bs = flipd $ step (flipd crc) bs - where - flipd = xor 0xffffffff - -step :: Word32 -> ByteString -> Word32 -step crc bs = B.foldl step' crc bs - where - step' acc b = let x = table !!! ((acc .&. 0xff) `xor` fromIntegral b) - in x `xor` (acc `shiftR` 8) -{-# INLINEABLE step #-} - -(!!!) :: (IArray a e, Ix i, Integral i) => a i e -> i -> e -arr !!! i = unsafeAt arr $ fromIntegral i -{-# INLINEABLE (!!!) #-} - -table :: UArray Word32 Word32 -table = listArray (0,255) $ - [ 0x00000000, 0xf26b8303, 0xe13b70f7, 0x1350f3f4 - , 0xc79a971f, 0x35f1141c, 0x26a1e7e8, 0xd4ca64eb - , 0x8ad958cf, 0x78b2dbcc, 0x6be22838, 0x9989ab3b - , 0x4d43cfd0, 0xbf284cd3, 0xac78bf27, 0x5e133c24 - , 0x105ec76f, 0xe235446c, 0xf165b798, 0x030e349b - , 0xd7c45070, 0x25afd373, 0x36ff2087, 0xc494a384 - , 0x9a879fa0, 0x68ec1ca3, 0x7bbcef57, 0x89d76c54 - , 0x5d1d08bf, 0xaf768bbc, 0xbc267848, 0x4e4dfb4b - , 0x20bd8ede, 0xd2d60ddd, 0xc186fe29, 0x33ed7d2a - , 0xe72719c1, 0x154c9ac2, 0x061c6936, 0xf477ea35 - , 0xaa64d611, 0x580f5512, 0x4b5fa6e6, 0xb93425e5 - , 0x6dfe410e, 0x9f95c20d, 0x8cc531f9, 0x7eaeb2fa - , 0x30e349b1, 0xc288cab2, 0xd1d83946, 0x23b3ba45 - , 0xf779deae, 0x05125dad, 0x1642ae59, 0xe4292d5a - , 0xba3a117e, 0x4851927d, 0x5b016189, 0xa96ae28a - , 0x7da08661, 0x8fcb0562, 0x9c9bf696, 0x6ef07595 - , 0x417b1dbc, 0xb3109ebf, 0xa0406d4b, 0x522bee48 - , 0x86e18aa3, 0x748a09a0, 0x67dafa54, 0x95b17957 - , 0xcba24573, 0x39c9c670, 0x2a993584, 0xd8f2b687 - , 0x0c38d26c, 0xfe53516f, 0xed03a29b, 0x1f682198 - , 0x5125dad3, 0xa34e59d0, 0xb01eaa24, 0x42752927 - , 0x96bf4dcc, 0x64d4cecf, 0x77843d3b, 0x85efbe38 - , 0xdbfc821c, 0x2997011f, 0x3ac7f2eb, 0xc8ac71e8 - , 0x1c661503, 0xee0d9600, 0xfd5d65f4, 0x0f36e6f7 - , 0x61c69362, 0x93ad1061, 0x80fde395, 0x72966096 - , 0xa65c047d, 0x5437877e, 0x4767748a, 0xb50cf789 - , 0xeb1fcbad, 0x197448ae, 0x0a24bb5a, 0xf84f3859 - , 0x2c855cb2, 0xdeeedfb1, 0xcdbe2c45, 0x3fd5af46 - , 0x7198540d, 0x83f3d70e, 0x90a324fa, 0x62c8a7f9 - , 0xb602c312, 0x44694011, 0x5739b3e5, 0xa55230e6 - , 0xfb410cc2, 0x092a8fc1, 0x1a7a7c35, 0xe811ff36 - , 0x3cdb9bdd, 0xceb018de, 0xdde0eb2a, 0x2f8b6829 - , 0x82f63b78, 0x709db87b, 0x63cd4b8f, 0x91a6c88c - , 0x456cac67, 0xb7072f64, 0xa457dc90, 0x563c5f93 - , 0x082f63b7, 0xfa44e0b4, 0xe9141340, 0x1b7f9043 - , 0xcfb5f4a8, 0x3dde77ab, 0x2e8e845f, 0xdce5075c - , 0x92a8fc17, 0x60c37f14, 0x73938ce0, 0x81f80fe3 - , 0x55326b08, 0xa759e80b, 0xb4091bff, 0x466298fc - , 0x1871a4d8, 0xea1a27db, 0xf94ad42f, 0x0b21572c - , 0xdfeb33c7, 0x2d80b0c4, 0x3ed04330, 0xccbbc033 - , 0xa24bb5a6, 0x502036a5, 0x4370c551, 0xb11b4652 - , 0x65d122b9, 0x97baa1ba, 0x84ea524e, 0x7681d14d - , 0x2892ed69, 0xdaf96e6a, 0xc9a99d9e, 0x3bc21e9d - , 0xef087a76, 0x1d63f975, 0x0e330a81, 0xfc588982 - , 0xb21572c9, 0x407ef1ca, 0x532e023e, 0xa145813d - , 0x758fe5d6, 0x87e466d5, 0x94b49521, 0x66df1622 - , 0x38cc2a06, 0xcaa7a905, 0xd9f75af1, 0x2b9cd9f2 - , 0xff56bd19, 0x0d3d3e1a, 0x1e6dcdee, 0xec064eed - , 0xc38d26c4, 0x31e6a5c7, 0x22b65633, 0xd0ddd530 - , 0x0417b1db, 0xf67c32d8, 0xe52cc12c, 0x1747422f - , 0x49547e0b, 0xbb3ffd08, 0xa86f0efc, 0x5a048dff - , 0x8ecee914, 0x7ca56a17, 0x6ff599e3, 0x9d9e1ae0 - , 0xd3d3e1ab, 0x21b862a8, 0x32e8915c, 0xc083125f - , 0x144976b4, 0xe622f5b7, 0xf5720643, 0x07198540 - , 0x590ab964, 0xab613a67, 0xb831c993, 0x4a5a4a90 - , 0x9e902e7b, 0x6cfbad78, 0x7fab5e8c, 0x8dc0dd8f - , 0xe330a81a, 0x115b2b19, 0x020bd8ed, 0xf0605bee - , 0x24aa3f05, 0xd6c1bc06, 0xc5914ff2, 0x37faccf1 - , 0x69e9f0d5, 0x9b8273d6, 0x88d28022, 0x7ab90321 - , 0xae7367ca, 0x5c18e4c9, 0x4f48173d, 0xbd23943e - , 0xf36e6f75, 0x0105ec76, 0x12551f82, 0xe03e9c81 - , 0x34f4f86a, 0xc69f7b69, 0xd5cf889d, 0x27a40b9e - , 0x79b737ba, 0x8bdcb4b9, 0x988c474d, 0x6ae7c44e - , 0xbe2da0a5, 0x4c4623a6, 0x5f16d052, 0xad7d5351 - ] 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 @@ -module Data.IntervalSet - ( IntSet - , null - , empty - , insert - , delete - , interval - , toIntervals - , nearestOutsider - , Data.IntervalSet.lookup - ) where - -import Prelude hiding (null) -import qualified Data.IntMap.Strict as IntMap - ;import Data.IntMap.Strict (IntMap) -import qualified Data.List as List -import Data.Ord - - --- A set of integers. -newtype IntSet = IntSet (IntMap Interval) - deriving Show - --- Note: the intervalMin is not stored here but is the lookup key in an IntMap. -data Interval = Interval - { intervalMax :: {-# UNPACK #-} !Int -- ^ Maximum value contained in this interval. - , intervalNext :: {-# UNPACK #-} !Int -- ^ Minimum value in next interval if there is one. - } - deriving Show - -null :: IntSet -> Bool -null (IntSet m) = IntMap.null m - -empty :: IntSet -empty = IntSet IntMap.empty - - -insert :: Int -> IntSet -> IntSet -insert x (IntSet m) = IntSet $ case IntMap.lookupLE x m of - Just (lb,Interval mx ub) - | x <= mx -> m - | otherwise -> case ub == maxBound of - - True | x == mx + 1 -> IntMap.insert lb (Interval x maxBound) m - | otherwise -> IntMap.insert lb (Interval mx x) - $ IntMap.insert x (Interval x maxBound) m - - False | mx + 2 == ub -> let (Just v', m') - = IntMap.updateLookupWithKey (\_ _ -> Nothing) ub m - in IntMap.insert lb v' m' - | mx + 1 == x -> IntMap.insert lb (Interval x ub) m - | otherwise -> IntMap.insert lb (Interval mx x) - $ if ub == x + 1 - then let (Just v', m') - = IntMap.updateLookupWithKey - (\_ _ -> Nothing) ub m - in IntMap.insert x v' m' - else IntMap.insert x (Interval x ub) m - - Nothing -> case IntMap.minViewWithKey m of - - Just ((ub,v),m') - | x + 1 == ub -> IntMap.insert x v m' - | otherwise -> IntMap.insert x (Interval x ub) m - - Nothing -> IntMap.singleton x (Interval x maxBound) - -member :: Int -> IntSet -> Bool -member x (IntSet m) = case IntMap.lookupLE x m of - Just (lb,Interval mx _) -> x <= mx - Nothing -> False - -nearestOutsider :: Int -> IntSet -> Maybe Int -nearestOutsider x (IntSet m) - | List.null xs = Nothing -- There are no integers outside the set! - | otherwise = Just $ List.minimumBy (comparing (\y -> abs (x - y))) xs - where - xs = case IntMap.lookupLE x m of - Nothing -> [x] - Just (lb,Interval mx ub) - -> if ub < maxBound - then case () of - () | x > mx -> [x] - | minBound < lb -> [lb-1, mx+1, ub-1] - | otherwise -> [mx+1, ub-1] - else case () of - () | x > mx -> [x] - | minBound < lb && mx < maxBound -> [lb-1, mx+1] - | minBound < lb -> [lb-1] - | mx < maxBound -> [mx+1] - | otherwise -> [] - --- Note this could possibly benefit from a intervalPrev field. -delete :: Int -> IntSet -> IntSet -delete x (IntSet m) = IntSet $ case IntMap.lookupLE x m of - Nothing -> m - Just (lb,Interval mx nxt) -> case compare x mx of - - GT -> m - - EQ | lb < mx -> IntMap.insert lb (Interval (mx - 1) nxt) m - | otherwise -> case IntMap.lookupLE (x-1) m of -- no intervalPrev - Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' nxt) - $ IntMap.delete lb m - Nothing -> IntMap.delete lb m - - LT -> let m' = IntMap.insert (x+1) (Interval mx nxt) m - in if lb < x - then IntMap.insert lb (Interval (x - 1) (x+1)) m' - else if x == minBound - then IntMap.delete minBound m' - else case IntMap.lookupLE (x-1) m' of -- no intervalPrev - Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' (x+1)) - $ IntMap.delete lb m' - Nothing -> IntMap.delete lb m' - -toIntervals :: IntSet -> [(Int,Int)] -toIntervals (IntSet m) = List.map (\(lb,(Interval mx _)) -> (lb,mx)) - $ IntMap.toList m - -interval :: Int -> Int -> IntSet -interval lb mx - | lb <= mx = IntSet $ IntMap.singleton lb (Interval mx maxBound) - | otherwise = IntSet IntMap.empty - -lookup :: Int -> IntSet -> Maybe (Int,Int) -lookup k (IntSet m) = case IntMap.lookupLE k m of - Nothing -> Nothing - 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 @@ -{-# LANGUAGE BangPatterns, PatternSynonyms #-} -module Data.MinMaxPSQ - ( module Data.MinMaxPSQ - , Binding' - , pattern Binding - ) where - -import Data.Ord -import qualified Data.Wrapper.PSQ as PSQ - ;import Data.Wrapper.PSQ as PSQ hiding (insert, insert', null, size) -import Prelude hiding (null, take) - -data MinMaxPSQ' k p v = MinMaxPSQ !Int !(PSQ' k p v) !(PSQ' k (Down p) v) -type MinMaxPSQ k p = MinMaxPSQ' k p () - -empty :: MinMaxPSQ' k p v -empty = MinMaxPSQ 0 PSQ.empty PSQ.empty - -singleton' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v -singleton' k v p = MinMaxPSQ 1 (PSQ.singleton' k v p) (PSQ.singleton' k v (Down p)) - -null :: MinMaxPSQ' k p v -> Bool -null (MinMaxPSQ sz _ _) = sz==0 -{-# INLINE null #-} - -size :: MinMaxPSQ' k p v -> Int -size (MinMaxPSQ sz _ _) = sz -{-# INLINE size #-} - -toList :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> [Binding' k p v] -toList (MinMaxPSQ _ nq xq) = PSQ.toList nq - -fromList :: (PSQKey k, Ord p) => [Binding' k p v] -> MinMaxPSQ' k p v -fromList kps = let nq = PSQ.fromList kps - xq = PSQ.fromList $ map (\(Binding k v p) -> Binding k v (Down p)) kps - in MinMaxPSQ (PSQ.size nq) nq xq - -findMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v) -findMin (MinMaxPSQ _ nq xq) = PSQ.findMin nq - -findMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v) -findMax (MinMaxPSQ _ nq xq) = fmap (\(Binding k v (Down p)) -> Binding k v p) $ PSQ.findMin xq - -insert :: (PSQKey k, Ord p) => k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p -insert k p (MinMaxPSQ sz nq xq) = case PSQ.insertView k p () nq of - (Just _ ,nq') -> MinMaxPSQ sz nq' (PSQ.insert k (Down p) xq) - (Nothing,nq') -> MinMaxPSQ (sz+1) nq' (PSQ.insert k (Down p) xq) - -insert' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v -insert' k v p (MinMaxPSQ sz nq xq) = case PSQ.insertView k p v nq of - (Just _ ,nq') -> MinMaxPSQ sz nq' (PSQ.insert' k v (Down p) xq) - (Nothing,nq') -> MinMaxPSQ (sz+1) nq' (PSQ.insert' k v (Down p) xq) - -delete :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v -delete k q@(MinMaxPSQ sz nq xq) = case PSQ.deleteView k nq of - Just (_,_,nq') -> MinMaxPSQ (sz - 1) nq' (PSQ.delete k xq) - Nothing -> q - -deleteMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v -deleteMin q@(MinMaxPSQ sz nq xq) = case PSQ.minView nq of - Just (Binding k _ _, nq') -> MinMaxPSQ (sz - 1) nq' (PSQ.delete k xq) - Nothing -> q - -deleteMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v -deleteMax q@(MinMaxPSQ sz nq xq) = case PSQ.minView xq of - Just (Binding k _ _, xq') -> MinMaxPSQ (sz - 1) (PSQ.delete k nq) xq' - Nothing -> q - -minView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v) -minView (MinMaxPSQ sz nq xq) = fmap (\(Binding k v p, nq') -> (Binding k v p, MinMaxPSQ (sz-1) nq' (PSQ.delete k xq))) - $ PSQ.minView nq - -maxView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v) -maxView (MinMaxPSQ sz nq xq) = fmap (\(Binding k v (Down p), xq') -> (Binding k v p, MinMaxPSQ (sz-1) (PSQ.delete k nq) xq')) - $ PSQ.minView xq - --- | Maintains a bounded 'MinMaxPSQ' by deleting the maximum element if the --- insertion would cause the queue to have too many elements. -insertTake :: (PSQKey k, Ord p) => Int -> k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p -insertTake n k p q - | size q < n = insert k p q - | size q == n = insert k p $ deleteMax q - | otherwise = take n $ insert k p q - --- | Maintains a bounded 'MinMaxPSQ\'' by deleting the maximum element if the --- insertion would cause the queue to have too many elements. -insertTake' :: (PSQKey k, Ord p) => Int -> k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v -insertTake' n k v p q - | size q < n = insert' k v p q - | size q == n = insert' k v p $ deleteMax q - | otherwise = take n $ insert' k v p q - - --- | Truncate the 'MinMaxPSQ' to the given number of lowest priority elements. -take :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v -take !n !q | (size q <= n) = q - | null q = q - | otherwise = take n $ deleteMax q - --- | Like 'take', except it provides a list deleted bindings. -takeView :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> ( [Binding' k p v], MinMaxPSQ' k p v ) -takeView !n !q | (size q <= n) = ([], q) - | null q = ([], q) - | otherwise = let Just (x,q') = maxView q - (xs,q'') = takeView n q' - ys = x:xs - in (ys, ys `seq` q'') - - - -lookup' :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> Maybe (p, v) -lookup' 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 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveFunctor #-} -module Data.PacketBuffer - ( PacketBuffer - , newPacketBuffer - , PacketOutboundEvent(..) - , PacketInboundEvent(..) - , grokOutboundPacket - , grokInboundPacket - , awaitReadyPacket - , packetNumbersToRequest - , expectingSequenceNumber - , nextToSendSequenceNumber - , retrieveForResend - , decompressSequenceNumbers - , compressSequenceNumbers - , pbReport - ) where - -import Data.PacketQueue as Q -import DPut -import DebugTag - -import Control.Concurrent.STM -import Control.Monad -import Data.Maybe -import Data.Word - -data PacketBuffer a b = PacketBuffer - { inQueue :: PacketQueue a - , outBuffer :: PacketQueue b } - --- | Initialize the packet buffers. Note, the capacity of the inbound packet --- queue is currently hardcoded to 200 packets and the capacity of the outbound --- buffer is hardcoded to 400 packets. -newPacketBuffer :: STM (PacketBuffer a b) -newPacketBuffer = PacketBuffer <$> Q.new 200 0 - <*> Q.new 400 0 - --- | Input for 'grokPacket'. -data PacketOutboundEvent b - = PacketSent { poSeqNum :: Word32 -- ^ Sequence number for payload. - , poSentPayload :: b -- ^ Payload packet we sent to them. - } - deriving Functor - -data PacketInboundEvent a - = PacketReceived { peSeqNum :: Word32 -- ^ Sequence number for payload. - , peReceivedPayload :: a -- ^ Payload packet they sent to us. - , peAcknowledgedNum :: Word32 -- ^ Earliest sequence number they've seen from us. - } - | PacketReceivedLossy { peSeqNum :: Word32 -- ^ Sequence number for lossy packet. - , peReceivedPayload :: a -- ^ Payload packet they sent to us (ignored). - , peAcknowledgedNum :: Word32 -- ^ Earliest sequence number they've seen from us. - } - deriving Functor - --- | Whenever a packet is received or sent (but not resent) from the network, --- this function should be called to update the relevant buffers. --- --- On outgoing packets, if the outbound buffer is full, this will return --- True. In this case, the caller may retry to enable blocking until --- 'grokInboundPacket' is called in another thread. -grokOutboundPacket :: PacketBuffer a b -> PacketOutboundEvent b -> STM (Bool,(Word32,Word32)) -grokOutboundPacket (PacketBuffer _ outb) (PacketSent seqno a) - = do (n,r) <- Q.enqueue outb seqno a - return (n/=0,(n,r)) - -grokInboundPacket :: PacketBuffer a b -> PacketInboundEvent a -> STM () -grokInboundPacket (PacketBuffer inb outb) (PacketReceived seqno a ack) - = do Q.enqueue inb seqno a - Q.dropPacketsBefore outb ack -grokInboundPacket (PacketBuffer inb outb) (PacketReceivedLossy seqno _ ack) - = do Q.observeOutOfBand inb seqno - Q.dropPacketsBefore outb ack - --- | Wait until an inbound packet is ready to process. Any necessary --- re-ordering will have been done. -awaitReadyPacket :: PacketBuffer a b -> STM a -awaitReadyPacket (PacketBuffer inb _) = Q.dequeue inb - --- | Obtain a list of sequence numbers that may have been dropped. This would --- be any number not yet received that is prior to the maxium sequence number --- we have received. For convenience, a lowerbound for the missing squence numbers --- is also returned as the second item of the pair. -packetNumbersToRequest :: PacketBuffer a b -> STM ([Word32],Word32) -packetNumbersToRequest (PacketBuffer inb _) = do - ns <- Q.getMissing inb - lb <- Q.getLastDequeuedPlus1 inb - return (ns,lb) - -expectingSequenceNumber :: PacketBuffer a b -> STM Word32 -expectingSequenceNumber (PacketBuffer inb _ ) = Q.getLastDequeuedPlus1 inb - -nextToSendSequenceNumber :: PacketBuffer a b -> STM Word32 -nextToSendSequenceNumber (PacketBuffer _ outb) = Q.getLastEnqueuedPlus1 outb - --- | Retrieve already-sent packets by their sequence numbers. See --- 'decompressSequenceNumbers' to obtain the sequence number list from a --- compressed encoding. There is no need to call 'grokPacket' when sending the --- packets returned from this call. -retrieveForResend :: PacketBuffer a b -> [Word32] -> STM [(Word32,b)] -retrieveForResend (PacketBuffer _ outb) seqnos = - catMaybes <$> forM seqnos (\no -> fmap (no,) <$> Q.lookup outb no) - --- | Expand a compressed set of sequence numbers. The first sequence number is --- given directly and the rest are computed using 8-bit offsets. This is --- normally used to obtain input for 'retrieveForResend'. -decompressSequenceNumbers :: Word32 -> [Word8] -> [Word32] -decompressSequenceNumbers baseno ns = foldr doOne (const []) ns (baseno-1) - where - doOne :: Word8 -> (Word32 -> [Word32]) -> Word32 -> [Word32] - doOne 0 f addend = f (addend + 255) - doOne x f addend = let y = fromIntegral x + addend - in y : f y - -compressSequenceNumbers :: Word32 -> [Word32] -> [Word8] -compressSequenceNumbers baseno xs = foldr doOne (const []) xs (baseno-1) - where - doOne :: Word32 -> (Word32 -> [Word8]) -> Word32 -> [Word8] - doOne y f addend = case y - addend of - x | x < 255 -> fromIntegral x : f y - | otherwise -> 0 : doOne y f (addend + 255) - -{- -compressSequenceNumbers :: Word32 -> [Word32] -> [Word8] -compressSequenceNumbers seqno xs = let r = map fromIntegral (reduceToSums ys >>= makeZeroes) - in dtrace XNetCrypto ("compressSequenceNumbers " ++ show seqno ++ show xs ++ " --> "++show r) r - where - ys = Prelude.map (subtract (seqno - 1)) xs - reduceToSums [] = [] - reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs) - makeZeroes :: Word32 -> [Word32] - -- makeZeroes 0 = [] - makeZeroes x - = let (d,m)= x `divMod` 255 - zeros= Prelude.replicate (fromIntegral d) 0 - in zeros ++ [m] --} - -pbReport :: String -> PacketBuffer a b -> STM String -pbReport what (PacketBuffer inb outb) = do - inb_seqno <- getLastDequeuedPlus1 inb - inb_buffend <- getLastEnqueuedPlus1 inb - outb_seqno <- getLastDequeuedPlus1 outb - outb_bufend <- getLastEnqueuedPlus1 outb - return $ "PacketBuffer<"++what++"> Inbound" ++ show (inb_seqno, inb_buffend) - ++" 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 @@ --- | This module is useful for implementing a lossess protocol on top of a --- lossy datagram style protocol. It implements a buffer in which packets may --- be stored out of order, but from which they are extracted in the proper --- sequence. -{-# LANGUAGE NamedFieldPuns #-} -module Data.PacketQueue - ( PacketQueue - , getCapacity - , getLastDequeuedPlus1 - , getLastEnqueuedPlus1 - , new - , dequeue - , dropPacketsLogic - , dropPacketsBefore - , getMissing - -- , dequeueOrGetMissing - -- , markButNotDequeue - , enqueue - , observeOutOfBand - , packetQueueViewList - -- , mapQ - , Data.PacketQueue.lookup - ) where - -import Control.Concurrent.STM -import Control.Monad -import Data.Word -import Data.Array.MArray -import Data.Maybe - -data PacketQueue a = PacketQueue - { pktq :: TArray Word32 (Maybe a) - , seqno :: TVar Word32 -- (buffer_start) - , qsize :: Word32 - , buffend :: TVar Word32 -- on incoming, next packet they'll send + 1 - -- i.e. one more than the largest seen sequence number. - -- Written by: - -- observeOutOfBand - -- dropPacketsBefore - -- enqueue - } - --- | Obtain a list of non-empty slots in the 'PacketQueue'. The numeric value --- is an index into the underlying array, not a sequence number. -packetQueueViewList :: PacketQueue a -> STM [(Word32,a)] -packetQueueViewList p = do - let f (n,Nothing) = Nothing - f (n,Just x) = Just (n,x) - catMaybes . map f <$> getAssocs (pktq p) - --- | This returns the earliest sequence number with a slot in the queue. -getLastDequeuedPlus1 :: PacketQueue a -> STM Word32 -getLastDequeuedPlus1 PacketQueue {seqno} = readTVar seqno - --- | This returns the least upper bound of sequence numbers that have been --- enqueued. -getLastEnqueuedPlus1 :: PacketQueue a -> STM Word32 -getLastEnqueuedPlus1 PacketQueue {buffend} = readTVar buffend - - --- | This is the number of consequetive sequence numbers, starting at --- 'getLastDequeuedPlus1' that can be stored in the queue -getCapacity :: Applicative m => PacketQueue t -> m Word32 -getCapacity (PacketQueue { qsize }) = pure qsize - --- | Create a new PacketQueue. -new :: Word32 -- ^ Capacity of queue. - -> Word32 -- ^ Initial sequence number. - -> STM (PacketQueue a) -new capacity seqstart = do - let cap = if capacity `mod` 2 == 0 then capacity else capacity + 1 - q <- newArray (0,cap - 1) Nothing - seqv <- newTVar seqstart - bufe <- newTVar seqstart - return PacketQueue - { pktq = q - , seqno = seqv - , qsize = cap - , buffend = bufe - } - --- | Update the packet queue given: --- --- * packet queue --- --- * the number of next lossless packet they intend to send you --- --- This behaves exactly like 'enqueue' except that no packet data is written to --- the queue. -observeOutOfBand :: PacketQueue a -> Word32-> STM () -observeOutOfBand PacketQueue { seqno, qsize, buffend } numberOfNextLosslessPacketThatTheyWillSend = do - low <- readTVar seqno - let proj = numberOfNextLosslessPacketThatTheyWillSend - low - -- Ignore packet if out of range. - when ( proj < qsize) $ do - modifyTVar' buffend (\be -> if be - low <= proj then numberOfNextLosslessPacketThatTheyWillSend + 1 else be) - --- | If seqno < buffend then return expected packet numbers for all --- the Nothings in the array between them. --- Otherwise, return empty list. -getMissing :: PacketQueue a -> STM [Word32] -getMissing PacketQueue { pktq, seqno, qsize, buffend } = do - seqno0 <- readTVar seqno - buffend0 <- readTVar buffend - -- note relying on fact that [ b .. a ] is null when a < b - let indices = take (fromIntegral qsize) $ [ seqno0 .. buffend0 - 1] - maybes <- forM indices $ \i -> do - x <- readArray pktq $ i `mod` qsize - return (i,x) - let nums = map fst . filter (isNothing . snd) $ maybes - return nums - --- -- | If seqno < buffend then return expected packet numbers for all --- -- the Nothings in the array between them. --- -- Otherwise, behave as 'dequeue' would. --- -- TODO: Do we need this function? Delete it if not. --- dequeueOrGetMissing :: PacketQueue a -> STM (Either [Word32] a) --- dequeueOrGetMissing PacketQueue { pktq, seqno, qsize, buffend } = do --- seqno0 <- readTVar seqno --- buffend0 <- readTVar buffend --- if seqno0 < buffend0 --- then do --- maybes <- mapM (readArray pktq) (take (fromIntegral qsize) $ map (`mod` qsize) [ seqno0 .. buffend0 ]) --- let nums = map fst . filter (isNothing . snd) $ zip [buffend0 ..] maybes --- return (Left nums) --- else do --- let i = seqno0 `mod` qsize --- x <- maybe retry return =<< readArray pktq i --- writeArray pktq i Nothing --- modifyTVar' seqno succ --- return (Right x) - --- | Retry until the next expected packet is enqueued. Then return it. -dequeue :: PacketQueue a -> STM a -dequeue PacketQueue { pktq, seqno, qsize } = do - i0 <- readTVar seqno - let i = i0 `mod` qsize - x <- maybe retry return =<< readArray pktq i - writeArray pktq i Nothing - modifyTVar' seqno succ - return x - --- | Helper to 'dropPacketsBefore'. -dropPacketsLogic :: Word32 -> Word32 -> Word32 -> (Maybe Word32, Word32, [(Word32,Word32)]) -dropPacketsLogic qsize low no0 = - let no = no0 - 1 -- Unsigned: could overflow - proj = no - low -- Unsigned: could overflow - in if proj < qsize - then - let ilow = low `mod` qsize - i = no `mod` qsize - ranges = if ilow <= i then [(ilow, i)] - else [(0,i),(ilow,qsize-1)] - in (Nothing,no0,ranges) -- Clear some, but not all, slots. - else (Nothing,low,[]) -- out of bounds, do nothing -- (Just no0, no0, [(0,qsize - 1)]) -- Reset to empty queue. - - --- | Drop all packets preceding the given packet number. -dropPacketsBefore :: PacketQueue a -> Word32 -> STM () -dropPacketsBefore PacketQueue{ pktq, seqno, qsize, buffend } no0 = do - low <- readTVar seqno - let (mbuffend, no, ranges) = dropPacketsLogic qsize low no0 - mapM_ (writeTVar buffend) mbuffend - writeTVar seqno no - forM_ ranges $ \(lo,hi) -> forM_ [lo .. hi] $ \i -> writeArray pktq i Nothing - - --- -- | Like dequeue, but marks as viewed rather than removing --- markButNotDequeue :: PacketQueue (Bool,a) -> STM a --- markButNotDequeue PacketQueue { pktq, seqno, qsize } = do --- i0 <- readTVar seqno --- let i = i0 `mod` qsize --- (b,x) <- maybe retry return =<< readArray pktq i --- writeArray pktq i (Just (True,x)) --- modifyTVar' seqno succ --- return x - --- | Enqueue a packet. Packets need not be enqueued in order as long as there --- is spare capacity in the queue. If there is not, the packet will be --- silently discarded without blocking. (Unless this is an Overwrite-queue, in --- which case, the packets will simply wrap around overwriting the old ones.) --- --- If the packet was enqueued, (0,i) will be retuned where /i/ is the index at --- which the new packet was stored in the buffer. If the queue was full, the --- first of the returned pair will be non-zero. -enqueue :: PacketQueue a -- ^ The packet queue. - -> Word32 -- ^ Sequence number of the packet. - -> a -- ^ The packet. - -> STM (Word32,Word32) -enqueue PacketQueue{ pktq, seqno, qsize, buffend} no x = do - low <- readTVar seqno - let proj = no - low - -- Ignore packet if out of range. - when ( proj < qsize) $ do - let i = no `mod` qsize - writeArray pktq i (Just x) - modifyTVar' buffend (\be -> if be - low <= proj then no + 1 else be) - return (proj `divMod` qsize) - --- | Obtain the packet with the given sequence number if it is stored in the --- queue, otherwise /Nothing/ is returned without blocking. -lookup :: PacketQueue a -> Word32 -> STM (Maybe a) -lookup PacketQueue{ pktq, seqno, qsize } no = do - low <- readTVar seqno - let proj = no - low - if proj < qsize - then let i = no `mod` qsize - in readArray pktq i - else return Nothing - --- -- | For each item in the queue, modify or delete it. --- mapQ :: (a -> Maybe a) -> PacketQueue a -> STM () --- mapQ f PacketQueue{pktq} = do --- (z,n) <- getBounds pktq --- forM_ [z .. n] $ \i -> do --- e <- readArray pktq i --- 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 @@ -module Data.Sized where - -import Data.Typeable - - --- | Info about a type's serialized length. Either the length is known --- independently of the value, or the length depends on the value. -data Size a - = VarSize (a -> Int) - | ConstSize !Int - deriving Typeable - -class Sized a where size :: Size a - 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 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -module Data.TableMethods where - -import Data.Functor.Contravariant -import Data.Time.Clock.POSIX -import Data.Word -import qualified Data.IntMap.Strict as IntMap - ;import Data.IntMap.Strict (IntMap) -import qualified Data.Map.Strict as Map - ;import Data.Map.Strict (Map) -import qualified Data.Word64Map as W64Map - ;import Data.Word64Map (Word64Map) - -import Data.Wrapper.PSQ as PSQ - -type Priority = POSIXTime - -data OptionalPriority t tid x - = NoPriority - | HasPriority (Priority -> t x -> ([(tid, Priority, x)], t x)) - --- | The standard lookup table methods. -data TableMethods t tid = TableMethods - { -- | Insert a new /tid/ entry into the transaction table. - tblInsert :: forall a. tid -> a -> Priority -> t a -> t a - -- | Delete transaction /tid/ from the transaction table. - , tblDelete :: forall a. tid -> t a -> t a - -- | Lookup the value associated with transaction /tid/. - , tblLookup :: forall a. tid -> t a -> Maybe a - } - -data QMethods t tid x = QMethods - { qTbl :: TableMethods t tid - , qAtMostView :: OptionalPriority t tid x - } - -vanillaTable :: TableMethods t tid -> QMethods t tid x -vanillaTable tbl = QMethods tbl NoPriority - -priorityTable :: TableMethods t tid - -> (Priority -> t x -> ([(k, Priority, x)], t x)) - -> (k -> x -> tid) - -> QMethods t tid x -priorityTable tbl atmost f = QMethods - { qTbl = tbl - , qAtMostView = HasPriority $ \p t -> case atmost p t of - (es,t') -> (map (\(k,p,a) -> (f k a, p, a)) es, t') - } - --- | Methods for using 'Data.IntMap'. -intMapMethods :: TableMethods IntMap Int -intMapMethods = TableMethods - { tblInsert = \tid a p -> IntMap.insert tid a - , tblDelete = IntMap.delete - , tblLookup = IntMap.lookup - } - --- | Methods for using 'Data.Word64Map'. -w64MapMethods :: TableMethods Word64Map Word64 -w64MapMethods = TableMethods - { tblInsert = \tid a p -> W64Map.insert tid a - , tblDelete = W64Map.delete - , tblLookup = W64Map.lookup - } - --- | Methods for using 'Data.Map' -mapMethods :: Ord tid => TableMethods (Map tid) tid -mapMethods = TableMethods - { tblInsert = \tid a p -> Map.insert tid a - , tblDelete = Map.delete - , tblLookup = Map.lookup - } - --- psqMethods :: PSQKey tid => QMethods (HashPSQ tid Priority) tid x -psqMethods :: PSQKey k => (tid -> k) -> (k -> x -> tid) -> QMethods (PSQ' k Priority) tid x -psqMethods g f = priorityTable (contramap g tbl) PSQ.atMostView f - where - tbl :: PSQKey tid => TableMethods (PSQ' tid Priority) tid - tbl = TableMethods - { tblInsert = PSQ.insert' - , tblDelete = PSQ.delete - , tblLookup = \tid t -> case PSQ.lookup tid t of - Just (p,a) -> Just a - Nothing -> Nothing - } - - --- | Change the key type for a lookup table implementation. --- --- This can be used with 'intMapMethods' or 'mapMethods' to restrict lookups to --- only a part of the generated /tid/ value. This is useful for /tid/ types --- that are especially large due their use for other purposes, such as secure --- nonces for encryption. -instance Contravariant (TableMethods t) where - -- contramap :: (tid -> t1) -> TableMethods t t1 -> TableMethods t tid - contramap f (TableMethods ins del lookup) = - TableMethods (\k p v t -> ins (f k) p v t) - (\k t -> del (f k) t) - (\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 @@ --- | --- Copyright : (c) Sam Truzjan 2013 --- License : BSD3 --- Maintainer : pxqr.sta@gmail.com --- Stability : experimental --- Portability : portable --- --- Torrent file contains metadata about files and folders but not --- content itself. The files are bencoded dictionaries. There is --- also other info which is used to help join the swarm. --- --- This module provides torrent metainfo serialization and info hash --- extraction. --- --- For more info see: --- , --- --- -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS -fno-warn-orphans #-} -module Data.Torrent - ( -- * InfoHash - -- $infohash - InfoHash(..) - , textToInfoHash - , longHex - , shortHex - - -- * File layout - -- ** FileInfo - , FileOffset - , FileSize - , FileInfo (..) -#ifdef USE_lens - , fileLength - , filePath - , fileMD5Sum -#endif - - -- ** Layout info - , LayoutInfo (..) -#ifdef USE_lens - , singleFile - , multiFile - , rootDirName -#endif - , joinFilePath - , isSingleFile - , isMultiFile - , suggestedName - , contentLength - , fileCount - , blockCount - - -- ** Flat layout info - , FileLayout - , flatLayout - , accumPositions - , fileOffset - - -- ** Internal - , sizeInBase - - -- * Pieces - -- ** Attributes - , PieceIx - , PieceCount - , PieceSize - , minPieceSize - , maxPieceSize - , defaultPieceSize - , PieceHash - - -- ** Piece data - , Piece (..) - , pieceSize - , hashPiece - - -- ** Piece control - , HashList (..) - , PieceInfo (..) -#ifdef USE_lens - , pieceLength - , pieceHashes -#endif - , pieceCount - - -- ** Validation - , pieceHash - , checkPieceLazy - - -- * Info dictionary - , InfoDict (..) -#ifdef USE_lens - , infohash - , layoutInfo - , pieceInfo - , isPrivate -#endif -#ifdef VERSION_bencoding - , infoDictionary -#endif - - -- * Torrent file - , Torrent(..) - -#ifdef USE_lens - -- ** Lenses - , announce - , announceList - , comment - , createdBy - , creationDate - , encoding - , infoDict - , publisher - , publisherURL - , signature -#endif - - -- ** Utils - , nullTorrent - , typeTorrent - , torrentExt - , isTorrentPath -#ifdef VERSION_bencoding - , fromFile - , toFile -#endif - - -- * Magnet - -- $magnet-link - , Magnet(..) - , nullMagnet - , simpleMagnet - , detailedMagnet - , parseMagnet - , renderMagnet - - -- ** URN - , URN (..) - , NamespaceId - , btih - , infohashURN - , parseURN - , renderURN - ) where - -import Prelude hiding ((<>)) -import Control.Applicative -import Control.DeepSeq -import Control.Exception --- import Control.Lens -import Control.Monad -import Crypto.Hash -#ifdef VERSION_bencoding -import Data.BEncode as BE -import Data.BEncode.Types as BE -#endif -import Data.Bits -#ifdef VERSION_bits_extras -import Data.Bits.Extras -#endif -import qualified Data.ByteArray as Bytes -import Data.ByteString as BS -import Data.ByteString.Base16 as Base16 -import Data.ByteString.Base32 as Base32 -import Data.ByteString.Base64 as Base64 -import Data.ByteString.Char8 as BC (pack, unpack) -import Data.ByteString.Lazy as BL -import Data.Char -import Data.Convertible -import Data.Default -import Data.Hashable as Hashable -import Data.Int -import Data.List as L -import Data.Map as M -import Data.Maybe -import Data.Serialize as S -import Data.String -import Data.Text as T -import Data.Text.Encoding as T -import Data.Text.Read -import Data.Time.Clock.POSIX -import Data.Typeable -import Network (HostName) -import Network.HTTP.Types.QueryLike -import Network.HTTP.Types.URI -import Network.URI -import Text.ParserCombinators.ReadP as P -import Text.PrettyPrint as PP -import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) -import System.FilePath -import System.Posix.Types - -import Network.Address - - -{----------------------------------------------------------------------- --- Info hash ------------------------------------------------------------------------} --- TODO --- --- data Word160 = Word160 {-# UNPACK #-} !Word64 --- {-# UNPACK #-} !Word64 --- {-# UNPACK #-} !Word32 --- --- newtype InfoHash = InfoHash Word160 --- --- reason: bytestring have overhead = 8 words, while infohash have length 20 bytes - --- $infohash --- --- Infohash is a unique identifier of torrent. - --- | Exactly 20 bytes long SHA1 hash of the info part of torrent file. -newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString } - deriving (Eq, Ord, Typeable) - -infoHashLen :: Int -infoHashLen = 20 - --- | Meaningless placeholder value. -instance Default InfoHash where - def = "0123456789012345678901234567890123456789" - --- | Hash raw bytes. (no encoding) -instance Hashable InfoHash where - hashWithSalt s (InfoHash ih) = hashWithSalt s ih - {-# INLINE hashWithSalt #-} - -#ifdef VERSION_bencoding --- | Convert to\/from raw bencoded string. (no encoding) -instance BEncode InfoHash where - toBEncode = toBEncode . getInfoHash - fromBEncode be = InfoHash <$> fromBEncode be -#endif - -#if 0 -instance TableKey KMessageOf InfoHash where - toNodeId = either (error msg) id . S.decode . S.encode - where -- TODO unsafe coerse? - msg = "tableKey: impossible" -#endif - - --- | Convert to\/from raw bytestring. (no encoding) -instance Serialize InfoHash where - put (InfoHash ih) = putByteString ih - {-# INLINE put #-} - - get = InfoHash <$> getBytes infoHashLen - {-# INLINE get #-} - --- | Convert to raw query value. (no encoding) -instance QueryValueLike InfoHash where - toQueryValue (InfoHash ih) = Just ih - {-# INLINE toQueryValue #-} - --- | Convert to base16 encoded string. -instance Show InfoHash where - show (InfoHash ih) = BC.unpack (Base16.encode ih) - --- | Convert to base16 encoded Doc string. -instance Pretty InfoHash where - pPrint = text . show - --- | Read base16 encoded string. -instance Read InfoHash where - readsPrec _ = readP_to_S $ do - str <- replicateM (infoHashLen * 2) (satisfy isHexDigit) - return $ InfoHash $ decodeIH str - where - decodeIH = BS.pack . L.map fromHex . pair - fromHex (a, b) = read $ '0' : 'x' : a : b : [] - - pair (a : b : xs) = (a, b) : pair xs - pair _ = [] - --- | Convert raw bytes to info hash. -instance Convertible BS.ByteString InfoHash where - safeConvert bs - | BS.length bs == infoHashLen = pure (InfoHash bs) - | otherwise = convError "invalid length" bs - --- | Parse infohash from base16\/base32\/base64 encoded string. -instance Convertible Text InfoHash where - safeConvert t - | 20 == hashLen = pure (InfoHash hashStr) - | 26 <= hashLen && hashLen <= 28 = - case Base64.decode hashStr of - Left msg -> convError ("invalid base64 encoding " ++ msg) t - Right ihStr -> safeConvert ihStr - - | hashLen == 32 = - case Base32.decode hashStr of - Left msg -> convError msg t - Right ihStr -> safeConvert ihStr - - | hashLen == 40 = - let (ihStr, inv) = Base16.decode hashStr - in if BS.length inv /= 0 - then convError "invalid base16 encoding" t - else safeConvert ihStr - - | otherwise = convError "invalid length" t - where - hashLen = BS.length hashStr - hashStr = T.encodeUtf8 t - --- | Decode from base16\/base32\/base64 encoded string. -instance IsString InfoHash where - fromString = either (error . prettyConvertError) id . safeConvert . T.pack - -ignoreErrorMsg :: Either a b -> Maybe b -ignoreErrorMsg = either (const Nothing) Just - --- | Tries both base16 and base32 while decoding info hash. --- --- Use 'safeConvert' for detailed error messages. --- -textToInfoHash :: Text -> Maybe InfoHash -textToInfoHash = ignoreErrorMsg . safeConvert - --- | Hex encode infohash to text, full length. -longHex :: InfoHash -> Text -longHex = T.decodeUtf8 . Base16.encode . getInfoHash - --- | The same as 'longHex', but only first 7 characters. -shortHex :: InfoHash -> Text -shortHex = T.take 7 . longHex - -{----------------------------------------------------------------------- --- File info ------------------------------------------------------------------------} - --- | Size of a file in bytes. -type FileSize = FileOffset - -#ifdef VERSION_bencoding -deriving instance BEncode FileOffset -#endif - --- | Contain metainfo about one single file. -data FileInfo a = FileInfo { - fiLength :: {-# UNPACK #-} !FileSize - -- ^ Length of the file in bytes. - - -- TODO unpacked MD5 sum - , fiMD5Sum :: !(Maybe BS.ByteString) - -- ^ 32 character long MD5 sum of the file. Used by third-party - -- tools, not by bittorrent protocol itself. - - , fiName :: !a - -- ^ One or more string elements that together represent the - -- path and filename. Each element in the list corresponds to - -- either a directory name or (in the case of the last element) - -- the filename. For example, the file: - -- - -- > "dir1/dir2/file.ext" - -- - -- would consist of three string elements: - -- - -- > ["dir1", "dir2", "file.ext"] - -- - } deriving (Show, Read, Eq, Typeable - , Functor, Foldable - ) - -#ifdef USE_lens -makeLensesFor - [ ("fiLength", "fileLength") - , ("fiMD5Sum", "fileMD5Sum") - , ("fiName" , "filePath" ) - ] - ''FileInfo -#endif - -instance NFData a => NFData (FileInfo a) where - rnf FileInfo {..} = rnf fiName - {-# INLINE rnf #-} - -#ifdef VERSION_bencoding -instance BEncode (FileInfo [BS.ByteString]) where - toBEncode FileInfo {..} = toDict $ - "length" .=! fiLength - .: "md5sum" .=? fiMD5Sum - .: "path" .=! fiName - .: endDict - {-# INLINE toBEncode #-} - - fromBEncode = fromDict $ do - FileInfo <$>! "length" - <*>? "md5sum" - <*>! "path" - {-# INLINE fromBEncode #-} - -type Put a = a -> BDict -> BDict -#endif - -#ifdef VERSION_bencoding -putFileInfoSingle :: Data.Torrent.Put (FileInfo BS.ByteString) -putFileInfoSingle FileInfo {..} cont = - "length" .=! fiLength - .: "md5sum" .=? fiMD5Sum - .: "name" .=! fiName - .: cont - -getFileInfoSingle :: BE.Get (FileInfo BS.ByteString) -getFileInfoSingle = do - FileInfo <$>! "length" - <*>? "md5sum" - <*>! "name" - -instance BEncode (FileInfo BS.ByteString) where - toBEncode = toDict . (`putFileInfoSingle` endDict) - {-# INLINE toBEncode #-} - - fromBEncode = fromDict getFileInfoSingle - {-# INLINE fromBEncode #-} -#endif - -instance Pretty (FileInfo BS.ByteString) where - pPrint FileInfo {..} = - "Path: " <> text (T.unpack (T.decodeUtf8 fiName)) - $$ "Size: " <> text (show fiLength) - $$ maybe PP.empty ppMD5 fiMD5Sum - where - ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5)) - --- | Join file path. -joinFilePath :: FileInfo [BS.ByteString] -> FileInfo BS.ByteString -joinFilePath = fmap (BS.intercalate "/") - -{----------------------------------------------------------------------- --- Layout info ------------------------------------------------------------------------} - --- | Original (found in torrent file) layout info is either: --- --- * Single file with its /name/. --- --- * Multiple files with its relative file /paths/. --- -data LayoutInfo - = SingleFile - { -- | Single file info. - liFile :: !(FileInfo BS.ByteString) - } - | MultiFile - { -- | List of the all files that torrent contains. - liFiles :: ![FileInfo [BS.ByteString]] - - -- | The /suggested/ name of the root directory in which to - -- store all the files. - , liDirName :: !BS.ByteString - } deriving (Show, Read, Eq, Typeable) - -#ifdef USE_lens -makeLensesFor - [ ("liFile" , "singleFile" ) - , ("liFiles" , "multiFile" ) - , ("liDirName", "rootDirName") - ] - ''LayoutInfo -#endif - -instance NFData LayoutInfo where - rnf SingleFile {..} = () - rnf MultiFile {..} = rnf liFiles - --- | Empty multifile layout. -instance Default LayoutInfo where - def = MultiFile [] "" - -#ifdef VERSION_bencoding -getLayoutInfo :: BE.Get LayoutInfo -getLayoutInfo = single <|> multi - where - single = SingleFile <$> getFileInfoSingle - multi = MultiFile <$>! "files" <*>! "name" - -putLayoutInfo :: Data.Torrent.Put LayoutInfo -putLayoutInfo SingleFile {..} = putFileInfoSingle liFile -putLayoutInfo MultiFile {..} = \ cont -> - "files" .=! liFiles - .: "name" .=! liDirName - .: cont - -instance BEncode LayoutInfo where - toBEncode = toDict . (`putLayoutInfo` endDict) - fromBEncode = fromDict getLayoutInfo -#endif - -instance Pretty LayoutInfo where - pPrint SingleFile {..} = pPrint liFile - pPrint MultiFile {..} = vcat $ L.map (pPrint . joinFilePath) liFiles - --- | Test if this is single file torrent. -isSingleFile :: LayoutInfo -> Bool -isSingleFile SingleFile {} = True -isSingleFile _ = False -{-# INLINE isSingleFile #-} - --- | Test if this is multifile torrent. -isMultiFile :: LayoutInfo -> Bool -isMultiFile MultiFile {} = True -isMultiFile _ = False -{-# INLINE isMultiFile #-} - --- | Get name of the torrent based on the root path piece. -suggestedName :: LayoutInfo -> BS.ByteString -suggestedName (SingleFile FileInfo {..}) = fiName -suggestedName MultiFile {..} = liDirName -{-# INLINE suggestedName #-} - --- | Find sum of sizes of the all torrent files. -contentLength :: LayoutInfo -> FileSize -contentLength SingleFile { liFile = FileInfo {..} } = fiLength -contentLength MultiFile { liFiles = tfs } = L.sum (L.map fiLength tfs) - --- | Get number of all files in torrent. -fileCount :: LayoutInfo -> Int -fileCount SingleFile {..} = 1 -fileCount MultiFile {..} = L.length liFiles - --- | Find number of blocks of the specified size. If torrent size is --- not a multiple of block size then the count is rounded up. -blockCount :: Int -> LayoutInfo -> Int -blockCount blkSize ci = contentLength ci `sizeInBase` blkSize - ------------------------------------------------------------------------- - --- | File layout specifies the order and the size of each file in the --- storage. Note that order of files is highly important since we --- coalesce all the files in the given order to get the linear block --- address space. --- -type FileLayout a = [(FilePath, a)] - --- | Extract files layout from torrent info with the given root path. -flatLayout - :: FilePath -- ^ Root path for the all torrent files. - -> LayoutInfo -- ^ Torrent content information. - -> FileLayout FileSize -- ^ The all file paths prefixed with the given root. -flatLayout prefixPath SingleFile { liFile = FileInfo {..} } - = [(prefixPath BC.unpack fiName, fiLength)] -flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles - where -- TODO use utf8 encoding in name - mkPath FileInfo {..} = (_path, fiLength) - where - _path = prefixPath BC.unpack liDirName - joinPath (L.map BC.unpack fiName) - --- | Calculate offset of each file based on its length, incrementally. -accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize) -accumPositions = go 0 - where - go !_ [] = [] - go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs - --- | Gives global offset of a content file for a given full path. -fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset -fileOffset = L.lookup -{-# INLINE fileOffset #-} - ------------------------------------------------------------------------- - --- | Divide and round up. -sizeInBase :: Integral a => a -> Int -> Int -sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align - where - align = if n `mod` fromIntegral b == 0 then 0 else 1 -{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-} -{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-} - -{----------------------------------------------------------------------- --- Piece attributes ------------------------------------------------------------------------} - --- | Zero-based index of piece in torrent content. -type PieceIx = Int - --- | Size of piece in bytes. Should be a power of 2. --- --- NOTE: Have max and min size constrained to wide used --- semi-standard values. This bounds should be used to make decision --- about piece size for new torrents. --- -type PieceSize = Int - --- | Number of pieces in torrent or a part of torrent. -type PieceCount = Int - -defaultBlockSize :: Int -defaultBlockSize = 16 * 1024 - --- | Optimal number of pieces in torrent. -optimalPieceCount :: PieceCount -optimalPieceCount = 1000 -{-# INLINE optimalPieceCount #-} - --- | Piece size should not be less than this value. -minPieceSize :: Int -minPieceSize = defaultBlockSize * 4 -{-# INLINE minPieceSize #-} - --- | To prevent transfer degradation piece size should not exceed this --- value. -maxPieceSize :: Int -maxPieceSize = 4 * 1024 * 1024 -{-# INLINE maxPieceSize #-} - -toPow2 :: Int -> Int -#ifdef VERSION_bits_extras -toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x) -#else -toPow2 x = bit $ fromIntegral (countLeadingZeros (0 :: Int) - countLeadingZeros x) -#endif - --- | Find the optimal piece size for a given torrent size. -defaultPieceSize :: Int64 -> Int -defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc - where - pc = fromIntegral (x `div` fromIntegral optimalPieceCount) - -{----------------------------------------------------------------------- --- Piece data ------------------------------------------------------------------------} - -type PieceHash = BS.ByteString - -hashsize :: Int -hashsize = 20 -{-# INLINE hashsize #-} - --- TODO check if pieceLength is power of 2 --- | Piece payload should be strict or lazy bytestring. -data Piece a = Piece - { -- | Zero-based piece index in torrent. - pieceIndex :: {-# UNPACK #-} !PieceIx - - -- | Payload. - , pieceData :: !a - } deriving (Show, Read, Eq, Functor, Typeable) - -instance NFData a => NFData (Piece a) where - rnf (Piece a b) = rnf a `seq` rnf b - --- | Payload bytes are omitted. -instance Pretty (Piece a) where - pPrint Piece {..} = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex) - --- | Get size of piece in bytes. -pieceSize :: Piece BL.ByteString -> PieceSize -pieceSize Piece {..} = fromIntegral (BL.length pieceData) - --- | Get piece hash. -hashPiece :: Piece BL.ByteString -> PieceHash -hashPiece Piece {..} = Bytes.convert (hashlazy pieceData :: Digest SHA1) - -{----------------------------------------------------------------------- --- Piece control ------------------------------------------------------------------------} - --- | A flat array of SHA1 hash for each piece. -newtype HashList = HashList { unHashList :: BS.ByteString } - deriving ( Show, Read, Eq, Typeable -#ifdef VERSION_bencoding - , BEncode -#endif - ) - --- | Empty hash list. -instance Default HashList where - def = HashList "" - --- | Part of torrent file used for torrent content validation. -data PieceInfo = PieceInfo - { piPieceLength :: {-# UNPACK #-} !PieceSize - -- ^ Number of bytes in each piece. - - , piPieceHashes :: !HashList - -- ^ Concatenation of all 20-byte SHA1 hash values. - } deriving (Show, Read, Eq, Typeable) - -#ifdef USE_lens --- | Number of bytes in each piece. -makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo - --- | Concatenation of all 20-byte SHA1 hash values. -makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo -#endif - -instance NFData PieceInfo where - rnf (PieceInfo a (HashList b)) = rnf a `seq` rnf b - -instance Default PieceInfo where - def = PieceInfo 1 def - - -#ifdef VERSION_bencoding -putPieceInfo :: Data.Torrent.Put PieceInfo -putPieceInfo PieceInfo {..} cont = - "piece length" .=! piPieceLength - .: "pieces" .=! piPieceHashes - .: cont - -getPieceInfo :: BE.Get PieceInfo -getPieceInfo = do - PieceInfo <$>! "piece length" - <*>! "pieces" - -instance BEncode PieceInfo where - toBEncode = toDict . (`putPieceInfo` endDict) - fromBEncode = fromDict getPieceInfo -#endif - --- | Hashes are omitted. -instance Pretty PieceInfo where - pPrint PieceInfo {..} = "Piece size: " <> int piPieceLength - -slice :: Int -> Int -> BS.ByteString -> BS.ByteString -slice start len = BS.take len . BS.drop start -{-# INLINE slice #-} - --- | Extract validation hash by specified piece index. -pieceHash :: PieceInfo -> PieceIx -> PieceHash -pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashList piPieceHashes) - --- | Find count of pieces in the torrent. If torrent size is not a --- multiple of piece size then the count is rounded up. -pieceCount :: PieceInfo -> PieceCount -pieceCount PieceInfo {..} = BS.length (unHashList piPieceHashes) `quot` hashsize - --- | Test if this is last piece in torrent content. -isLastPiece :: PieceInfo -> PieceIx -> Bool -isLastPiece ci i = pieceCount ci == succ i - --- | Validate piece with metainfo hash. -checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool -checkPieceLazy pinfo @ PieceInfo {..} Piece {..} - = (fromIntegral (BL.length pieceData) == piPieceLength - || isLastPiece pinfo pieceIndex) - && Bytes.convert (hashlazy pieceData :: Digest SHA1) == pieceHash pinfo pieceIndex - -{----------------------------------------------------------------------- --- Info dictionary ------------------------------------------------------------------------} - -{- note that info hash is actually reduntant field - but it's better to keep it here to avoid heavy recomputations --} - --- | Info part of the .torrent file contain info about each content file. -data InfoDict = InfoDict - { idInfoHash :: !InfoHash - -- ^ SHA1 hash of the (other) 'DictInfo' fields. - - , idLayoutInfo :: !LayoutInfo - -- ^ File layout (name, size, etc) information. - - , idPieceInfo :: !PieceInfo - -- ^ Content validation information. - - , idPrivate :: !Bool - -- ^ If set the client MUST publish its presence to get other - -- peers ONLY via the trackers explicity described in the - -- metainfo file. - -- - -- BEP 27: - } deriving (Show, Read, Eq, Typeable) - -#ifdef VERISON_lens -makeLensesFor - [ ("idInfoHash" , "infohash" ) - , ("idLayoutInfo", "layoutInfo") - , ("idPieceInfo" , "pieceInfo" ) - , ("idPrivate" , "isPrivate" ) - ] - ''InfoDict -#endif - -instance NFData InfoDict where - rnf InfoDict {..} = rnf idLayoutInfo - -instance Hashable InfoDict where - hashWithSalt = Hashable.hashUsing idInfoHash - {-# INLINE hashWithSalt #-} - --- | Hash lazy bytestring using SHA1 algorithm. -hashLazyIH :: BL.ByteString -> InfoHash -hashLazyIH = either (const (error msg)) id . safeConvert . (Bytes.convert :: Digest SHA1 -> BS.ByteString) . hashlazy - where - msg = "Infohash.hash: impossible: SHA1 is always 20 bytes long" - -#ifdef VERSION_bencoding --- | Empty info dictionary with zero-length content. -instance Default InfoDict where - def = infoDictionary def def False - --- | Smart constructor: add a info hash to info dictionary. -infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict -infoDictionary li pinfo private = InfoDict ih li pinfo private - where - ih = hashLazyIH $ BE.encode $ InfoDict def li pinfo private - -getPrivate :: BE.Get Bool -getPrivate = (Just True ==) <$>? "private" - -putPrivate :: Bool -> BDict -> BDict -putPrivate False = id -putPrivate True = \ cont -> "private" .=! True .: cont - -instance BEncode InfoDict where - toBEncode InfoDict {..} = toDict $ - putLayoutInfo idLayoutInfo $ - putPieceInfo idPieceInfo $ - putPrivate idPrivate $ - endDict - - fromBEncode dict = (`fromDict` dict) $ do - InfoDict ih <$> getLayoutInfo - <*> getPieceInfo - <*> getPrivate - where - ih = hashLazyIH (BE.encode dict) -#endif - -ppPrivacy :: Bool -> Doc -ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public" - ---ppAdditionalInfo :: InfoDict -> Doc ---ppAdditionalInfo layout = PP.empty - -instance Pretty InfoDict where - pPrint InfoDict {..} = - pPrint idLayoutInfo $$ - pPrint idPieceInfo $$ - ppPrivacy idPrivate - -{----------------------------------------------------------------------- --- Torrent info ------------------------------------------------------------------------} --- TODO add torrent file validation - --- | Metainfo about particular torrent. -data Torrent = Torrent - { tAnnounce :: !(Maybe URI) - -- ^ The URL of the tracker. - - , tAnnounceList :: !(Maybe [[URI]]) - -- ^ Announce list add multiple tracker support. - -- - -- BEP 12: - - , tComment :: !(Maybe Text) - -- ^ Free-form comments of the author. - - , tCreatedBy :: !(Maybe Text) - -- ^ Name and version of the program used to create the .torrent. - - , tCreationDate :: !(Maybe POSIXTime) - -- ^ Creation time of the torrent, in standard UNIX epoch. - - , tEncoding :: !(Maybe Text) - -- ^ String encoding format used to generate the pieces part of - -- the info dictionary in the .torrent metafile. - - , tInfoDict :: !InfoDict - -- ^ Info about each content file. - - , tNodes :: !(Maybe [NodeAddr HostName]) - -- ^ This key should be set to the /K closest/ nodes in the - -- torrent generating client's routing table. Alternatively, the - -- key could be set to a known good 'Network.Address.Node' - -- such as one operated by the person generating the torrent. - -- - -- Please do not automatically add \"router.bittorrent.com\" to - -- this list because different bittorrent software may prefer to - -- use different bootstrap node. - - , tPublisher :: !(Maybe URI) - -- ^ Containing the RSA public key of the publisher of the - -- torrent. Private counterpart of this key that has the - -- authority to allow new peers onto the swarm. - - , tPublisherURL :: !(Maybe URI) - , tSignature :: !(Maybe BS.ByteString) - -- ^ The RSA signature of the info dictionary (specifically, the - -- encrypted SHA-1 hash of the info dictionary). - } deriving (Show, Eq, Typeable) - -#ifdef USE_lens -makeLensesFor - [ ("tAnnounce" , "announce" ) - , ("tAnnounceList", "announceList") - , ("tComment" , "comment" ) - , ("tCreatedBy" , "createdBy" ) - , ("tCreationDate", "creationDate") - , ("tEncoding" , "encoding" ) - , ("tInfoDict" , "infoDict" ) - , ("tPublisher" , "publisher" ) - , ("tPublisherURL", "publisherURL") - , ("tSignature" , "signature" ) - ] - ''Torrent -#endif - -instance NFData Torrent where - rnf Torrent {..} = rnf tInfoDict - -#ifdef VERSION_bencoding --- TODO move to bencoding -instance BEncode URI where - toBEncode uri = toBEncode (BC.pack (uriToString id uri "")) - {-# INLINE toBEncode #-} - - fromBEncode (BString s) | Just url <- parseURI (BC.unpack s) = return url - fromBEncode b = decodingError $ "url <" ++ show b ++ ">" - {-# INLINE fromBEncode #-} - ---pico2uni :: Pico -> Uni ---pico2uni = undefined - --- TODO move to bencoding -instance BEncode POSIXTime where - toBEncode pt = toBEncode (floor pt :: Integer) - fromBEncode (BInteger i) = return $ fromIntegral i - fromBEncode _ = decodingError $ "POSIXTime" - --- TODO to bencoding package -instance {-# OVERLAPPING #-} BEncode String where - toBEncode = toBEncode . T.pack - fromBEncode v = T.unpack <$> fromBEncode v - -instance BEncode Torrent where - toBEncode Torrent {..} = toDict $ - "announce" .=? tAnnounce - .: "announce-list" .=? tAnnounceList - .: "comment" .=? tComment - .: "created by" .=? tCreatedBy - .: "creation date" .=? tCreationDate - .: "encoding" .=? tEncoding - .: "info" .=! tInfoDict - .: "nodes" .=? tNodes - .: "publisher" .=? tPublisher - .: "publisher-url" .=? tPublisherURL - .: "signature" .=? tSignature - .: endDict - - fromBEncode = fromDict $ do - Torrent <$>? "announce" - <*>? "announce-list" - <*>? "comment" - <*>? "created by" - <*>? "creation date" - <*>? "encoding" - <*>! "info" - <*>? "nodes" - <*>? "publisher" - <*>? "publisher-url" - <*>? "signature" -#endif - -(<:>) :: Doc -> Doc -> Doc -name <:> v = name <> ":" <+> v - -(<:>?) :: Doc -> Maybe Doc -> Doc -_ <:>? Nothing = PP.empty -name <:>? (Just d) = name <:> d - -instance Pretty Torrent where - pPrint Torrent {..} = - "InfoHash: " <> pPrint (idInfoHash tInfoDict) - $$ hang "General" 4 generalInfo - $$ hang "Tracker" 4 trackers - $$ pPrint tInfoDict - where - trackers = case tAnnounceList of - Nothing -> text (show tAnnounce) - Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs - where - ppTier (n, xs) = "Tier #" <> int n <:> vcat (L.map (text . show) xs) - - generalInfo = - "Comment" <:>? ((text . T.unpack) <$> tComment) $$ - "Created by" <:>? ((text . T.unpack) <$> tCreatedBy) $$ - "Created on" <:>? ((text . show . posixSecondsToUTCTime) - <$> tCreationDate) $$ - "Encoding" <:>? ((text . T.unpack) <$> tEncoding) $$ - "Publisher" <:>? ((text . show) <$> tPublisher) $$ - "Publisher URL" <:>? ((text . show) <$> tPublisherURL) $$ - "Signature" <:>? ((text . show) <$> tSignature) - -#ifdef VERSION_bencoding --- | No files, no trackers, no nodes, etc... -instance Default Torrent where - def = nullTorrent def -#endif - --- | A simple torrent contains only required fields. -nullTorrent :: InfoDict -> Torrent -nullTorrent info = Torrent - Nothing Nothing Nothing Nothing Nothing Nothing - info Nothing Nothing Nothing Nothing - --- | Mime type of torrent files. -typeTorrent :: BS.ByteString -typeTorrent = "application/x-bittorrent" - --- | Extension usually used for torrent files. -torrentExt :: String -torrentExt = "torrent" - --- | Test if this path has proper extension. -isTorrentPath :: FilePath -> Bool -isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt - -#ifdef VERSION_bencoding --- | Read and decode a .torrent file. -fromFile :: FilePath -> IO Torrent -fromFile filepath = do - contents <- BS.readFile filepath - case BE.decode contents of - Right !t -> return t - Left msg -> throwIO $ userError $ msg ++ " while reading torrent file" - --- | Encode and write a .torrent file. -toFile :: FilePath -> Torrent -> IO () -toFile filepath = BL.writeFile filepath . BE.encode -#endif - -{----------------------------------------------------------------------- --- URN ------------------------------------------------------------------------} - --- | Namespace identifier determines the syntactic interpretation of --- namespace-specific string. -type NamespaceId = [Text] - --- | BitTorrent Info Hash (hence the name) namespace --- identifier. Namespace-specific string /should/ be a base16\/base32 --- encoded SHA1 hash of the corresponding torrent /info/ dictionary. --- -btih :: NamespaceId -btih = ["btih"] - --- | URN is pesistent location-independent identifier for --- resources. In particular, URNs are used represent torrent names --- as a part of magnet link, see 'Data.Torrent.Magnet.Magnet' for --- more info. --- -data URN = URN - { urnNamespace :: NamespaceId -- ^ a namespace identifier; - , urnString :: Text -- ^ a corresponding - -- namespace-specific string. - } deriving (Eq, Ord, Typeable) - ------------------------------------------------------------------------ - -instance Convertible URN InfoHash where - safeConvert u @ URN {..} - | urnNamespace /= btih = convError "invalid namespace" u - | otherwise = safeConvert urnString - --- | Make resource name for torrent with corresponding --- infohash. Infohash is base16 (hex) encoded. --- -infohashURN :: InfoHash -> URN -infohashURN = URN btih . longHex - --- | Meaningless placeholder value. -instance Default URN where - def = infohashURN def - ------------------------------------------------------------------------- - --- | Render URN to its text representation. -renderURN :: URN -> Text -renderURN URN {..} - = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString] - -instance Pretty URN where - pPrint = text . T.unpack . renderURN - -instance Show URN where - showsPrec n = showsPrec n . T.unpack . renderURN - -instance QueryValueLike URN where - toQueryValue = toQueryValue . renderURN - {-# INLINE toQueryValue #-} - ------------------------------------------------------------------------ - -_unsnoc :: [a] -> Maybe ([a], a) -_unsnoc [] = Nothing -_unsnoc xs = Just (L.init xs, L.last xs) - -instance Convertible Text URN where - safeConvert t = case T.split (== ':') t of - uriScheme : body - | T.toLower uriScheme == "urn" -> - case _unsnoc body of - Just (namespace, val) -> pure URN - { urnNamespace = namespace - , urnString = val - } - Nothing -> convError "missing URN string" body - | otherwise -> convError "invalid URN scheme" uriScheme - [] -> convError "missing URN scheme" t - -instance IsString URN where - fromString = either (error . prettyConvertError) id - . safeConvert . T.pack - --- | Try to parse an URN from its text representation. --- --- Use 'safeConvert' for detailed error messages. --- -parseURN :: Text -> Maybe URN -parseURN = either (const Nothing) pure . safeConvert - -{----------------------------------------------------------------------- --- Magnet ------------------------------------------------------------------------} --- $magnet-link --- --- Magnet URI scheme is an standard defining Magnet links. Magnet --- links are refer to resources by hash, in particular magnet links --- can refer to torrent using corresponding infohash. In this way, --- magnet links can be used instead of torrent files. --- --- This module provides bittorrent specific implementation of magnet --- links. --- --- For generic magnet uri scheme see: --- , --- --- --- Bittorrent specific details: --- --- - --- TODO multiple exact topics --- TODO render/parse supplement for URI/query - --- | An URI used to identify torrent. -data Magnet = Magnet - { -- | Torrent infohash hash. Can be used in DHT queries if no - -- 'tracker' provided. - exactTopic :: !InfoHash -- TODO InfoHash -> URN? - - -- | A filename for the file to download. Can be used to - -- display name while waiting for metadata. - , displayName :: Maybe Text - - -- | Size of the resource in bytes. - , exactLength :: Maybe Integer - - -- | URI pointing to manifest, e.g. a list of further items. - , manifest :: Maybe Text - - -- | Search string. - , keywordTopic :: Maybe Text - - -- | A source to be queried after not being able to find and - -- download the file in the bittorrent network in a defined - -- amount of time. - , acceptableSource :: Maybe URI - - -- | Direct link to the resource. - , exactSource :: Maybe URI - - -- | URI to the tracker. - , tracker :: Maybe URI - - -- | Additional or experimental parameters. - , supplement :: Map Text Text - } deriving (Eq, Ord, Typeable) - -instance QueryValueLike Integer where - toQueryValue = toQueryValue . show - -instance QueryValueLike URI where - toQueryValue = toQueryValue . show - -instance QueryLike Magnet where - toQuery Magnet {..} = - [ ("xt", toQueryValue $ infohashURN exactTopic) - , ("dn", toQueryValue displayName) - , ("xl", toQueryValue exactLength) - , ("mt", toQueryValue manifest) - , ("kt", toQueryValue keywordTopic) - , ("as", toQueryValue acceptableSource) - , ("xs", toQueryValue exactSource) - , ("tr", toQueryValue tracker) - ] - -instance QueryValueLike Magnet where - toQueryValue = toQueryValue . renderMagnet - -instance Convertible QueryText Magnet where - safeConvert xs = do - urnStr <- getTextMsg "xt" "exact topic not defined" xs - infoHash <- convertVia (error "safeConvert" :: URN) urnStr - return Magnet - { exactTopic = infoHash - , displayName = getText "dn" xs - , exactLength = getText "xl" xs >>= getInt - , manifest = getText "mt" xs - , keywordTopic = getText "kt" xs - , acceptableSource = getText "as" xs >>= getURI - , exactSource = getText "xs" xs >>= getURI - , tracker = getText "tr" xs >>= getURI - , supplement = M.empty - } - where - getInt = either (const Nothing) (Just . fst) . signed decimal - getURI = parseURI . T.unpack - getText p = join . L.lookup p - getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps - -magnetScheme :: URI -magnetScheme = URI - { uriScheme = "magnet:" - , uriAuthority = Nothing - , uriPath = "" - , uriQuery = "" - , uriFragment = "" - } - -isMagnetURI :: URI -> Bool -isMagnetURI u = u { uriQuery = "" } == magnetScheme - --- | Can be used instead of 'parseMagnet'. -instance Convertible URI Magnet where - safeConvert u @ URI {..} - | not (isMagnetURI u) = convError "this is not a magnet link" u - | otherwise = safeConvert $ parseQueryText $ BC.pack uriQuery - --- | Can be used instead of 'renderMagnet'. -instance Convertible Magnet URI where - safeConvert m = pure $ magnetScheme - { uriQuery = BC.unpack $ renderQuery True $ toQuery m } - -instance Convertible String Magnet where - safeConvert str - | Just uri <- parseURI str = safeConvert uri - | otherwise = convError "unable to parse uri" str - ------------------------------------------------------------------------- - --- | Meaningless placeholder value. -instance Default Magnet where - def = Magnet - { exactTopic = def - , displayName = Nothing - , exactLength = Nothing - , manifest = Nothing - , keywordTopic = Nothing - , acceptableSource = Nothing - , exactSource = Nothing - , tracker = Nothing - , supplement = M.empty - } - --- | Set 'exactTopic' ('xt' param) only, other params are empty. -nullMagnet :: InfoHash -> Magnet -nullMagnet u = Magnet - { exactTopic = u - , displayName = Nothing - , exactLength = Nothing - , manifest = Nothing - , keywordTopic = Nothing - , acceptableSource = Nothing - , exactSource = Nothing - , tracker = Nothing - , supplement = M.empty - } - --- | Like 'nullMagnet' but also include 'displayName' ('dn' param). -simpleMagnet :: Torrent -> Magnet -simpleMagnet Torrent {tInfoDict = InfoDict {..}} - = (nullMagnet idInfoHash) - { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo - } - --- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and --- 'tracker' ('tr' param). --- -detailedMagnet :: Torrent -> Magnet -detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce} - = (simpleMagnet t) - { exactLength = Just $ fromIntegral $ contentLength idLayoutInfo - , tracker = tAnnounce - } - ------------------------------------------------------------------------ - -parseMagnetStr :: String -> Maybe Magnet -parseMagnetStr = either (const Nothing) Just . safeConvert - -renderMagnetStr :: Magnet -> String -renderMagnetStr = show . (convert :: Magnet -> URI) - -instance Pretty Magnet where - pPrint = PP.text . renderMagnetStr - -instance Show Magnet where - show = renderMagnetStr - {-# INLINE show #-} - -instance Read Magnet where - readsPrec _ xs - | Just m <- parseMagnetStr mstr = [(m, rest)] - | otherwise = [] - where - (mstr, rest) = L.break (== ' ') xs - -instance IsString Magnet where - fromString str = fromMaybe (error msg) $ parseMagnetStr str - where - msg = "unable to parse magnet: " ++ str - --- | Try to parse magnet link from urlencoded string. Use --- 'safeConvert' to find out error location. --- -parseMagnet :: Text -> Maybe Magnet -parseMagnet = parseMagnetStr . T.unpack -{-# INLINE parseMagnet #-} - --- | Render magnet link to urlencoded string -renderMagnet :: Magnet -> Text -renderMagnet = T.pack . renderMagnetStr -{-# 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 @@ --- | This module assigns meaningful symbolic names to Tox message ids and --- classifies messages as lossy or lossless. -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -module Data.Tox.Message where - -import Data.Word - --- | The one-byte type code prefix that classifies a 'CryptoMessage'. -newtype MessageID = MessageID Word8 deriving (Eq,Enum,Ord,Bounded) -pattern Padding = MessageID 0 -- ^ 0 padding (skipped until we hit a non zero (data id) byte) -pattern PacketRequest = MessageID 1 -- ^ 1 packet request packet (lossy packet) -pattern KillPacket = MessageID 2 -- ^ 2 connection kill packet (lossy packet) -pattern UnspecifiedPacket003 = MessageID 3 -- ^ 3+ unspecified -pattern PING = MessageID 16 -- ^ 16+ reserved for Messenger usage (lossless packets) --- TODO: rename to ALIVE 16 --- SHARE_RELAYS 17 --- FRIEND_REQUESTS 18 -pattern ONLINE = MessageID 24 -- 1 byte -pattern OFFLINE = MessageID 25 -- 1 byte --- LOSSLESS_RANGE_SIZE 32 -pattern NICKNAME = MessageID 48 -- up to 129 bytes -pattern STATUSMESSAGE = MessageID 49 -- up to 1008 bytes -pattern USERSTATUS = MessageID 50 -- 2 bytes -pattern TYPING = MessageID 51 -- 2 bytes --- LOSSY_RANGE_SIZE 63 -pattern MESSAGE = MessageID 64 -- up to 1373 bytes -pattern ACTION = MessageID 65 -- up to 1373 bytes -pattern MSI = MessageID 69 -pattern FILE_SENDREQUEST = MessageID 80 -- 1+1+4+8+32+max255 = up to 301 -pattern FILE_CONTROL = MessageID 81 -- 8 bytes if seek, otherwise 4 -pattern FILE_DATA = MessageID 82 -- up to 1373 -pattern INVITE_GROUPCHAT = MessageID 95 -pattern INVITE_GROUPCHAT0 = MessageID 96 -- 0x60 --- TODO: rename to INVITE_CONFERENCE 96 -pattern ONLINE_PACKET = MessageID 97 -- 0x61 -pattern DIRECT_GROUPCHAT = MessageID 98 -- 0x62 --- TODO: rename to DIRECT_CONFERENCE 98 -pattern MESSAGE_GROUPCHAT = MessageID 99 -- 0x63 --- TODO: rename to MESSAGE_CONFERENCE 99 --- LOSSLESS_RANGE_START 160 -pattern MessengerLossy192 = MessageID 192 -- ^ 192+ reserved for Messenger usage (lossy packets) -pattern LOSSY_GROUPCHAT = MessageID 199 -- 0xC7 -pattern Messenger255 = MessageID 255 -- ^ 255 reserved for Messenger usage (lossless packet) - -instance Show MessageID where - show Padding = "Padding" - show PacketRequest = "PacketRequest" - show KillPacket = "KillPacket" - show UnspecifiedPacket003 = "UnspecifiedPacket003" - show PING = "PING" - show ONLINE = "ONLINE" - show OFFLINE = "OFFLINE" - show NICKNAME = "NICKNAME" - show STATUSMESSAGE = "STATUSMESSAGE" - show USERSTATUS = "USERSTATUS" - show TYPING = "TYPING" - show MESSAGE = "MESSAGE" - show ACTION = "ACTION" - show MSI = "MSI" - show FILE_SENDREQUEST = "FILE_SENDREQUEST" - show FILE_CONTROL = "FILE_CONTROL" - show FILE_DATA = "FILE_DATA" - show INVITE_GROUPCHAT = "INVITE_GROUPCHAT" - show ONLINE_PACKET = "ONLINE_PACKET" - show DIRECT_GROUPCHAT = "DIRECT_GROUPCHAT" - show MESSAGE_GROUPCHAT = "MESSAGE_GROUPCHAT" - show MessengerLossy192 = "MessengerLossy192" - show LOSSY_GROUPCHAT = "LOSSY_GROUPCHAT" - show Messenger255 = "Messenger255" - show (MessageID n) = "MessageID " ++ show n - -data LossyOrLossless = Lossless | Lossy - deriving (Eq,Ord,Enum,Show,Bounded) - --- | Classify a packet as lossy or lossless. -lossyness :: MessageID -> LossyOrLossless -lossyness (fromEnum -> x) | x < 3 = Lossy -lossyness (fromEnum -> x) | {-16 <= x,-} x < 192 = Lossless -lossyness (fromEnum -> x) | 192 <= x, x < 255 = Lossy -lossyness (fromEnum -> 255) = Lossless - - 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 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Tox.Msg where - -import Crypto.Error -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.ByteArray as BA -import Data.ByteString as B -import Data.Dependent.Sum -import Data.Functor.Contravariant -import Data.Functor.Identity -import Data.GADT.Compare -import Data.GADT.Show -import Data.Monoid -import Data.Serialize -import Data.Text as T -import Data.Text.Encoding as T -import Data.Typeable -import Data.Word -import GHC.TypeLits - -import Crypto.Tox -import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers) -import Network.Tox.NodeId - -newtype Unknown = Unknown B.ByteString deriving (Eq,Show) -newtype Padded = Padded B.ByteString deriving (Eq,Show) - --- The 'UserStatus' equivalent in Presence is: --- --- data JabberShow = Offline --- | ExtendedAway --- | Away -- Tox equiv: Away (1) --- | DoNotDisturb -- Tox equiv: Busy (2) --- | Available -- Tox equiv: Online (0) --- | Chatty --- deriving (Show,Enum,Ord,Eq,Read) --- --- The Enum instance on 'UserStatus' is not arbitrary. It corresponds --- to on-the-wire id numbers. -data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum) - -instance Serialize UserStatus where - get = do - x <- get :: Get Word8 - return (toEnum8 x) - put x = put (fromEnum8 x) - - -newtype MissingPackets = MissingPackets [Word32] - deriving (Eq,Show) - -data Msg (n :: Nat) t where - Padding :: Msg 0 Padded - PacketRequest :: Msg 1 MissingPackets - KillPacket :: Msg 2 () - ALIVE :: Msg 16 () - SHARE_RELAYS :: Msg 17 Unknown - FRIEND_REQUESTS :: Msg 18 Unknown - ONLINE :: Msg 24 () - OFFLINE :: Msg 25 () - NICKNAME :: Msg 48 Text - STATUSMESSAGE :: Msg 49 Text - USERSTATUS :: Msg 50 UserStatus - TYPING :: Msg 51 Bool - MESSAGE :: Msg 64 Text - ACTION :: Msg 65 Text - MSI :: Msg 69 Unknown - FILE_SENDREQUEST :: Msg 80 Unknown - FILE_CONTROL :: Msg 81 Unknown - FILE_DATA :: Msg 82 Unknown - INVITE_GROUPCHAT :: Msg 95 Invite - INVITE_CONFERENCE :: Msg 96 Unknown - ONLINE_PACKET :: Msg 97 Unknown - DIRECT_CONFERENCE :: Msg 98 Unknown - MESSAGE_CONFERENCE :: Msg 99 Unknown - LOSSY_CONFERENCE :: Msg 199 Unknown - -deriving instance Show (Msg n a) - -msgbyte :: KnownNat n => Msg n a -> Word8 -msgbyte m = fromIntegral (natVal $ proxy m) - where proxy :: Msg n a -> Proxy n - proxy _ = Proxy - -data Pkt a where Pkt :: (KnownNat n, Packet a, KnownMsg n) => Msg n a -> Pkt a - -deriving instance (Show (Pkt a)) - -type CryptoMessage = DSum Pkt Identity - -msgID (Pkt mid :=> Identity _) = M mid - --- TODO -instance GShow Pkt where gshowsPrec = showsPrec -instance ShowTag Pkt Identity where - showTaggedPrec (Pkt _) = showsPrec - -instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT -instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==) - -someMsgVal :: KnownMsg n => Msg n a -> SomeMsg -someMsgVal m = msgid (proxy m) - where proxy :: Msg n a -> Proxy n - proxy _ = Proxy - -class KnownMsg (n::Nat) where msgid :: proxy n -> SomeMsg - -instance KnownMsg 0 where msgid _ = M Padding -instance KnownMsg 1 where msgid _ = M PacketRequest -instance KnownMsg 2 where msgid _ = M KillPacket -instance KnownMsg 16 where msgid _ = M ALIVE -instance KnownMsg 17 where msgid _ = M SHARE_RELAYS -instance KnownMsg 18 where msgid _ = M FRIEND_REQUESTS -instance KnownMsg 24 where msgid _ = M ONLINE -instance KnownMsg 25 where msgid _ = M OFFLINE -instance KnownMsg 48 where msgid _ = M NICKNAME -instance KnownMsg 49 where msgid _ = M STATUSMESSAGE -instance KnownMsg 50 where msgid _ = M USERSTATUS -instance KnownMsg 51 where msgid _ = M TYPING -instance KnownMsg 64 where msgid _ = M MESSAGE -instance KnownMsg 65 where msgid _ = M ACTION -instance KnownMsg 69 where msgid _ = M MSI -instance KnownMsg 80 where msgid _ = M FILE_SENDREQUEST -instance KnownMsg 81 where msgid _ = M FILE_CONTROL -instance KnownMsg 82 where msgid _ = M FILE_DATA -instance KnownMsg 95 where msgid _ = M INVITE_GROUPCHAT -instance KnownMsg 96 where msgid _ = M INVITE_CONFERENCE -instance KnownMsg 97 where msgid _ = M ONLINE_PACKET -instance KnownMsg 98 where msgid _ = M DIRECT_CONFERENCE -instance KnownMsg 99 where msgid _ = M MESSAGE_CONFERENCE - -msgTag :: Word8 -> Maybe SomeMsg -msgTag 0 = Just $ M Padding -msgTag 1 = Just $ M PacketRequest -msgTag 2 = Just $ M KillPacket -msgTag 16 = Just $ M ALIVE -msgTag 17 = Just $ M SHARE_RELAYS -msgTag 18 = Just $ M FRIEND_REQUESTS -msgTag 24 = Just $ M ONLINE -msgTag 25 = Just $ M OFFLINE -msgTag 48 = Just $ M NICKNAME -msgTag 49 = Just $ M STATUSMESSAGE -msgTag 50 = Just $ M USERSTATUS -msgTag 51 = Just $ M TYPING -msgTag 64 = Just $ M MESSAGE -msgTag 65 = Just $ M ACTION -msgTag 69 = Just $ M MSI -msgTag 80 = Just $ M FILE_SENDREQUEST -msgTag 81 = Just $ M FILE_CONTROL -msgTag 82 = Just $ M FILE_DATA -msgTag 95 = Just $ M INVITE_GROUPCHAT -msgTag 96 = Just $ M INVITE_CONFERENCE -msgTag 97 = Just $ M ONLINE_PACKET -msgTag 98 = Just $ M DIRECT_CONFERENCE -msgTag 99 = Just $ M MESSAGE_CONFERENCE -msgTag _ = Nothing - - -class (Typeable t, Eq t, Show t, Sized t) => Packet t where - getPacket :: Word32 -> Get t - putPacket :: Word32 -> t -> Put - default getPacket :: Serialize t => Word32 -> Get t - getPacket _ = get - default putPacket :: Serialize t => Word32 -> t -> Put - putPacket _ t = put t - -instance Sized UserStatus where size = ConstSize 1 -instance Packet UserStatus - -instance Sized () where size = ConstSize 0 -instance Packet () where - getPacket _ = return () - putPacket _ _ = return () - -instance Sized MissingPackets where size = VarSize $ \(MissingPackets ws) -> Prelude.length ws -instance Packet MissingPackets where - getPacket seqno = do - bs <- B.unpack <$> (remaining >>= getBytes) - return $ MissingPackets (decompressSequenceNumbers seqno bs) - putPacket seqno (MissingPackets ws) = do - mapM_ putWord8 $ compressSequenceNumbers seqno ws - -instance Sized Unknown where size = VarSize $ \(Unknown bs) -> B.length bs -instance Packet Unknown where - getPacket _ = Unknown <$> (remaining >>= getBytes) - putPacket _ (Unknown bs) = putByteString bs - -instance Sized Padded where size = VarSize $ \(Padded bs) -> B.length bs -instance Packet Padded where - getPacket _ = Padded <$> (remaining >>= getBytes) - putPacket _ (Padded bs) = putByteString bs - -instance Sized Text where size = VarSize (B.length . T.encodeUtf8) -instance Packet Text where - getPacket _ = T.decodeUtf8 <$> (remaining >>= getBytes) - putPacket _ = putByteString . T.encodeUtf8 - -instance Sized Bool where size = ConstSize 1 -instance Packet Bool where - getPacket _ = (/= 0) <$> getWord8 - putPacket _ False = putWord8 0 - putPacket _ True = putWord8 1 - -data SomeMsg where - M :: (KnownMsg n, KnownNat n, Packet t) => Msg n t -> SomeMsg - -instance Eq SomeMsg where - M m == M n = msgbyte m == msgbyte n - -instance Show SomeMsg where - show (M m) = show m - -toEnum8 :: (Enum a, Integral word8) => word8 -> a -toEnum8 = toEnum . fromIntegral - -fromEnum8 :: Enum a => a -> Word8 -fromEnum8 = fromIntegral . fromEnum - -data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded) - -someLossyness (M m) = lossyness m - -lossyness :: KnownNat n => Msg n t -> LossyOrLossless -lossyness m = case msgbyte m of - x | x < 3 -> Lossy - | {-16 <= x,-} x < 192 -> Lossless - | 192 <= x, x < 255 -> Lossy - | otherwise -> Lossless - - -newtype ChatID = ChatID Ed25519.PublicKey - deriving Eq - -instance Sized ChatID where size = ConstSize 32 - -instance Serialize ChatID where - get = do - bs <- getBytes 32 - case Ed25519.publicKey bs of - CryptoPassed ed -> return $ ChatID ed - CryptoFailed e -> fail (show e) - put (ChatID ed) = putByteString $ BA.convert ed - -instance Read ChatID where - readsPrec _ s - | Right bs <- parseToken32 s - , CryptoPassed ed <- Ed25519.publicKey bs - = [ (ChatID ed, Prelude.drop 43 s) ] - | otherwise = [] - -instance Show ChatID where - show (ChatID ed) = showToken32 ed - -data InviteType = GroupInvite { groupName :: Text } - | AcceptedInvite - | ConfirmedInvite { inviteNodes :: [NodeInfo] } - deriving (Eq,Show) - -instance Sized InviteType where - size = VarSize $ \x -> case x of - GroupInvite name -> B.length (T.encodeUtf8 name) - AcceptedInvite -> 0 - ConfirmedInvite ns -> 0 -- TODO: size of node list. - -data Invite = Invite - { inviteChatID :: ChatID - , inviteChatKey :: PublicKey - , invite :: InviteType - } - deriving (Eq,Show) - -instance Sized Invite where - size = contramap inviteChatID size - <> contramap (key2id . inviteChatKey) size - <> contramap invite size - -instance Serialize Invite where - get = do - group_packet_id <- getWord8 -- expecting 254=GP_FRIEND_INVITE - invite_type <- getWord8 - chatid <- get - chatkey <- getPublicKey - Invite chatid chatkey <$> case invite_type of - 0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state. - return $ GroupInvite $ decodeUtf8 bs - 1 -> return AcceptedInvite - 2 -> return $ ConfirmedInvite [] -- TODO: decode nodes - - put x = do - putWord8 254 -- GP_FRIEND_INVITE - putWord8 $ case invite x of - GroupInvite {} -> 0 -- GROUP_INVITE - AcceptedInvite -> 1 -- GROUP_INVITE_ACCEPTED - ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION - put $ inviteChatID x - putPublicKey $ inviteChatKey x - case invite x of - GroupInvite name -> putByteString $ encodeUtf8 name - AcceptedInvite -> return () - ConfirmedInvite ns -> return () -- TODO: encode nodes. - -instance 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 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Tox.Onion where - - -import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort) -import Network.QueryResponse -import Crypto.Tox hiding (encrypt,decrypt) -import Network.Tox.NodeId -import qualified Crypto.Tox as ToxCrypto -import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo) - -import Control.Applicative -import Control.Arrow -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString as B - ;import Data.ByteString (ByteString) -import Data.Data -import Data.Function -import Data.Functor.Contravariant -import Data.Functor.Identity -#if MIN_VERSION_iproute(1,7,4) -import Data.IP hiding (fromSockAddr) -#else -import Data.IP -#endif -import Data.Maybe -import Data.Monoid -import Data.Serialize as S -import Data.Type.Equality -import Data.Typeable -import Data.Word -import GHC.Generics () -import GHC.TypeLits -import Network.Socket -import qualified Text.ParserCombinators.ReadP as RP -import Data.Hashable -import DPut -import DebugTag -import Data.Word64Map (fitsInInt) -import Data.Bits (shiftR,shiftL) -import qualified Rank2 - -type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a - -type UDPTransport = Transport String SockAddr ByteString - - -getOnionAsymm :: Get (Asymm (Encrypted DataToRoute)) -getOnionAsymm = getAliasedAsymm - -putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put -putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a - -data OnionMessage (f :: * -> *) - = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8))) - | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) -- XXX: Why is Nonce8 transmitted in the clear? - | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm - | OnionToRouteResponse (Asymm (Encrypted DataToRoute)) - -deriving instance ( Eq (f (AnnounceRequest, Nonce8)) - , Eq (f AnnounceResponse) - , Eq (f DataToRoute) - ) => Eq (OnionMessage f) - -deriving instance ( Ord (f (AnnounceRequest, Nonce8)) - , Ord (f AnnounceResponse) - , Ord (f DataToRoute) - ) => Ord (OnionMessage f) - -deriving instance ( Show (f (AnnounceRequest, Nonce8)) - , Show (f AnnounceResponse) - , Show (f DataToRoute) - ) => Show (OnionMessage f) - -instance Data (OnionMessage Encrypted) where - gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt - toConstr _ = error "OnionMessage.toConstr" - gunfold _ _ = error "OnionMessage.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage" -#else - dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionMessage" -#endif - -instance Rank2.Functor OnionMessage where - f <$> m = mapPayload (Proxy :: Proxy Serialize) f m - -instance Payload Serialize OnionMessage where - mapPayload _ f (OnionAnnounce a) = OnionAnnounce (fmap f a) - mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a) - mapPayload _ f (OnionToRoute k a) = OnionToRoute k a - mapPayload _ f (OnionToRouteResponse a) = OnionToRouteResponse a - - -msgNonce :: OnionMessage f -> Nonce24 -msgNonce (OnionAnnounce a) = asymmNonce a -msgNonce (OnionAnnounceResponse _ n24 _) = n24 -msgNonce (OnionToRoute _ a) = asymmNonce a -msgNonce (OnionToRouteResponse a) = asymmNonce a - -data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey - deriving (Eq,Show) - -data OnionDestination r - = OnionToOwner - { onionNodeInfo :: NodeInfo - , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us. - } - | OnionDestination - { onionAliasSelector' :: AliasSelector - , onionNodeInfo :: NodeInfo - , onionRouteSpec :: Maybe r -- ^ Our own onion-path. - } - deriving Show - -onionAliasSelector :: OnionDestination r -> AliasSelector -onionAliasSelector (OnionToOwner {} ) = SearchingAlias -onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel - -onionKey :: OnionDestination r -> PublicKey -onionKey od = id2key . nodeId $ onionNodeInfo od - -instance Sized (OnionMessage Encrypted) where - size = VarSize $ \case - OnionAnnounce a -> case size of ConstSize n -> n + 1 - VarSize f -> f a + 1 - OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33 - VarSize f -> f x + 33 - OnionToRoute pubkey a -> case size of ConstSize n -> n + 33 - VarSize f -> f a + 33 - OnionToRouteResponse a -> case size of ConstSize n -> n + 1 - VarSize f -> f a + 1 - -instance Serialize (OnionMessage Encrypted) where - get = do - typ <- get - case typ :: Word8 of - 0x83 -> OnionAnnounce <$> getAliasedAsymm - 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm - t -> fail ("Unknown onion payload: " ++ show t) - `fromMaybe` getOnionReply t - put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAsymm a - put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a - put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x - put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAsymm a - -onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r) -onionToOwner asymm ret3 saddr = do - ni <- nodeInfo (key2id $ senderKey asymm) saddr - return $ OnionToOwner ni ret3 --- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr - - -onion :: Sized msg => - ByteString - -> SockAddr - -> Get (Asymm (Encrypted msg) -> t) - -> Either String (t, OnionDestination r) -onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs - oaddr <- onionToOwner asymm ret3 saddr - return (f asymm, oaddr) - -parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r))) - -> (ByteString, SockAddr) - -> IO (Either (OnionMessage Encrypted,OnionDestination r) - (ByteString,SockAddr)) -parseOnionAddr lookupSender (msg,saddr) - | Just (typ,bs) <- B.uncons msg - , let right = Right (msg,saddr) - query = return . either (const right) Left - = case typ of - 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request - 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request - _ -> case flip runGet bs <$> getOnionReply typ of - Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do - maddr <- lookupSender saddr n8 - maybe (return right) -- Response unsolicited or too late. - (return . Left . \od -> (msg,od)) - maddr - Just (Right msg@(OnionToRouteResponse asym)) -> do - let ni = asymNodeInfo saddr asym - return $ Left (msg, OnionDestination SearchingAlias ni Nothing) - _ -> return right - -getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted)) -getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get -getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm -getOnionReply _ = Nothing - -putOnionMsg :: OnionMessage Encrypted -> Put -putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a -putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a -putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x -putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a - -newtype RouteId = RouteId Int - deriving Show - - --- We used to derive the RouteId from the Nonce8 associated with the query. --- This is problematic because a nonce generated by toxcore will not validate --- if it is received via a different route than it was issued. This is --- described by the Tox spec: --- --- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current --- time, some secret bytes generated when the instance is created, the --- current time divided by a 20 second timeout, the public key of the --- requester and the source ip/port that the packet was received from. Since --- the ip/port that the packet was received from is in the `ping_id`, the --- announce packets being sent with a ping id must be sent using the same --- path as the packet that we received the `ping_id` from or announcing will --- fail. --- --- The original idea was: --- --- > routeId :: Nonce8 -> RouteId --- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12 --- --- Instead, we'll just hash the destination node id. -routeId :: NodeId -> RouteId -routeId nid = RouteId $ mod (hash nid) 12 - - - -forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport -forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP } - -forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a -forwardAwait crypto udp sendTCP kont = do - fix $ \another -> do - awaitMessage udp $ \case - m@(Just (Right (bs,saddr))) -> case B.head bs of - 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another - 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another - 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another - 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another - 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another - 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another - _ -> kont m - m -> kont m - -forward :: forall c b b1. (Serialize b, Show b) => - (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c -forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs - -class SumToThree a b - -instance SumToThree N0 N3 -instance SumToThree (S a) b => SumToThree a (S b) - -class ( Serialize (ReturnPath n) - , Serialize (ReturnPath (S n)) - , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted)) - , ThreeMinus n ~ S (ThreeMinus (S n)) - ) => LessThanThree n - -instance LessThanThree N0 -instance LessThanThree N1 -instance LessThanThree N2 - -type family ThreeMinus n where - ThreeMinus N3 = N0 - ThreeMinus N2 = N1 - ThreeMinus N1 = N2 - ThreeMinus N0 = N3 - --- n = 0, 1, 2 -data OnionRequest n = OnionRequest - { onionNonce :: Nonce24 - , onionForward :: Forwarding (ThreeMinus n) (OnionMessage Encrypted) - , pathFromOwner :: ReturnPath n - } - deriving (Eq,Ord) - - -{- -instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n) - , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) - ) => Data (OnionRequest n) where - gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt - toConstr _ = error "OnionRequest.toConstr" - gunfold _ _ = error "OnionRequest.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionRequest" -#else - dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionRequest" -#endif --} - - -instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where - gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt - toConstr _ = error "OnionResponse.toConstr" - gunfold _ _ = error "OnionResponse.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionResponse" -#else - dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionResponse" -#endif - -deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) - , KnownNat (PeanoNat n) - ) => Show (OnionRequest n) - -instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce. - size = contramap onionNonce size - <> contramap onionForward size - <> contramap pathFromOwner size - -instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) - , Sized (ReturnPath n) - , Serialize (ReturnPath n) - , Typeable n - ) => Serialize (OnionRequest n) where - get = do - -- TODO share code with 'getOnionRequest' - n24 <- case eqT :: Maybe (n :~: N3) of - Just Refl -> return $ Nonce24 zeros24 - Nothing -> get - cnt <- remaining - let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n - fwd <- isolate fwdsize get - rpath <- get - return $ OnionRequest n24 fwd rpath - put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p - --- getRequest :: _ --- getRequest = OnionRequest <$> get <*> get <*> get - --- n = 1, 2, 3 --- Attributed (Encrypted ( - -data OnionResponse n = OnionResponse - { pathToOwner :: ReturnPath n - , msgToOwner :: OnionMessage Encrypted - } - deriving (Eq,Ord) - -deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n) - -instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where - get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding") - . getOnionReply) - put (OnionResponse p m) = put p >> putOnionMsg m - -instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where - size = contramap pathToOwner size <> contramap msgToOwner size - -data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a } - | TCPIndex { tcpIndex :: Int, unaddressed :: a } - deriving (Eq,Ord,Show) - -instance (Typeable a, Serialize a) => Data (Addressed a) where - gfoldl f z a = z (either error id . S.decode) `f` S.encode a - toConstr _ = error "Addressed.toConstr" - gunfold _ _ = error "Addressed.gunfold" -#if MIN_VERSION_base(4,2,0) - dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.Addressed" -#else - dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.Addressed" -#endif - -instance Sized a => Sized (Addressed a) where - size = case size :: Size a of - ConstSize n -> ConstSize $ 1{-family-} + 16{-ip-} + 2{-port-} + n - VarSize f -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x) - -getForwardAddr :: S.Get SockAddr -getForwardAddr = do - addrfam <- S.get :: S.Get Word8 - ip <- getIP addrfam - case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this. - IPv6 _ -> return () - port <- S.get :: S.Get PortNumber - return $ setPort port $ toSockAddr ip - - -putForwardAddr :: SockAddr -> S.Put -putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do - port <- sockAddrPort saddr - ip <- fromSockAddr $ either id id $ either4or6 saddr - return $ do - case ip of - IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0) - IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6 - S.put port - -addrToIndex :: SockAddr -> Int -addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) = - if fitsInInt (Proxy :: Proxy Word64) - then fromIntegral lo + (fromIntegral hi `shiftL` 32) - else fromIntegral lo -addrToIndex _ = 0 - -indexToAddr :: Int -> SockAddr -indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0 - --- Note, toxcore would check an address family byte here to detect a TCP-bound --- packet, but we instead use the IPv6 id and rely on the port number being --- zero. Since it will be symmetrically encrypted for our eyes only, it's not --- important to conform on this point. -instance Serialize a => Serialize (Addressed a) where - get = do saddr <- getForwardAddr - a <- get - case sockAddrPort saddr of - Just 0 -> return $ TCPIndex (addrToIndex saddr) a - _ -> return $ Addressed saddr a - put (Addressed addr x) = putForwardAddr addr >> put x - put (TCPIndex idx x) = putForwardAddr (indexToAddr idx) >> put x - -data N0 -data S n -type N1 = S N0 -type N2 = S N1 -type N3 = S N2 - -deriving instance Data N0 -deriving instance Data n => Data (S n) - -class KnownPeanoNat n where - peanoVal :: p n -> Int - -instance KnownPeanoNat N0 where - peanoVal _ = 0 -instance KnownPeanoNat n => KnownPeanoNat (S n) where - peanoVal _ = 1 + peanoVal (Proxy :: Proxy n) - -type family PeanoNat p where - PeanoNat N0 = 0 - PeanoNat (S n) = 1 + PeanoNat n - -data ReturnPath n where - NoReturnPath :: ReturnPath N0 - ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n) - -deriving instance Eq (ReturnPath n) -deriving instance Ord (ReturnPath n) - --- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce) -instance Sized (ReturnPath N0) where size = ConstSize 0 -instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where - size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n) - in error "non-constant ReturnPath size") - (size :: Size (ReturnPath n)) - -{- -instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where - size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n))) --} - -instance Serialize (ReturnPath N0) where get = pure NoReturnPath - put NoReturnPath = pure () - -instance Serialize (ReturnPath N1) where - get = ReturnPath <$> get <*> get - put (ReturnPath n24 p) = put n24 >> put p - -instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where - get = ReturnPath <$> get <*> get - put (ReturnPath n24 p) = put n24 >> put p - - -{- --- This doesn't work because it tried to infer it for (0 - 1) -instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where - get = ReturnPath <$> get <*> get - put (ReturnPath n24 p) = put n24 >> put p --} - -instance KnownNat (PeanoNat n) => Show (ReturnPath n) where - show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n))) - - --- instance KnownNat n => Serialize (ReturnPath n) where --- -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce) --- get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) ) --- put (ReturnPath bs) = putByteString bs - - -data Forwarding n msg where - NotForwarded :: msg -> Forwarding N0 msg - Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg - -deriving instance Eq msg => Eq (Forwarding n msg) -deriving instance Ord msg => Ord (Forwarding n msg) - -instance Show msg => Show (Forwarding N0 msg) where - show (NotForwarded x) = "NotForwarded "++show x - -instance ( KnownNat (PeanoNat (S n)) - , Show (Encrypted (Addressed (Forwarding n msg))) - ) => Show (Forwarding (S n) msg) where - show (Forwarding k a) = unwords [ "Forwarding" - , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")" - , show (key2id k) - , show a - ] - -instance Sized msg => Sized (Forwarding N0 msg) - where size = case size :: Size msg of - ConstSize n -> ConstSize n - VarSize f -> VarSize $ \(NotForwarded x) -> f x - -instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg) - where size = ConstSize 32 - <> contramap (\(Forwarding _ e) -> e) - (size :: Size (Encrypted (Addressed (Forwarding n msg)))) - -instance Serialize msg => Serialize (Forwarding N0 msg) where - get = NotForwarded <$> get - put (NotForwarded msg) = put msg - -instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where - get = Forwarding <$> getPublicKey <*> get - put (Forwarding k x) = putPublicKey k >> put x - -{- -rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)), - Serialize (ReturnPath n), - Serialize - (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) => - TransportCrypto - -> (forall x. x -> Addressed x) - -> OnionRequest n - -> IO (Either String (OnionRequest (S n), SockAddr)) -rewrap crypto saddr (OnionRequest nonce msg rpath) = do - (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto - <*> transportNewNonce crypto ) - peeled <- peelOnion crypto nonce msg - return $ peeled >>= \case - Addressed dst msg' - -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst) - _ -> Left "Onion forward to TCP client?" --} - -handleOnionRequest :: forall a proxy n. - ( LessThanThree n - , KnownPeanoNat n - , Sized (ReturnPath n) - , Typeable n - ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a -handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do - let n = peanoVal rpath - dput XOnion $ "handleOnionRequest " ++ show n - (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto - <*> transportNewNonce crypto ) - peeled <- peelOnion crypto nonce msg - let showDestination = case saddr () of - Addressed a _ -> either show show $ either4or6 a - TCPIndex i _ -> "TCP" ++ show [i] - - case peeled of - Left e -> do - dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e] - kont - Right (Addressed dst msg') -> do - dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"] - sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath) - kont - Right (TCPIndex {}) -> do - dput XUnexpected "handleOnionRequest: Onion forward to TCP client?" - kont - -wrapSymmetric :: Serialize (ReturnPath n) => - SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n) -wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath) - -peelSymmetric :: Serialize (Addressed (ReturnPath n)) - => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n)) -peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain - - -peelOnion :: Serialize (Addressed (Forwarding n t)) - => TransportCrypto - -> Nonce24 - -> Forwarding (S n) t - -> IO (Either String (Addressed (Forwarding n t))) -peelOnion crypto nonce (Forwarding k fwd) = do - fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) - -handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n), Typeable n) => - proxy (S n) - -> TransportCrypto - -> SockAddr - -> UDPTransport - -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send. - -> IO a - -> OnionResponse (S n) - -> IO a -handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do - sym <- atomically $ transportSymmetric crypto - case peelSymmetric sym path of - Left e -> do - -- todo report encryption error - let n = peanoVal path - dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e] - kont - Right (Addressed dst path') -> do - sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg) - kont - Right (TCPIndex dst path') -> do - case peanoVal path' of - 0 -> sendTCP dst msg - n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported." - kont - - -data AnnounceRequest = AnnounceRequest - { announcePingId :: Nonce32 -- Ping ID - , announceSeeking :: NodeId -- Public key we are searching for - , announceKey :: NodeId -- Public key that we want those sending back data packets to use - } - deriving Show - -instance Sized AnnounceRequest where size = ConstSize (32*3) - -instance S.Serialize AnnounceRequest where - get = AnnounceRequest <$> S.get <*> S.get <*> S.get - put (AnnounceRequest p s k) = S.put (p,s,k) - -getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3) -getOnionRequest = do - -- Assumes return path is constant size so that we can isolate - -- the variable-sized prefix. - cnt <- remaining - a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n) - getAliasedAsymm - path <- get - return (a,path) - -putRequest :: ( KnownPeanoNat n - , Serialize (OnionRequest n) - , Typeable n - ) => OnionRequest n -> Put -putRequest req = do - let tag = 0x80 + fromIntegral (peanoVal req) - when (tag <= 0x82) (putWord8 tag) - put req - -putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put -putResponse resp = do - let tag = 0x8f - fromIntegral (peanoVal resp) - -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag - -- in it's Serialize instance. - when (tag /= 0x8f) (putWord8 tag) - put resp - - -data KeyRecord = NotStored Nonce32 - | SendBackKey PublicKey - | Acknowledged Nonce32 - deriving Show - -instance Sized KeyRecord where size = ConstSize 33 - -instance S.Serialize KeyRecord where - get = do - is_stored <- S.get :: S.Get Word8 - case is_stored of - 1 -> SendBackKey <$> getPublicKey - 2 -> Acknowledged <$> S.get - _ -> NotStored <$> S.get - put (NotStored n32) = S.put (0 :: Word8) >> S.put n32 - put (SendBackKey key) = S.put (1 :: Word8) >> putPublicKey key - put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32 - -data AnnounceResponse = AnnounceResponse - { is_stored :: KeyRecord - , announceNodes :: SendNodes - } - deriving Show - -instance Sized AnnounceResponse where - size = contramap is_stored size <> contramap announceNodes size - -getNodeList :: S.Get [NodeInfo] -getNodeList = do - n <- S.get - (:) n <$> (getNodeList <|> pure []) - -instance S.Serialize AnnounceResponse where - get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList) - put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns - -data DataToRoute = DataToRoute - { dataFromKey :: PublicKey -- Real public key of sender - , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c - } - deriving Show - -instance Sized DataToRoute where - size = ConstSize 32 <> contramap dataToRoute size - -instance Serialize DataToRoute where - get = DataToRoute <$> getPublicKey <*> get - put (DataToRoute k dta) = putPublicKey k >> put dta - -data OnionData - = -- | type 0x9c - -- - -- We send this packet every 30 seconds if there is more than one peer (in - -- the 8) that says they our friend is announced on them. This packet can - -- also be sent through the DHT module as a DHT request packet (see DHT) if - -- we know the DHT public key of the friend and are looking for them in the - -- DHT but have not connected to them yet. 30 second is a reasonable - -- timeout to not flood the network with too many packets while making sure - -- the other will eventually receive the packet. Since packets are sent - -- through every peer that knows the friend, resending it right away - -- without waiting has a high likelihood of failure as the chances of - -- packet loss happening to all (up to to 8) packets sent is low. - -- - -- If a friend is online and connected to us, the onion will stop all of - -- its actions for that friend. If the peer goes offline it will restart - -- searching for the friend as if toxcore was just started. - OnionDHTPublicKey DHTPublicKey - | -- | type 0x20 - -- - -- - OnionFriendRequest FriendRequest -- 0x20 - deriving (Eq,Show) - -instance Sized OnionData where - size = VarSize $ \case - OnionDHTPublicKey dhtpk -> case size of - ConstSize n -> n -- Override because OnionData probably - -- should be treated as variable sized. - VarSize f -> f dhtpk - -- FIXME: inconsitantly, we have to add in the tag byte for this case. - OnionFriendRequest req -> 1 + case size of - ConstSize n -> n - VarSize f -> f req - -instance Serialize OnionData where - get = do - tag <- get - case tag :: Word8 of - 0x9c -> OnionDHTPublicKey <$> get - 0x20 -> OnionFriendRequest <$> get - _ -> fail $ "Unknown onion data: "++show tag - put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk - put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr - -selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey) -selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) - = return (skey, pkey) -selectKey crypto msg rpath = return $ aliasKey crypto rpath - -encrypt :: TransportCrypto - -> OnionMessage Identity - -> OnionDestination r - -> IO (OnionMessage Encrypted, OnionDestination r) -encrypt crypto msg rpath = do - (skey,pkey) <- selectKey crypto msg rpath -- source key - let okey = onionKey rpath -- destination key - encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a - encipher1 sk pk n a = Composed $ do - secret <- lookupSharedSecret crypto sk pk n - return $ ToxCrypto.encrypt secret $ encodePlain a - encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a - encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d - m <- sequenceMessage $ transcode encipher msg - return (m, rpath) - -decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r)) -decrypt crypto msg addr = do - (skey,pkey) <- selectKey crypto msg addr - let decipher1 :: Serialize a => - TransportCrypto -> SecretKey -> Nonce24 - -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a)) - -> (IO ∘ Either String ∘ Identity) a - decipher1 crypto k n arg = Composed $ do - let (sender,e) = either id (senderKey &&& asymmData) arg - secret <- lookupSharedSecret crypto k sender n - return $ Composed $ do - plain <- ToxCrypto.decrypt secret e - Identity <$> decodePlain plain - decipher :: Serialize a - => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a)) - -> (IO ∘ Either String ∘ Identity) a - decipher = (\n -> decipher1 crypto skey n . left (senderkey addr)) - foo <- sequenceMessage $ transcode decipher msg - return $ do - msg <- sequenceMessage foo - Right (msg, addr) - -senderkey :: OnionDestination r -> t -> (PublicKey, t) -senderkey addr e = (onionKey addr, e) - -aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey) -aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto -aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto - -dhtKey :: TransportCrypto -> (SecretKey,PublicKey) -dhtKey crypto = (transportSecret &&& transportPublic) crypto - -decryptMessage :: Serialize x => - TransportCrypto - -> (SecretKey,PublicKey) - -> Nonce24 - -> Either (PublicKey, Encrypted x) - (Asymm (Encrypted x)) - -> IO ((Either String ∘ Identity) x) -decryptMessage crypto (sk,pk) n arg = do - let (sender,e) = either id (senderKey &&& asymmData) arg - plain = Composed . fmap Identity . (>>= decodePlain) - secret <- lookupSharedSecret crypto sk sender n - return $ plain $ ToxCrypto.decrypt secret e - -sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) -sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a -sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta -sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a -sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a --- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a - -transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g -transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) } -transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta -transcode f (OnionToRoute pub a) = OnionToRoute pub a -transcode f (OnionToRouteResponse a) = OnionToRouteResponse a --- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) } - - -data OnionRoute = OnionRoute - { routeAliasA :: SecretKey - , routeAliasB :: SecretKey - , routeAliasC :: SecretKey - , routeNodeA :: NodeInfo - , routeNodeB :: NodeInfo - , routeNodeC :: NodeInfo - , routeRelayPort :: Maybe PortNumber - } - - -wrapOnion :: Serialize (Forwarding n msg) => - TransportCrypto - -> SecretKey - -> Nonce24 - -> PublicKey - -> SockAddr - -> Forwarding n msg - -> IO (Forwarding (S n) msg) -wrapOnion crypto skey nonce destkey saddr fwd = do - let plain = encodePlain $ Addressed saddr fwd - secret <- lookupSharedSecret crypto skey destkey nonce - return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain - -wrapOnionPure :: Serialize (Forwarding n msg) => - SecretKey - -> ToxCrypto.State - -> SockAddr - -> Forwarding n msg - -> Forwarding (S n) msg -wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain) - where - plain = encodePlain $ Addressed saddr fwd - - - --- TODO --- Two types of packets may be sent to Rendezvous via OnionToRoute requests. --- --- (1) DHT public key packet (0x9c) --- --- (2) Friend request -data Rendezvous = Rendezvous - { rendezvousKey :: PublicKey - , rendezvousNode :: NodeInfo - } - deriving Eq - -instance Show Rendezvous where - showsPrec d (Rendezvous k ni) - = showsPrec d (key2id k) - . (':' :) - . showsPrec d ni - -instance Read Rendezvous where - readsPrec d = RP.readP_to_S $ do - rkstr <- RP.munch (/=':') - RP.char ':' - nistr <- RP.munch (const True) - return Rendezvous - { rendezvousKey = id2key $ read rkstr - , rendezvousNode = read nistr - } - - -data AnnouncedRendezvous = AnnouncedRendezvous - { remoteUserKey :: PublicKey - , rendezvous :: Rendezvous - } - deriving Eq - -instance Show AnnouncedRendezvous where - showsPrec d (AnnouncedRendezvous remote rendez) - = showsPrec d (key2id remote) - . (':' :) - . showsPrec d rendez - -instance Read AnnouncedRendezvous where - readsPrec d = RP.readP_to_S $ do - ukstr <- RP.munch (/=':') - RP.char ':' - rkstr <- RP.munch (/=':') - RP.char ':' - nistr <- RP.munch (const True) - return AnnouncedRendezvous - { remoteUserKey = id2key $ read ukstr - , rendezvous = Rendezvous - { rendezvousKey = id2key $ read rkstr - , rendezvousNode = read nistr - } - } - - -selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector -selectAlias crypto pkey = do - ks <- filter (\(sk,pk) -> pk == id2key pkey) - <$> userKeys crypto - maybe (return SearchingAlias) - (return . uncurry AnnouncingAlias) - (listToMaybe ks) - - -parseDataToRoute - :: TransportCrypto - -> (OnionMessage Encrypted,OnionDestination r) - -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) -parseDataToRoute crypto (OnionToRouteResponse dta, od) = do - ks <- atomically $ userKeys crypto - - omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto) - (asymmNonce dta) - (Right dta) -- using Asymm{senderKey} as remote key - let eOuter = fmap runIdentity $ uncomposed omsg0 - - anyRight [] f = return $ Left "parseDataToRoute: no user key" - anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) - - -- TODO: We don't currently have a way to look up which user key we - -- announced using along this onion route. Therefore, for now, we will - -- try all our user keys to see if any can decrypt the packet. - eInner <- case eOuter of - Left e -> return $ Left e - Right dtr -> anyRight ks $ \(sk,pk) -> do - omsg0 <- decryptMessage crypto - (sk,pk) - (asymmNonce dta) - (Left (dataFromKey dtr, dataToRoute dtr)) - return $ do - omsg <- fmap runIdentity . uncomposed $ omsg0 - Right (pk,dtr,omsg) - - let e = do - (pk,dtr,omsg) <- eInner - return ( (pk, omsg) - , AnnouncedRendezvous - (dataFromKey dtr) - $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od ) - r = either (const $ Right (OnionToRouteResponse dta,od)) Left e - -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail - case e of - Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks) - Right _ -> return () - dput XMisc $ unlines - [ "parseDataToRoute " ++ either id (const "Right") e - , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner - , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter - , " outer.me = " ++ show (key2id $ rendezvousPublic crypto) - , " outer.them = " ++ show (key2id $ senderKey dta) - ] - return r -parseDataToRoute _ msg = return $ Right msg - -encodeDataToRoute :: TransportCrypto - -> ((PublicKey,OnionData),AnnouncedRendezvous) - -> IO (Maybe (OnionMessage Encrypted,OnionDestination r)) -encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do - nonce <- atomically $ transportNewNonce crypto - asel <- atomically $ selectAlias crypto (key2id me) - let (sk,pk) = case asel of - AnnouncingAlias sk pk -> (sk,pk) - _ -> (onionAliasSecret crypto, onionAliasPublic crypto) - innerSecret <- lookupSharedSecret crypto sk toxid nonce - let plain = encodePlain $ DataToRoute { dataFromKey = pk - , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg - } - outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce - let dta = ToxCrypto.encrypt outerSecret plain - dput XOnion $ unlines - [ "encodeDataToRoute me=" ++ show (key2id me) - , " dhtpk=" ++ case omsg of - OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg) - OnionFriendRequest fr -> "friend request" - , " ns=" ++ case omsg of - OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg) - OnionFriendRequest fr -> "friend request" - , " crypto inner.me =" ++ show (key2id pk) - , " inner.you=" ++ show (key2id toxid) - , " outer.me =" ++ show (key2id $ onionAliasPublic crypto) - , " outer.you=" ++ show (key2id pub) - , " " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni)) - , " " ++ show dta - ] - return $ Just ( OnionToRoute toxid -- Public key of destination node - Asymm { senderKey = onionAliasPublic crypto - , asymmNonce = nonce - , asymmData = dta - } - , 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 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} -module Data.Tox.Relay where - -import Data.Aeson (ToJSON(..),FromJSON(..)) -import qualified Data.Aeson as JSON -import Data.ByteString as B -import Data.Data -import Data.Functor.Contravariant -import Data.Hashable -import qualified Data.HashMap.Strict as HashMap -import Data.Monoid -import Data.Serialize -import qualified Data.Vector as Vector -import Data.Word -import Network.Socket -import qualified Rank2 -import qualified Text.ParserCombinators.ReadP as RP - -import Crypto.Tox -import Data.Tox.Onion -import qualified Network.Tox.NodeId as UDP - -newtype ConId = ConId Word8 - deriving (Eq,Show,Ord,Data,Serialize) - -badcon :: ConId -badcon = ConId 0 - --- Maps to a range -120 .. 119 -c2key :: ConId -> Maybe Int -c2key (ConId x) | x < 16 = Nothing - | otherwise = Just $ case divMod (x - 15) 2 of - (q,0) -> negate $ fromIntegral q - (q,1) -> fromIntegral q - --- Maps to range 16 .. 255 --- negatives become odds -key2c :: Int -> ConId -key2c y = ConId $ if y < 0 then 15 + fromIntegral (negate y * 2) - else 16 + fromIntegral (y * 2) - -data RelayPacket - = RoutingRequest PublicKey - | RoutingResponse ConId PublicKey -- 0 for refusal, 16-255 for success. - | ConnectNotification ConId - | DisconnectNotification ConId - | RelayPing Nonce8 - | RelayPong Nonce8 - | OOBSend PublicKey ByteString - | OOBRecv PublicKey ByteString - | OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0) - | OnionPacketResponse (OnionMessage Encrypted) - -- 0x0A through 0x0F reserved for future use. - | RelayData ByteString ConId - deriving (Eq,Ord,Show,Data) - -newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 } - deriving (Eq,Ord,Show) - -pattern PingPacket = PacketNumber 4 -pattern OnionPacketID = PacketNumber 8 - -packetNumber :: RelayPacket -> PacketNumber -packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed. -packetNumber rp = PacketNumber $ fromIntegral $ pred $ constrIndex $ toConstr rp - -instance Sized RelayPacket where - size = mappend (ConstSize 1) $ VarSize $ \x -> case x of - RoutingRequest k -> 32 - RoutingResponse rpid k -> 33 - ConnectNotification conid -> 1 - DisconnectNotification conid -> 1 - RelayPing pingid -> 8 - RelayPong pingid -> 8 - OOBSend k bs -> 32 + B.length bs - OOBRecv k bs -> 32 + B.length bs - OnionPacket n24 query -> 24 + case contramap (`asTypeOf` query) size of - ConstSize n -> n - VarSize f -> f query - OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of - ConstSize n -> n - VarSize f -> f answer - RelayData bs _ -> B.length bs - -instance Serialize RelayPacket where - - get = do - pktid <- getWord8 - case pktid of - 0 -> RoutingRequest <$> getPublicKey - 1 -> RoutingResponse <$> get <*> getPublicKey - 2 -> ConnectNotification <$> get - 3 -> DisconnectNotification <$> get - 4 -> RelayPing <$> get - 5 -> RelayPong <$> get - 6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes) - 7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes) - 8 -> OnionPacket <$> get <*> get - 9 -> OnionPacketResponse <$> get - conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes) - - put rp = do - putWord8 $ packetNumberToWord8 $ packetNumber rp - case rp of - RoutingRequest k -> putPublicKey k - RoutingResponse rpid k -> put rpid >> putPublicKey k - ConnectNotification conid -> put conid - DisconnectNotification conid -> put conid - RelayPing pingid -> put pingid - RelayPong pingid -> put pingid - OOBSend k bs -> putPublicKey k >> putByteString bs - OOBRecv k bs -> putPublicKey k >> putByteString bs - OnionPacket n24 query -> put n24 >> put query - OnionPacketResponse answer -> put answer - RelayData bs _ -> putByteString bs - --- | Initial client-to-server handshake message. -newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData)) - -deriving instance Show (f HelloData) => Show (Hello f) - -helloFrom :: Hello f -> PublicKey -helloFrom (Hello x) = senderKey x - -helloNonce :: Hello f -> Nonce24 -helloNonce (Hello x) = asymmNonce x - -helloData :: Hello f -> f HelloData -helloData (Hello x) = asymmData x - -instance Rank2.Functor Hello where - f <$> Hello (Asymm k n dta) = Hello $ Asymm k n (f dta) - -instance Payload Serialize Hello where - mapPayload _ f (Hello (Asymm k n dta)) = Hello $ Asymm k n (f dta) - -instance Rank2.Foldable Hello where - foldMap f (Hello (Asymm k n dta)) = f dta - -instance Rank2.Traversable Hello where - traverse f (Hello (Asymm k n dta)) = Hello . Asymm k n <$> f dta - -instance Sized (Hello Encrypted) where - size = ConstSize 56 <> contramap helloData size - -instance Serialize (Hello Encrypted) where - get = Hello <$> getAsymm - put (Hello asym) = putAsymm asym - -data HelloData = HelloData - { sessionPublicKey :: PublicKey - , sessionBaseNonce :: Nonce24 - } - deriving Show - -instance Sized HelloData where size = ConstSize 56 - -instance Serialize HelloData where - get = HelloData <$> getPublicKey <*> get - put (HelloData k n) = putPublicKey k >> put n - --- | Handshake server-to-client response packet. -data Welcome (f :: * -> *) = Welcome - { welcomeNonce :: Nonce24 - , welcomeData :: f HelloData - } - -deriving instance Show (f HelloData) => Show (Welcome f) - -instance Rank2.Functor Welcome where - f <$> Welcome n dta = Welcome n (f dta) - -instance Payload Serialize Welcome where - mapPayload _ f (Welcome n dta) = Welcome n (f dta) - -instance Rank2.Foldable Welcome where - foldMap f (Welcome _ dta) = f dta - -instance Rank2.Traversable Welcome where - traverse f (Welcome n dta) = Welcome n <$> f dta - -instance Sized (Welcome Encrypted) where - size = ConstSize 24 <> contramap welcomeData size - -instance Serialize (Welcome Encrypted) where - get = Welcome <$> get <*> get - put (Welcome n dta) = put n >> put dta - -data NodeInfo = NodeInfo - { udpNodeInfo :: UDP.NodeInfo - , tcpPort :: PortNumber - } - deriving (Eq,Ord) - -instance Read NodeInfo where - readsPrec _ = RP.readP_to_S $ do - udp <- RP.readS_to_P reads - port <- RP.between (RP.char '{') (RP.char '}') $ do - mapM_ RP.char ("tcp:" :: String) - w16 <- RP.readS_to_P reads - return $ fromIntegral (w16 :: Word16) - return $ NodeInfo udp port - -instance ToJSON NodeInfo where - toJSON (NodeInfo udp port) = case (toJSON udp) of - JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports" - (JSON.Array $ Vector.fromList - [JSON.Number (fromIntegral port)]) - tbl - x -> x -- Shouldn't happen. - -instance FromJSON NodeInfo where - parseJSON json = do - udp <- parseJSON json - port <- case json of - JSON.Object v -> do - portnum:_ <- v JSON..: "tcp_ports" - return (fromIntegral (portnum :: Word16)) - _ -> fail "TCP.NodeInfo: Expected JSON object." - return $ NodeInfo udp port - -instance Hashable NodeInfo where - hashWithSalt s n = hashWithSalt s (udpNodeInfo n) - 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 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} -module Data.Word64Map where - -import Data.Bits -import qualified Data.IntMap as IntMap - ;import Data.IntMap (IntMap) -import Data.Monoid -import Data.Typeable -import Data.Word - --- | Since 'Int' may be 32 or 64 bits, this function is provided as a --- convenience to test if an integral type, such as 'Data.Word.Word64', can be --- safely transformed into an 'Int' for use with 'IntMap'. --- --- Returns 'True' if the proxied type can be losslessly converted to 'Int' using --- 'fromIntegral'. -fitsInInt :: forall proxy word. (Bounded word, Integral word) => proxy word -> Bool -fitsInInt proxy = (original == casted) - where - original = div maxBound 2 :: word - casted = fromIntegral (fromIntegral original :: Int) :: word - -newtype Word64Map a = Word64Map (IntMap (IntMap a)) - -size :: Word64Map a -> Int -size (Word64Map m) = getSum $ foldMap (\n -> Sum (IntMap.size n)) m - -empty :: Word64Map a -empty = Word64Map IntMap.empty - --- Warning: This function assumes an 'Int' is either 64 or 32 bits. -keyFrom64 :: Word64 -> (# Int,Int #) -keyFrom64 w8 = - if fitsInInt (Proxy :: Proxy Word64) - then (# fromIntegral w8 , 0 #) - else (# fromIntegral (w8 `shiftR` 32), fromIntegral w8 #) -{-# INLINE keyFrom64 #-} - -lookup :: Word64 -> Word64Map b -> Maybe b -lookup w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 = do - m' <- IntMap.lookup hi m - IntMap.lookup lo m' -{-# INLINE lookup #-} - -insert :: Word64 -> b -> Word64Map b -> Word64Map b -insert w8 b (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 - = Word64Map $ IntMap.alter (Just . maybe (IntMap.singleton lo b) - (IntMap.insert lo b)) - hi - m -{-# INLINE insert #-} - -delete :: Word64 -> Word64Map b -> Word64Map b -delete w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 - = Word64Map $ IntMap.alter (maybe Nothing - (\m' -> case IntMap.delete lo m' of - m'' | IntMap.null m'' -> Nothing - m'' -> Just m'')) - hi - m -{-# INLINE delete #-} - - - 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 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -module Data.Wrapper.PSQ -#if 0 - ( module Data.Wrapper.PSQ , module Data.PSQueue ) where - -import Data.PSQueue hiding (foldr, foldl) -import qualified Data.PSQueue as PSQueue - -type PSQKey k = (Ord k) - --- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface. -fold' :: (Ord k, Ord p) => (k -> p -> () -> a -> a) -> a -> PSQ k p -> a -fold' f a q = PSQueue.foldr f' a q - where - f' (k :-> prio) x = f k prio () x - -#else - ( module Data.Wrapper.PSQ , module HashPSQ ) where - --- import Data.OrdPSQ as OrdPSQ hiding (insert, map, singleton, minView) --- import qualified Data.OrdPSQ as OrdPSQ - -import Data.Hashable -import qualified Data.HashPSQ as Q - ;import Data.HashPSQ as HashPSQ hiding (insert, map, minView, - singleton) -import Data.Time.Clock.POSIX (POSIXTime) - --- type PSQ' k p v = HashPSQ k p v -type PSQ' = HashPSQ -type PSQ k p = PSQ' k p () - -type Binding' k p v = (k,p,v) -type Binding k p = Binding' k p () - -type PSQKey k = (Hashable k, Ord k) - -pattern (:->) :: k -> p -> Binding k p -pattern k :-> p <- (k,p,_) where k :-> p = (k,p,()) - --- I tried defining (::->) :: (k,v) -> p -> Binding' k p v --- but no luck... -pattern Binding :: k -> v -> p -> Binding' k p v -pattern Binding k v p <- (k,p,v) where Binding k v p = (k,p,v) - -key :: (k,p,v) -> k -key (k,p,v) = k -{-# INLINE key #-} - -prio :: (k,p,v) -> p -prio (k,p,v) = p -{-# INLINE prio #-} - -insert :: (PSQKey k, Ord p) => k -> p -> PSQ k p -> PSQ k p -insert k p q = Q.insert k p () q -{-# INLINE insert #-} - -insert' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v -> PSQ' k p v -insert' k v p q = Q.insert k p v q -{-# INLINE insert' #-} - -insertWith :: (PSQKey k, Ord p) => (p -> p -> p) -> k -> p -> PSQ k p -> PSQ k p -insertWith f k p0 q = snd $ Q.alter f' k q - where - f' (Just (p,())) = ((),Just (f p0 p, ())) - f' Nothing = ((),Just (p0,())) -{-# INLINE insertWith #-} - -singleton :: (PSQKey k, Ord p) => k -> p -> PSQ k p -singleton k p = Q.singleton k p () -{-# INLINE singleton #-} - -singleton' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v -singleton' k v p = Q.singleton k p v -{-# INLINE singleton' #-} - - -minView :: (PSQKey k, Ord p) => PSQ' k p v -> Maybe (Binding' k p v, PSQ' k p v) -minView q = fmap (\(k,p,v,q') -> (Binding k v p, q')) $ Q.minView q -{-# INLINE minView #-} - - --- | Utility to convert a 'POSIXTime' delta into microseconds suitable for --- passing to 'threadDelay'. -toMicroseconds :: POSIXTime -> Int -toMicroseconds = round . (* 1000) . (* 1000) - - -#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 @@ -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -module Data.Wrapper.PSQInt -#if 0 - ( module Data.Wrapper.PSQInt , module Data.PSQueue ) where - -import Data.PSQueue hiding (foldr, foldl, PSQ) -import qualified Data.PSQueue as PSQueue - -type PSQ p = PSQueue.PSQ Int p - --- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface. -fold' :: (Ord p) => (Int -> p -> () -> a -> a) -> a -> PSQ p -> a -fold' f a q = PSQueue.foldr f' a q - where - f' (k :-> prio) x = f k prio () x - -#else - ( module Data.Wrapper.PSQInt - , module IntPSQ - , module Data.Wrapper.PSQ - ) where - -import Data.Wrapper.PSQ (Binding, pattern (:->), key, prio, toMicroseconds) - -import Data.IntPSQ as IntPSQ hiding (insert, map, singleton, minView) -import qualified Data.IntPSQ as Q - -type PSQ p = IntPSQ p () - -type PSQKey = () - -insert :: (Ord p) => Int -> p -> PSQ p -> PSQ p -insert k p q = Q.insert k p () q -{-# INLINE insert #-} - -insertWith :: (Ord p) => (p -> p -> p) -> Int -> p -> PSQ p -> PSQ p -insertWith f k p0 q = snd $ Q.alter f' k q - where - f' (Just (p,())) = ((),Just (f p0 p, ())) - f' Nothing = ((),Nothing) -{-# INLINE insertWith #-} - -singleton :: (Ord p) => Int -> p -> PSQ p -singleton k p = Q.singleton k p () -{-# INLINE singleton #-} - -minView :: (Ord p) => PSQ p -> Maybe (Binding Int p, PSQ p) -minView q = fmap (\(k,p,(),q') -> (k :-> p, q')) $ Q.minView q -{-# INLINE minView #-} - -#endif -- cgit v1.2.3