summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Control/Concurrent/Async/Lifted/Instrument.hs5
-rw-r--r--src/Control/Concurrent/Lifted/Instrument.hs98
-rw-r--r--src/Control/Concurrent/Tasks.hs44
-rw-r--r--src/Control/TriadCommittee.hs89
-rw-r--r--src/Crypto/Nonce.hs49
-rw-r--r--src/Crypto/Tox.hs709
-rw-r--r--src/Crypto/XEd25519.hs185
-rw-r--r--src/Crypto/XEd25519/FieldElement.hs49
-rw-r--r--src/DPut.hs75
-rw-r--r--src/Data/BEncode/Pretty.hs81
-rw-r--r--src/Data/Bits/ByteString.hs132
-rw-r--r--src/Data/Digest/CRC32C.hs100
-rw-r--r--src/Data/IntervalSet.hs129
-rw-r--r--src/Data/MinMaxPSQ.hs112
-rw-r--r--src/Data/PacketBuffer.hs148
-rw-r--r--src/Data/PacketQueue.hs217
-rw-r--r--src/Data/Sized.hs14
-rw-r--r--src/Data/TableMethods.hs105
-rw-r--r--src/Data/Torrent.hs1347
-rw-r--r--src/Data/Tox/Message.hs84
-rw-r--r--src/Data/Tox/Msg.hs311
-rw-r--r--src/Data/Tox/Onion.hs1029
-rw-r--r--src/Data/Tox/Relay.hs232
-rw-r--r--src/Data/Word64Map.hs66
-rw-r--r--src/Data/Wrapper/PSQ.hs91
-rw-r--r--src/Data/Wrapper/PSQInt.hs53
-rw-r--r--src/DebugTag.hs24
-rw-r--r--src/DebugUtil.hs41
-rw-r--r--src/Hans/Checksum.hs136
-rw-r--r--src/Network/Address.hs1253
-rw-r--r--src/Network/BitTorrent/DHT/ContactInfo.hs254
-rw-r--r--src/Network/BitTorrent/DHT/Readme.md13
-rw-r--r--src/Network/BitTorrent/DHT/Token.hs201
-rw-r--r--src/Network/BitTorrent/MainlineDHT.hs1169
-rw-r--r--src/Network/BitTorrent/MainlineDHT/Symbols.hs24
-rw-r--r--src/Network/Kademlia.hs163
-rw-r--r--src/Network/Kademlia/Bootstrap.hs437
-rw-r--r--src/Network/Kademlia/CommonAPI.hs84
-rw-r--r--src/Network/Kademlia/Persistence.hs51
-rw-r--r--src/Network/Kademlia/Routing.hs808
-rw-r--r--src/Network/Kademlia/Search.hs236
-rw-r--r--src/Network/Lossless.hs124
-rw-r--r--src/Network/QueryResponse.hs638
-rw-r--r--src/Network/QueryResponse/TCP.hs192
-rw-r--r--src/Network/SessionTransports.hs98
-rw-r--r--src/Network/SocketLike.hs124
-rw-r--r--src/Network/StreamServer.hs154
-rw-r--r--src/Network/Tox.hs456
-rw-r--r--src/Network/Tox/AggregateSession.hs374
-rw-r--r--src/Network/Tox/Avahi.hs65
-rw-r--r--src/Network/Tox/ContactInfo.hs172
-rw-r--r--src/Network/Tox/Crypto/Transport.hs1029
-rw-r--r--src/Network/Tox/DHT/Handlers.hs573
-rw-r--r--src/Network/Tox/DHT/Transport.hs460
-rw-r--r--src/Network/Tox/Handshake.hs125
-rw-r--r--src/Network/Tox/NodeId.hs731
-rw-r--r--src/Network/Tox/Onion/Handlers.hs369
-rw-r--r--src/Network/Tox/Onion/Transport.hs119
-rw-r--r--src/Network/Tox/Relay.hs235
-rw-r--r--src/Network/Tox/Session.hs243
-rw-r--r--src/Network/Tox/TCP.hs313
-rw-r--r--src/Network/Tox/Transport.hs86
-rw-r--r--src/Network/UPNP.hs40
-rw-r--r--src/StaticAssert.hs13
-rw-r--r--src/System/Global6.hs53
-rw-r--r--src/Text/XXD.hs48
66 files changed, 0 insertions, 17282 deletions
diff --git a/src/Control/Concurrent/Async/Lifted/Instrument.hs b/src/Control/Concurrent/Async/Lifted/Instrument.hs
deleted file mode 100644
index eab0fadc..00000000
--- a/src/Control/Concurrent/Async/Lifted/Instrument.hs
+++ /dev/null
@@ -1,5 +0,0 @@
1module Control.Concurrent.Async.Lifted.Instrument
2 ( module Control.Concurrent.Async.Lifted
3 ) where
4
5import Control.Concurrent.Async.Lifted
diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
deleted file mode 100644
index fc3b6369..00000000
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ /dev/null
@@ -1,98 +0,0 @@
1{-# LANGUAGE FlexibleContexts #-}
2module Control.Concurrent.Lifted.Instrument
3 ( module Control.Concurrent.Lifted
4 , forkIO
5 , forkOS
6 , fork
7 , labelThread
8 , threadsInformation
9 , PerThread(..)
10 ) where
11
12import qualified Control.Concurrent.Lifted as Raw
13import Control.Concurrent.Lifted hiding (fork,forkOS)
14import Control.Exception (fromException)
15import Control.Monad.Trans.Control
16import System.IO.Unsafe
17import qualified Data.Map.Strict as Map
18import Control.Exception.Lifted
19import Control.Monad.Base
20import qualified GHC.Conc as GHC
21import Data.Time()
22import Data.Time.Clock
23import DPut
24import DebugTag
25
26
27data PerThread = PerThread
28 { lbl :: String
29 , startTime :: UTCTime
30 }
31 deriving (Eq,Ord,Show)
32
33data GlobalState = GlobalState
34 { threads :: !(Map.Map ThreadId PerThread)
35 , reportException :: String -> IO ()
36 }
37
38globals :: MVar GlobalState
39globals = unsafePerformIO $ newMVar $ GlobalState
40 { threads = Map.empty
41 , reportException = dput XMisc
42 }
43{-# NOINLINE globals #-}
44
45
46forkIO :: IO () -> IO ThreadId
47forkIO = instrumented GHC.forkIO
48{-# INLINE forkIO #-}
49
50forkOS :: MonadBaseControl IO m => m () -> m ThreadId
51forkOS = instrumented Raw.forkOS
52{-# INLINE forkOS #-}
53
54fork :: MonadBaseControl IO m => m () -> m ThreadId
55fork = instrumented Raw.fork
56{-# INLINE fork #-}
57
58instrumented :: MonadBaseControl IO m =>
59 (m () -> m ThreadId) -> m () -> m ThreadId
60instrumented rawFork action = do
61 t <- rawFork $ do
62 tid <- myThreadId
63 tm <- liftBase getCurrentTime
64 bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm))
65 (return ())
66 $ do catch action $ \e -> case fromException e of
67 Just ThreadKilled -> return ()
68 Nothing -> liftBase $ do
69 g <- takeMVar globals
70 let l = concat [ show e
71 , " ("
72 , maybe "" lbl $ Map.lookup tid (threads g)
73 , ")"
74 ]
75 reportException g l
76 putMVar globals $! g { threads = Map.insert tid (PerThread l tm) $ threads g }
77 throwIO e
78 -- Remove the thread only if it terminated normally or was killed.
79 modifyThreads $! Map.delete tid
80 return t
81
82labelThread :: ThreadId -> String -> IO ()
83labelThread tid s = do
84 GHC.labelThread tid s
85 modifyThreads $! Map.adjust (\pt -> pt { lbl = s }) tid
86{-# INLINE labelThread #-}
87
88threadsInformation :: IO [(ThreadId,PerThread)]
89threadsInformation = do
90 m <- threads <$> readMVar globals
91 return $ Map.toList m
92
93
94modifyThreads :: MonadBase IO m => (Map.Map ThreadId PerThread -> Map.Map ThreadId PerThread) -> m ()
95modifyThreads f = do
96 g <- takeMVar globals
97 let f' st = st { threads = f (threads st) }
98 putMVar globals $! f' g
diff --git a/src/Control/Concurrent/Tasks.hs b/src/Control/Concurrent/Tasks.hs
deleted file mode 100644
index da2e589e..00000000
--- a/src/Control/Concurrent/Tasks.hs
+++ /dev/null
@@ -1,44 +0,0 @@
1{-# LANGUAGE CPP #-}
2module Control.Concurrent.Tasks where
3
4import Control.Concurrent.STM
5import Control.Exception
6import Data.Function
7import Data.List
8#ifdef THREAD_DEBUG
9import Control.Concurrent.Lifted.Instrument
10#else
11import Control.Concurrent.Lifted
12import GHC.Conc (labelThread)
13#endif
14
15newtype TaskGroup = TaskGroup
16 { taskQueue :: TChan (String,IO ())
17 }
18
19withTaskGroup :: String -> Int -> (TaskGroup -> IO ()) -> IO ()
20withTaskGroup glabel numslots action = do
21 tg <- atomically $ newTChan
22 cnt <- atomically $ newTVar 0
23 thread <- forkIO $ do
24 myThreadId >>= flip labelThread glabel
25 fix $ \again -> do
26 (slot, (lbl,task)) <- atomically $ do
27 slot <- readTVar cnt
28 check (slot < numslots)
29 writeTVar cnt (succ slot)
30 t <- readTChan tg
31 return (slot,t)
32 _ <- fork $ do
33 myThreadId >>= flip labelThread (intercalate "." [glabel,show slot,lbl])
34 task `catch` (\(SomeException e) -> return ())
35 atomically $ modifyTVar' cnt pred
36 again
37 action (TaskGroup tg) `onException` killThread thread
38 atomically $ do
39 isEmptyTChan tg >>= check
40 readTVar cnt >>= check . (== 0)
41 killThread thread
42
43forkTask :: TaskGroup -> String -> IO () -> IO ()
44forkTask (TaskGroup q) lbl action = atomically $ writeTChan q (lbl,action)
diff --git a/src/Control/TriadCommittee.hs b/src/Control/TriadCommittee.hs
deleted file mode 100644
index 88e665b6..00000000
--- a/src/Control/TriadCommittee.hs
+++ /dev/null
@@ -1,89 +0,0 @@
1{-# LANGUAGE TupleSections #-}
2module Control.TriadCommittee where
3
4import Control.Concurrent.STM
5import Control.Monad
6import Data.Maybe
7
8
9data TriadSlot = SlotA | SlotB | SlotC
10 deriving (Eq,Ord,Enum,Show,Read)
11
12data TriadCommittee voter a = TriadCommittee
13 { triadDecider :: TVar TriadSlot
14 , triadA :: TVar (Maybe (voter,a))
15 , triadB :: TVar (Maybe (voter,a))
16 , triadC :: TVar (Maybe (voter,a))
17 , triadNewDecision :: a -> STM ()
18 }
19
20triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a))
21triadSlot SlotA = triadA
22triadSlot SlotB = triadB
23triadSlot SlotC = triadC
24
25triadDecision :: a -> TriadCommittee voter a -> STM a
26triadDecision fallback triad = do
27 slot <- readTVar (triadDecider triad)
28 maybe fallback snd <$> readTVar (triadSlot slot triad)
29
30
31newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a)
32newTriadCommittee onChange =
33 TriadCommittee <$> newTVar SlotA
34 <*> newTVar Nothing
35 <*> newTVar Nothing
36 <*> newTVar Nothing
37 <*> pure onChange
38
39
40triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM ()
41triadCountVotes prior triad = do
42 a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad)
43 b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad)
44 c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad)
45 let (slot,vote) = case catMaybes [a,b,c] of
46 [ (x,xvote)
47 , (y,yvote)
48 , (z,zvote) ] -> if xvote == yvote then (x,Just xvote)
49 else (z,Just zvote)
50 [] -> (SlotA,Nothing)
51 ((slot,vote):_) -> (slot, Just vote)
52 writeTVar (triadDecider triad) slot
53 case vote of
54 Just v | vote /= prior -> triadNewDecision triad v
55 _ -> return ()
56
57
58addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM ()
59addVote triad voter vote = do
60 a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
61 b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
62 c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
63 let avail (_,Nothing) = True
64 avail (_,Just x ) = (x == voter)
65 slots = filter avail [a,b,c]
66 forM_ (take 1 slots) $ \(slot,_) -> do
67 prior <- do
68 slotp <- readTVar (triadDecider triad)
69 fmap snd <$> readTVar (triadSlot slotp triad)
70 writeTVar (triadSlot slot triad)
71 (Just (voter,vote))
72 triadCountVotes prior triad
73
74
75delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM ()
76delVote triad voter = do
77 a <- (SlotA,) . fmap fst <$> readTVar (triadA triad)
78 b <- (SlotB,) . fmap fst <$> readTVar (triadB triad)
79 c <- (SlotC,) . fmap fst <$> readTVar (triadC triad)
80 let match (_,Just x ) = (x == voter)
81 match _ = False
82 slots = filter match [a,b,c]
83 forM_ (take 1 slots) $ \(slot,_) -> do
84 prior <- do
85 slotp <- readTVar (triadDecider triad)
86 fmap snd <$> readTVar (triadSlot slotp triad)
87 writeTVar (triadSlot slot triad) Nothing
88 triadCountVotes prior triad
89
diff --git a/src/Crypto/Nonce.hs b/src/Crypto/Nonce.hs
deleted file mode 100644
index 263f9b0a..00000000
--- a/src/Crypto/Nonce.hs
+++ /dev/null
@@ -1,49 +0,0 @@
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3module Crypto.Nonce
4 ( Nonce32
5 , generateNonce32
6 , zeros32
7 ) where
8
9import Crypto.Random
10import Data.ByteArray as BA
11import Data.ByteString as B
12import qualified Data.ByteString.Base64 as Base64
13import Data.ByteString.Char8 as B8
14import Data.Data
15import Data.Serialize
16import Data.Sized
17
18newtype Nonce32 = Nonce32 ByteString
19 deriving (Eq, Ord, ByteArrayAccess, Data)
20
21bin2base64 :: ByteArrayAccess bs => bs -> String
22bin2base64 = B8.unpack . Base64.encode . BA.convert
23
24instance Show Nonce32 where
25 showsPrec d nonce = mappend $ bin2base64 nonce
26
27instance Read Nonce32 where
28 readsPrec _ str = either (const []) id $ do
29 let (ds,ss) = Prelude.splitAt 43 str
30 ss' <- case ss of
31 '=':xs -> Right xs -- optional terminating '='
32 _ -> Right ss
33 bs <- Base64.decode (B8.pack $ ds ++ ['='])
34 if B.length bs == 32
35 then Right [ (Nonce32 bs, ss') ]
36 else Left "Truncated Nonce32 (expected 43 base64 digits)."
37
38instance Serialize Nonce32 where
39 get = Nonce32 <$> getBytes 32
40 put (Nonce32 bs) = putByteString bs
41
42instance Sized Nonce32 where size = ConstSize 32
43
44
45zeros32 :: Nonce32
46zeros32 = Nonce32 $ BA.replicate 32 0
47
48generateNonce32 :: MonadRandom m => m Nonce32
49generateNonce32 = Nonce32 <$> getRandomBytes 32
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs
deleted file mode 100644
index 1b3d5e5c..00000000
--- a/src/Crypto/Tox.hs
+++ /dev/null
@@ -1,709 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE DeriveDataTypeable #-}
6{-# LANGUAGE DeriveFunctor #-}
7{-# LANGUAGE DeriveGeneric #-}
8{-# LANGUAGE DeriveTraversable #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE ConstraintKinds #-}
13{-# LANGUAGE Rank2Types #-}
14{-# LANGUAGE NamedFieldPuns #-}
15{-# LANGUAGE PatternSynonyms #-}
16{-# LANGUAGE FlexibleContexts #-}
17module Crypto.Tox
18 ( PublicKey
19 , publicKey
20 , getPublicKey
21 , putPublicKey
22 , SecretKey
23 , generateSecretKey
24 , toPublic
25 , SymmetricKey(..)
26 , TransportCrypto(..)
27 , newCrypto
28 , SecretsCache
29 , newSecretsCache
30 , Encrypted
31 , Encrypted8(..)
32 , type (∘), uncomposed, pattern Composed -- type (∘)(..)
33 , Asymm(..)
34 , getAsymm
35 , getAliasedAsymm
36 , putAsymm
37 , putAliasedAsymm
38 , Plain
39 , encodePlain
40 , decodePlain
41 -- , computeSharedSecret
42 , lookupSharedSecret
43 , lookupNonceFunction
44 , lookupNonceFunctionSTM
45 , Payload(..)
46 , encrypt
47 , decrypt
48 , decryptPayload
49 , encryptPayload
50 , Nonce8(..)
51 , Nonce24(..)
52 , incrementNonce24
53 , nonce24ToWord16
54 , addtoNonce24
55 , Nonce32(..)
56 , getRemainingEncrypted
57 , putEncrypted
58 , Auth
59 , Sized(..)
60 , Size(..)
61 , State(..)
62 , zeros32
63 , zeros24
64 , decryptSymmetric
65 , encryptSymmetric
66 , encodeSecret
67 , decodeSecret
68 , xorsum
69 ) where
70
71import Control.Arrow
72import Control.Monad
73import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
74import qualified Crypto.Cipher.Salsa as Salsa
75import qualified Crypto.Cipher.XSalsa as XSalsa
76import qualified Crypto.Error as Cryptonite
77import qualified Crypto.MAC.Poly1305 as Poly1305
78import Crypto.PubKey.Curve25519
79import Data.Bits
80import qualified Data.ByteArray as BA
81 ;import Data.ByteArray as BA (ByteArrayAccess, Bytes)
82import Data.ByteString as B
83import qualified Data.ByteString.Base16 as Base16
84import qualified Data.ByteString.Base64 as Base64
85import qualified Data.ByteString.Char8 as C8
86import Data.Data
87import Data.Functor.Contravariant
88#if MIN_VERSION_base(4,9,1)
89import Data.Kind
90#else
91import GHC.Exts (Constraint)
92#endif
93import Data.Ord
94import Data.Serialize as S
95import Data.Semigroup
96import Data.Word
97import Foreign.Marshal.Alloc
98import Foreign.Ptr
99import Foreign.Storable
100import System.Endian
101import Control.Concurrent.STM
102#ifdef CRYPTONITE_BACKPORT
103import Crypto.ECC.Class
104import Crypto.Error.Types (CryptoFailable (..), throwCryptoError)
105#else
106import Crypto.ECC
107import Crypto.Error
108#endif
109import Crypto.Random
110import Network.Socket (SockAddr)
111import GHC.Exts (Word(..),inline)
112import GHC.Generics (Generic)
113import GHC.Prim
114import Data.Word64Map (fitsInInt)
115import Data.MinMaxPSQ (MinMaxPSQ')
116import qualified Data.MinMaxPSQ as MM
117import Data.Time.Clock.POSIX
118import Data.Hashable
119import System.IO.Unsafe (unsafeDupablePerformIO)
120import Data.Functor.Compose
121import qualified Rank2
122import Data.Functor.Identity
123import DPut
124import DebugTag
125
126-- | A 16-byte mac and an arbitrary-length encrypted stream.
127newtype Encrypted a = Encrypted ByteString
128 deriving (Eq,Ord,Data,ByteArrayAccess,Hashable,Generic)
129
130newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
131 deriving (Serialize, Show)
132
133-- Simulating: newtype (f ∘ g) x = Composed { uncomposed :: f (g x) }
134pattern Composed x = Compose x
135uncomposed = getCompose
136type f ∘ g = f `Compose` g
137infixr 9 ∘
138
139newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
140instance Ord Auth where
141 compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
142instance Data Auth where
143 gfoldl k z x = z x
144 -- Well, this is a little wonky... XXX
145 gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
146 toConstr _ = con_Auth
147 dataTypeOf _ = mkDataType "Crypto.Tox" [con_Auth]
148con_Auth :: Constr
149con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
150instance Serialize Auth where
151 get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
152 put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs
153
154instance Typeable a => Show (Encrypted a) where
155 show (Encrypted _) = "Encrypted "++show (typeOf (undefined :: a))
156
157encryptedAuth :: Encrypted a -> Auth
158encryptedAuth (Encrypted bs)
159 | Right auth <- decode (B.take 16 bs) = auth
160 | otherwise = error "encryptedAuth: insufficient bytes"
161
162authAndBytes :: Encrypted a -> (Auth, ByteString)
163authAndBytes (Encrypted bs) = (auth,bs')
164 where
165 (as,bs') = B.splitAt 16 bs
166 Right auth = decode as
167
168-- | Info about a type's serialized length. Either the length is known
169-- independently of the value, or the length depends on the value.
170data Size a
171 = VarSize (a -> Int)
172 | ConstSize { constSize :: !Int }
173 deriving Typeable
174
175instance Contravariant Size where
176 contramap f sz = case sz of
177 ConstSize n -> ConstSize n
178 VarSize g -> VarSize (\x -> g (f x))
179
180instance Semigroup (Size a) where
181 ConstSize x <> ConstSize y = ConstSize (x + y)
182 VarSize f <> ConstSize y = VarSize $ \x -> f x + y
183 ConstSize x <> VarSize g = VarSize $ \y -> x + g y
184 VarSize f <> VarSize g = VarSize $ \x -> f x + g x
185
186instance Monoid (Size a) where
187 mappend = (<>)
188 mempty = ConstSize 0
189
190
191class Sized a where size :: Size a
192
193instance Sized a => Serialize (Encrypted a) where
194 get = case size :: Size a of
195 VarSize _ -> Encrypted <$> (remaining >>= getBytes)
196 ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac
197 put = putEncrypted
198
199instance Sized a => Sized (Encrypted a) where
200 size = case size :: Size a of
201 ConstSize n -> ConstSize $ n + 16
202 VarSize _ -> VarSize $ \(Encrypted bs) -> B.length bs
203
204instance (Sized a, Sized b) => Sized (a,b) where
205 size = case (size :: Size a, size :: Size b) of
206 (ConstSize a , ConstSize b) -> ConstSize $ a + b
207 (VarSize f , ConstSize b) -> VarSize $ \(a, _) -> f a + b
208 (ConstSize a , VarSize g) -> VarSize $ \(_, b) -> a + g b
209 (VarSize f , VarSize g) -> VarSize $ \(a, b) -> f a + g b
210
211getRemainingEncrypted :: Get (Encrypted a)
212getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes)
213
214putEncrypted :: Encrypted a -> Put
215putEncrypted (Encrypted bs) = putByteString bs
216
217newtype Plain (s:: * -> Constraint) a = Plain ByteString
218 deriving (Eq,Ord,Show,ByteArrayAccess)
219
220
221decodePlain :: Serialize a => Plain Serialize a -> Either String a
222decodePlain (Plain bs) = decode bs
223
224encodePlain :: Serialize a => a -> Plain Serialize a
225encodePlain a = Plain $ encode a
226
227storePlain :: Storable a => a -> IO (Plain Storable a)
228storePlain a = Plain <$> BA.create (sizeOf a) (`poke` a)
229
230retrievePlain :: Storable a => Plain Storable a -> IO a
231retrievePlain (Plain bs) = BA.withByteArray bs peek
232
233decryptSymmetric :: SymmetricKey -> Nonce24 -> Encrypted a -> Either String (Plain s a)
234decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do
235 let sym_nonce_bytes = B.take 12 n24
236 (mac, bs'') = B.splitAt 16 bs
237 symm <- left show . Cryptonite.eitherCryptoError $ do
238 sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
239 Symmetric.initialize symmkey sym_nonce
240 let (ds, symm') = Symmetric.decrypt bs'' symm
241 auth = Symmetric.finalize symm'
242 if BA.convert auth /= mac
243 then Left "Symmetric decryption failed. Incorrect key material?"
244 else return $ Plain ds
245
246encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x
247encryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Plain bs) = Encrypted es
248 where
249 Cryptonite.CryptoPassed es = do
250 sym_nonce <- Symmetric.nonce12 (BA.take 12 n24)
251 symm <- Symmetric.initialize symmkey sym_nonce
252 let (rpath_bs, symm') = Symmetric.encrypt bs symm
253 auth = Symmetric.finalize symm' -- 16 bytes
254 return (BA.convert auth `BA.append` rpath_bs)
255
256
257data State = State Poly1305.State XSalsa.State
258
259decrypt :: State -> Encrypted a -> Either String (Plain s a)
260decrypt (State hash crypt) ciphertext
261 | (a == mac) = Right (Plain m)
262 | otherwise = Left "Asymmetric decryption failed. Incorrect key material?"
263 where
264 (mac, c) = authAndBytes ciphertext
265 m = fst . XSalsa.combine crypt $ c
266 a = Auth . Poly1305.finalize . Poly1305.update hash $ c
267
268class Rank2.Functor g => Payload c g where
269 mapPayload :: proxy c -> (forall a. c a => p a -> q a) -> g p -> g q
270
271decryptPayload :: ( Rank2.Traversable g
272 , Payload Serialize g
273 ) => State -> g Encrypted -> Either String (g Identity)
274decryptPayload st g = do
275 plain <- Rank2.traverse (decrypt st) g
276 Rank2.sequence $ mapPayload (Proxy :: Proxy Serialize)
277 (Composed . fmap pure . decodePlain)
278 plain
279
280-- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the
281-- ciphertext, and prepend it to the ciphertext
282encrypt :: State -> Plain s a -> Encrypted a
283encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c
284 where
285 c = fst . XSalsa.combine crypt $ m
286 a = Auth . Poly1305.finalize . Poly1305.update hash $ c
287
288encryptPayload :: Payload Serialize g => State -> g Identity -> g Encrypted
289encryptPayload st g =
290 encrypt st
291 Rank2.<$> mapPayload (Proxy :: Proxy Serialize)
292 (encodePlain . runIdentity)
293 g
294
295-- (Poly1305.State, XSalsa.State)
296computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State
297computeSharedSecret sk recipient = k `seq` \nonce ->
298 let -- cipher state
299 st0 = XSalsa.initialize 20 k nonce
300 -- Poly1305 key
301 (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
302 -- Since rs is 32 bytes, this pattern should never fail...
303 Cryptonite.CryptoPassed hash = Poly1305.initialize rs
304 in State hash crypt
305 where
306 -- diffie helman
307#if MIN_VERSION_cryptonite(0,24,0)
308 -- TODO: Handle failure.
309 -- Failure was observed...
310 -- Reproduce by issuing tox command "ping 192.168.10.1:33446" without specifying
311 -- the public key portion of the node id.
312 -- "Irrefutable pattern failed for pattern CryptoPassed shared"
313 Cryptonite.CryptoPassed shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
314#else
315 shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
316#endif
317 -- shared secret XSalsa key
318 k = hsalsa20 shared zeros24
319
320unsafeFirstWord64 :: ByteArrayAccess ba => ba -> Word64
321unsafeFirstWord64 ba = unsafeDupablePerformIO $ BA.withByteArray ba peek
322{-# INLINE unsafeFirstWord64 #-}
323
324instance Hashable PublicKey where
325 hashWithSalt salt pk = hashWithSalt salt (unsafeFirstWord64 pk)
326 {-# INLINE hashWithSalt #-}
327
328instance Hashable SecretKey where
329 hashWithSalt salt sk = hashWithSalt salt (unsafeFirstWord64 sk)
330 {-# INLINE hashWithSalt #-}
331
332instance Ord PublicKey where compare = unsafeCompare32Bytes
333 {-# INLINE compare #-}
334instance Ord SecretKey where compare = unsafeCompare32Bytes
335 {-# INLINE compare #-}
336
337unsafeCompare32Bytes :: (ByteArrayAccess ba, ByteArrayAccess bb)
338 => ba -> bb -> Ordering
339unsafeCompare32Bytes ba bb =
340 unsafeDupablePerformIO $ BA.withByteArray ba
341 $ \pa -> BA.withByteArray bb
342 $ \pb -> unsafeCompare32Bytes' 3 pa pb
343
344unsafeCompare32Bytes' :: Int -> Ptr Word64 -> Ptr Word64 -> IO Ordering
345unsafeCompare32Bytes' !n !pa !pb = do
346 a <- peek pa
347 b <- peek pb
348 if n == 0
349 then return $! inline compare a b
350 else case inline compare a b of
351 EQ -> unsafeCompare32Bytes' (n - 1)
352 (pa `plusPtr` 8)
353 (pb `plusPtr` 8)
354 neq -> return neq
355
356
357
358lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State
359lookupSharedSecret crypto sk recipient nonce
360 = ($ nonce) <$> lookupNonceFunction crypto sk recipient
361
362{-# INLINE lookupNonceFunction #-}
363lookupNonceFunction :: TransportCrypto -> SecretKey -> PublicKey -> IO (Nonce24 -> State)
364lookupNonceFunction c@(TransportCrypto{secretsCache}) sk recipient = do
365 now <- getPOSIXTime
366 atomically $ lookupNonceFunctionSTM now c sk recipient
367
368{-# INLINE lookupNonceFunctionSTM #-}
369-- | This version of 'lookupNonceFunction' is STM instead of IO, this means if some later part of
370-- of the transaction fails, we may end up forgoing a computation that could have been cached.
371-- Use with care. In most circumstances you probably want 'lookupNonceFunction'. It also commits
372-- us to using TVars to store the cache.
373lookupNonceFunctionSTM :: POSIXTime -> TransportCrypto -> SecretKey -> PublicKey -> STM (Nonce24 -> State)
374lookupNonceFunctionSTM now TransportCrypto{secretsCache} sk recipient = do
375 mm <- readTVar $ sharedSecret secretsCache
376 case MM.lookup' recipient mm of
377 Nothing -> do
378 let miss = computeSharedSecret sk recipient
379 writeTVar (sharedSecret secretsCache)
380 (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm)
381 return miss
382 Just (stamp,smm) -> do
383 let (r,v) = case MM.lookup' sk smm of
384 Nothing | let miss = computeSharedSecret sk recipient
385 -> (miss, MM.insertTake' 3 sk miss (Down now) smm)
386 Just (stamp2,hit) -> (hit , MM.insert' sk hit (Down now) smm)
387 writeTVar (sharedSecret secretsCache)
388 (MM.insertTake' 160 recipient v (Down now) mm)
389 return r
390
391
392hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
393hsalsa20 k n = BA.append a b
394 where
395 Salsa.State st = XSalsa.initialize 20 k n
396 (_, as) = BA.splitAt 4 st
397 (a, xs) = BA.splitAt 16 as
398 (_, bs) = BA.splitAt 24 xs
399 (b, _ ) = BA.splitAt 16 bs
400
401
402newtype Nonce24 = Nonce24 ByteString
403 deriving (Eq, Ord, ByteArrayAccess, Data, Generic, Hashable)
404
405nonce24ToWord16 :: Nonce24 -> Word16
406nonce24ToWord16 (Nonce24 n24) = fromIntegral (B.index n24 23) + 256 * fromIntegral (B.index n24 22)
407
408addtoNonce24 :: Nonce24 -> Word -> Nonce24
409addtoNonce24 (Nonce24 n24) n = unsafeDupablePerformIO $ Nonce24 <$> BA.copy n24 init
410 where
411 init :: Ptr Word -> IO ()
412 init ptr | fitsInInt (Proxy :: Proxy Word64) = do
413 let frmBE64 = fromIntegral . fromBE64 . fromIntegral
414 tBE64 = fromIntegral . toBE64 . fromIntegral
415 !(W# input) = n
416 W# w1 <- frmBE64 <$> peek ptr
417 W# w2 <- frmBE64 <$> peekElemOff ptr 1
418 W# w3 <- frmBE64 <$> peekElemOff ptr 2
419 let (# overflw, sum #) = plusWord2# w3 input
420 (# overflw', sum' #) = plusWord2# w2 overflw
421 (# discard, sum'' #) = plusWord2# w1 overflw'
422 poke ptr $ tBE64 (W# sum'')
423 pokeElemOff ptr 1 $ tBE64 (W# sum')
424 pokeElemOff ptr 2 $ tBE64 (W# sum)
425
426 init ptr | fitsInInt (Proxy :: Proxy Word32) = do
427 let frmBE32 = fromIntegral . fromBE32 . fromIntegral
428 tBE32 = fromIntegral . toBE32 . fromIntegral
429 !(W# input) = n
430 W# w1 <- frmBE32 <$> peek ptr
431 W# w2 <- frmBE32 <$> peekElemOff ptr 1
432 W# w3 <- frmBE32 <$> peekElemOff ptr 2
433 W# w4 <- frmBE32 <$> peekElemOff ptr 3
434 W# w5 <- frmBE32 <$> peekElemOff ptr 4
435 W# w6 <- frmBE32 <$> peekElemOff ptr 5
436 let (# overflw_, sum_ #) = plusWord2# w6 input
437 (# overflw__, sum__ #) = plusWord2# w5 overflw_
438 (# overflw___, sum___ #) = plusWord2# w6 overflw__
439 (# overflw, sum #) = plusWord2# w3 overflw___
440 (# overflw', sum' #) = plusWord2# w2 overflw
441 (# discard, sum'' #) = plusWord2# w1 overflw'
442 poke ptr $ tBE32 (W# sum'')
443 pokeElemOff ptr 1 $ tBE32 (W# sum')
444 pokeElemOff ptr 2 $ tBE32 (W# sum)
445 pokeElemOff ptr 3 $ tBE32 (W# sum___)
446 pokeElemOff ptr 4 $ tBE32 (W# sum__)
447 pokeElemOff ptr 5 $ tBE32 (W# sum_)
448 init _ = error "incrementNonce24: I only support 64 and 32 bits"
449
450incrementNonce24 :: Nonce24 -> Nonce24
451incrementNonce24 nonce24 = addtoNonce24 nonce24 1
452{-# INLINE incrementNonce24 #-}
453
454quoted :: ShowS -> ShowS
455quoted shows s = '"':shows ('"':s)
456
457bin2hex :: ByteArrayAccess bs => bs -> String
458bin2hex = C8.unpack . Base16.encode . BA.convert
459
460bin2base64 :: ByteArrayAccess bs => bs -> String
461bin2base64 = C8.unpack . Base64.encode . BA.convert
462
463
464instance Show Nonce24 where
465 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
466
467instance Sized Nonce24 where size = ConstSize 24
468
469instance Serialize Nonce24 where
470 get = Nonce24 <$> getBytes 24
471 put (Nonce24 bs) = putByteString bs
472
473newtype Nonce8 = Nonce8 Word64
474 deriving (Eq, Ord, Data, Serialize)
475
476-- Note: Big-endian to match Serialize instance.
477instance Storable Nonce8 where
478 sizeOf _ = 8
479 alignment _ = alignment (undefined::Word64)
480 peek ptr = Nonce8 . fromBE64 <$> peek (castPtr ptr)
481 poke ptr (Nonce8 w) = poke (castPtr ptr) (toBE64 w)
482
483instance Sized Nonce8 where size = ConstSize 8
484
485instance ByteArrayAccess Nonce8 where
486 length _ = 8
487 withByteArray (Nonce8 w64) kont =
488 allocaBytes 8 $ \p -> do
489 poke (castPtr p :: Ptr Word64) $ toBE64 w64
490 kont p
491
492instance Show Nonce8 where
493 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
494
495
496newtype Nonce32 = Nonce32 ByteString
497 deriving (Eq, Ord, ByteArrayAccess, Data)
498
499instance Show Nonce32 where
500 showsPrec d nonce = mappend $ bin2base64 nonce
501
502instance Read Nonce32 where
503 readsPrec _ str = either (const []) id $ do
504 let (ds,ss) = Prelude.splitAt 43 str
505 ss' <- case ss of
506 '=':xs -> Right xs -- optional terminating '='
507 _ -> Right ss
508 bs <- Base64.decode (C8.pack $ ds ++ ['='])
509 if B.length bs == 32
510 then Right [ (Nonce32 bs, ss') ]
511 else Left "Insuffiicent base64 digits while parsing Nonce32."
512
513instance Serialize Nonce32 where
514 get = Nonce32 <$> getBytes 32
515 put (Nonce32 bs) = putByteString bs
516
517instance Sized Nonce32 where size = ConstSize 32
518
519
520zeros32 :: Nonce32
521zeros32 = Nonce32 $ BA.replicate 32 0
522
523zeros24 :: ByteString
524zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
525
526-- | `32` | sender's DHT public key |
527-- | `24` | nonce |
528-- | `?` | encrypted message |
529data Asymm a = Asymm
530 { senderKey :: PublicKey
531 , asymmNonce :: Nonce24
532 , asymmData :: a
533 }
534 deriving (Functor,Foldable,Traversable, Show, Eq, Ord)
535
536instance Sized a => Sized (Asymm a) where
537 size = case size of
538 ConstSize a -> ConstSize $ a + 24 + 32
539 VarSize f -> VarSize $ \Asymm { asymmData = x } -> f x + 24 + 32
540
541-- | Field order: senderKey, then nonce This is the format used by
542-- Ping/Pong/GetNodes/SendNodes.
543--
544-- See 'getAliasedAsymm' if the nonce precedes the key.
545getAsymm :: Serialize a => Get (Asymm a)
546getAsymm = Asymm <$> getPublicKey <*> get <*> get
547
548putAsymm :: Serialize a => Asymm a -> Put
549putAsymm (Asymm key nonce dta) = putPublicKey key >> put nonce >> put dta
550
551-- | Field order: nonce, and then senderKey.
552getAliasedAsymm :: Serialize a => Get (Asymm a)
553getAliasedAsymm = flip Asymm <$> get <*> getPublicKey <*> get
554
555putAliasedAsymm :: Serialize a => Asymm a -> Put
556putAliasedAsymm (Asymm key nonce dta) = put nonce >> putPublicKey key >> put dta
557
558data SecretsCache = SecretsCache
559 { sharedSecret :: TVar (MinMaxPSQ' PublicKey
560 (Down POSIXTime)
561 (MinMaxPSQ' SecretKey (Down POSIXTime) (Nonce24 -> State)))
562 }
563
564newSecretsCache :: IO SecretsCache
565newSecretsCache = atomically (SecretsCache <$> newTVar MM.empty)
566
567
568newtype SymmetricKey = SymmetricKey ByteString
569
570instance Show SymmetricKey where
571 show (SymmetricKey bs) = bin2base64 bs
572
573data TransportCrypto = TransportCrypto
574 { transportSecret :: SecretKey
575 , transportPublic :: PublicKey
576 , onionAliasSecret :: SecretKey
577 , onionAliasPublic :: PublicKey
578 , rendezvousSecret :: SecretKey
579 , rendezvousPublic :: PublicKey
580 , transportSymmetric :: STM SymmetricKey
581 , transportNewNonce :: STM Nonce24
582 , transportNewKey :: STM SecretKey
583 , userKeys :: STM [(SecretKey,PublicKey)]
584 , pendingCookies :: TVar [(SockAddr, (Int, PublicKey))]
585 , secretsCache :: SecretsCache
586 }
587
588getPublicKey :: S.Get PublicKey
589getPublicKey = eitherCryptoError . publicKey <$> S.getBytes 32
590 >>= either (fail . show) return
591
592putPublicKey :: PublicKey -> S.Put
593putPublicKey bs = S.putByteString $ BA.convert bs
594
595-- 32 bytes -> 42 base64 digits.
596--
597encodeSecret :: SecretKey -> Maybe C8.ByteString
598encodeSecret k = do
599 (a,bs) <- BA.uncons (BA.convert k)
600 -- Bytes
601 -- 1 31
602 -- a | bs
603 (cs,c) <- unsnoc bs
604 -- Bytes
605 -- 1 30 1
606 -- a | cs | c
607 --
608 -- Based on the following pasted from the generateSecretKey function:
609 --
610 -- tweakToSecretKey :: ScrubbedBytes -> SecretKey
611 -- tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do
612 -- modifyByte inp 0 (\e0 -> e0 .&. 0xf8)
613 -- modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40)
614 --
615 -- We know the following holds:
616 -- a == a .&. 0xf8
617 -- c == (c .&. 0x7f) .|. 0x40
618 --
619 -- Therefore, there are 5 reserved bits:
620 -- a := aaaa a000
621 -- c := 01dd cccc
622 --
623 -- That gives us 256 - 5 = 251 bits to encode.
624 -- 42 * 6 = 252
625 --
626 let -- We'll reserve the first bit as zero so that the encoded
627 -- key starts with a digit between A and f. Other digits will be
628 -- arbitrary.
629 --
630 -- The middle 30 bytes will be encoded as is from the source byte
631 -- string (cs). It remains to compute the first (a') and last (c')
632 -- bytes.
633 xs = Base64.encode $ a' `BA.cons` cs `BA.snoc` c'
634 -- a' := 0aaaaadd
635 a' = shiftR a 1 .|. (shiftR c 4 .&. 0x03)
636 -- c' := cccc0000
637 c' = shiftL c 4
638 return $ BA.take 42 xs
639
640-- 42 base64 digits. First digit should be between A and f. The rest are
641-- arbitrary.
642decodeSecret :: C8.ByteString -> Maybe SecretKey
643decodeSecret k64 | B.length k64 < 42 = Nothing
644decodeSecret k64 = do
645 xs <- either (const Nothing) Just $ Base64.decode $ B.append k64 "A="
646 (a',ds) <- B.uncons $ B.take 32 xs
647 (cs,c') <- B.unsnoc ds
648 let c = 0x40 .|. shiftR c' 4 .|. ( 0x30 .&. shiftL a' 4)
649 a = 0xf8 .&. shiftL a' 1
650 case secretKey $ B.cons a cs `B.snoc` c of
651 CryptoPassed x -> Just x
652 _ -> Nothing
653
654-- Treats byte pairs as big-endian.
655xorsum :: ByteArrayAccess ba => ba -> Word16
656xorsum bs = unsafeDupablePerformIO $ BA.withByteArray bs $ \ptr16 -> do
657 let (wcnt,r) = BA.length bs `divMod` 2
658 loop cnt !ac = do
659 ac' <- xor ac <$> peekElemOff ptr16 cnt
660 case cnt of 0 -> return $ fromBE16 ac'
661 _ -> loop (cnt - 1) ac'
662 loop (wcnt - 1) $ case r of
663 0 -> 0
664 _ -> 256 * fromIntegral (BA.index bs (BA.length bs - 1))
665
666showHex :: BA.ByteArrayAccess ba => ba -> String
667showHex bs = C8.unpack $ Base16.encode $ BA.convert bs
668
669newCrypto :: IO TransportCrypto
670newCrypto = do
671 secret <- generateSecretKey
672 alias <- generateSecretKey
673 ralias <- generateSecretKey
674 let pubkey = toPublic secret
675 aliaspub = toPublic alias
676 raliaspub = toPublic ralias
677 ukeys <- atomically $ newTVar []
678 (symkey, drg) <- do
679 drg0 <- getSystemDRG
680 return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG)
681 noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew
682 cookieKeys <- atomically $ newTVar []
683 cache <- newSecretsCache
684 dput XNetCrypto $ "secret(tox) = " ++ showHex secret
685 dput XNetCrypto $ "public(tox) = " ++ showHex pubkey
686 dput XNetCrypto $ "symmetric(tox) = " ++ showHex symkey
687 return TransportCrypto
688 { transportSecret = secret
689 , transportPublic = pubkey
690 , onionAliasSecret = alias
691 , onionAliasPublic = aliaspub
692 , rendezvousSecret = ralias
693 , rendezvousPublic = raliaspub
694 , transportSymmetric = return $ SymmetricKey symkey
695 , transportNewNonce = do
696 drg1 <- readTVar noncevar
697 let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24)
698 writeTVar noncevar drg2
699 return nonce
700 , transportNewKey = do
701 drg1 <- readTVar noncevar
702 let (k, drg2) = withDRG drg1 generateSecretKey
703 writeTVar noncevar drg2
704 return k
705 , userKeys = return []
706 , pendingCookies = cookieKeys
707 , secretsCache = cache
708 }
709
diff --git a/src/Crypto/XEd25519.hs b/src/Crypto/XEd25519.hs
deleted file mode 100644
index 372f31a8..00000000
--- a/src/Crypto/XEd25519.hs
+++ /dev/null
@@ -1,185 +0,0 @@
1module Crypto.XEd25519 where
2
3import Control.Arrow
4import Data.Bits
5import Data.ByteArray as BA
6import Data.Memory.PtrMethods (memCopy)
7import Crypto.Hash
8import Crypto.ECC.Edwards25519
9import Crypto.Error
10import qualified Crypto.PubKey.Ed25519 as Ed25519
11import Foreign.Marshal
12import Foreign.Ptr
13import Foreign.Storable
14import qualified Crypto.PubKey.Curve25519 as X25519
15
16import Crypto.XEd25519.FieldElement
17import Crypto.Nonce
18
19
20data SecretKey = SecretKey { secretScalar :: Scalar }
21
22data PublicKey = PublicKey Ed25519.PublicKey
23 deriving Eq
24
25type Nonce = Nonce32
26
27newtype EncodedPoint = EncodedPoint Point
28
29instance ByteArrayAccess SecretKey where
30 length _ = 32
31 withByteArray (SecretKey scalar) = withByteArray (scalarEncode scalar :: Bytes)
32
33instance ByteArrayAccess PublicKey where
34 length _ = 32
35 withByteArray (PublicKey edpub) = withByteArray edpub
36
37instance ByteArrayAccess EncodedPoint where
38 length _ = 32
39 withByteArray (EncodedPoint pt) f =
40 withByteArray (pointEncode pt :: Bytes) f
41
42
43data Signature = Signature EncodedPoint Scalar
44
45instance ByteArrayAccess Signature where
46 length _ = 64
47 withByteArray (Signature pt scalar) f =
48 withByteArray pt $ \ptptr -> do
49 withByteArray (SecretKey scalar) $ \scalarptr -> do
50 allocaBytes 64 $ \ptr -> do
51 memCopy ptr ptptr 32
52 memCopy (ptr `plusPtr` 32) scalarptr 32
53 f (castPtr ptr)
54
55
56padding :: Bytes
57padding = 0xFE `BA.cons` BA.replicate 31 0xFF
58
59sign :: ByteArrayAccess dta => dta -> Nonce -> SecretKey -> PublicKey -> Signature
60sign dta nonce sec pub = Signature rB s
61 where
62 rB = ge_p3_tobytes $ ge_scalarmult_base r
63
64 r = sc_reduce $ hashFinalize $ (`hashUpdate` padding)
65 >>> (`hashUpdate` sec)
66 >>> (`hashUpdate` dta)
67 >>> (`hashUpdate` nonce) $ hashInit
68
69 h = sc_reduce $ hashFinalize $ (`hashUpdate` rB)
70 >>> (`hashUpdate` pub)
71 >>> (`hashUpdate` dta) $ hashInit
72
73 -- s = r + ha (mod q)
74 s = sc_muladd h (secretScalar sec) r
75
76
77
78ge_p3_tobytes :: Point -> EncodedPoint
79ge_p3_tobytes = EncodedPoint
80
81ge_scalarmult_base :: Scalar -> Point
82ge_scalarmult_base = toPoint
83
84sc_muladd :: Scalar -> Scalar -> Scalar -> Scalar
85sc_muladd a b c = scalarAdd (scalarMul a b) c
86
87sc_reduce :: Digest SHA512 -> Scalar
88sc_reduce digest = x where CryptoPassed x = scalarDecodeLong digest -- ???
89
90-- Scalar is internally, at least on 64bit machines, represented as 5
91-- 56-bit words in little-endian order, each encoded as a Word64.
92sc_neg :: Scalar -> Scalar
93sc_neg = scalarMul sc_neg1
94
95verify :: ByteArrayAccess dta => PublicKey -> dta -> Signature -> Bool
96verify pub dta signature = Ed25519.verify ed_pub dta ed_sig
97 where
98 CryptoPassed ed_pub = Ed25519.publicKey pub'
99 CryptoPassed ed_sig = Ed25519.signature signature'
100
101 -- Get the sign bit from the s part of the signature.
102 sign_bit = BA.index signature 63 .&. 0x80
103
104 -- Set the sign bit to zero in the s part of the signature.
105 signature' :: Bytes
106 signature' = BA.copyAndFreeze signature $ \ptr -> do
107 let at63 = plusPtr ptr 63
108 byte63 <- peek at63
109 poke at63 $ byte63 .&. (0x7F `asTypeOf` sign_bit)
110
111 -- Restore the sign bit on the verification key, which should have 0 as its
112 -- current sign bit.
113 pub' :: Bytes
114 pub' = BA.copyAndFreeze pub $ \ptr -> do
115 let at31 = plusPtr ptr 31
116 byte31 <- peek at31
117 poke at31 $ (byte31 .&. 0x7F) .|. sign_bit
118
119
120-- typedef crypto_int32 fe[10];
121--
122-- fe means field element. Here the field is \Z/(2^255-19).
123-- An element t, entries t[0]...t[9], represents the integer
124-- t[0]+2^26 t[1]+2^51 t[2]+2^77 t[3]+2^102 t[4]+...+2^230 t[9].
125-- Bounds on each t[i] vary depending on context.
126
127-- mont_pub_to_ed_pub
128toSigningKey :: X25519.PublicKey -> PublicKey
129toSigningKey mont_pub0 = PublicKey ed_pub
130 where
131 -- Read the public key as a field element
132 mont_pub = fe_frombytes mont_pub0
133
134 -- Convert the Montgomery public key to a twisted Edwards public key
135 fe_ONE = fe_1
136
137 -- Calculate the parameters (u - 1) and (u + 1)
138 mont_pub_minus_one = fe_sub mont_pub fe_ONE
139 mont_pub_plus_one0 = fe_add mont_pub fe_ONE
140
141 -- Prepare inv(u + 1)
142 mont_pub_plus_one = fe_invert mont_pub_plus_one0
143
144 -- Calculate y = (u - 1) * inv(u + 1) (mod p)
145 ed_pub0 = fe_mul mont_pub_minus_one mont_pub_plus_one
146 ed_pub = fe_tobytes ed_pub0
147
148-- mont_priv_to_ed_pair
149toSigningKeyPair :: X25519.SecretKey -> (SecretKey,PublicKey)
150toSigningKeyPair mont_priv0 = (SecretKey ed_priv, PublicKey ed_pub)
151 where
152 -- Prepare a buffer for the twisted Edwards private key
153 ed_priv1 = (throwCryptoError . scalarDecodeLong :: X25519.SecretKey -> Scalar) mont_priv0
154
155 -- Get the twisted edwards public key, including the sign bit
156 ed_pub0 = ge_p3_tobytes $ ge_scalarmult_base ed_priv1
157
158 -- Save the sign bit for later
159 sign_bit = (BA.index ed_pub0 31 `shiftR` 7) .&. 1
160
161 -- Force the sign bit to zero
162 pub' :: Bytes
163 pub' = BA.copyAndFreeze ed_pub0 $ \ptr -> do
164 let at31 = plusPtr ptr 31
165 byte31 <- peek at31
166 poke at31 $ (byte31 .&. 0x7F) `asTypeOf` sign_bit
167
168 CryptoPassed ed_pub = Ed25519.publicKey pub'
169
170
171 -- Prepare the negated private key
172 ed_priv_neg = sc_neg ed_priv1
173
174 -- Get the correct private key based on the sign stored above
175 ed_priv = if sign_bit/=0 then ed_priv_neg
176 else ed_priv1
177
178-- sc_zero = throwCryptoError $ scalarDecodeLong (b::Bytes)
179-- where
180-- b = BA.pack $ encodeLittleEndian $ 2^252 + 27742317777372353535851937790883648493
181
182sc_neg1 :: Scalar
183sc_neg1 = throwCryptoError $ scalarDecodeLong (b::Bytes)
184 where
185 b = BA.pack $ encodeLittleEndian $ 2^252 + 27742317777372353535851937790883648492
diff --git a/src/Crypto/XEd25519/FieldElement.hs b/src/Crypto/XEd25519/FieldElement.hs
deleted file mode 100644
index 7a916107..00000000
--- a/src/Crypto/XEd25519/FieldElement.hs
+++ /dev/null
@@ -1,49 +0,0 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE TypeOperators #-}
3module Crypto.XEd25519.FieldElement where
4
5import Crypto.Error
6import qualified Crypto.PubKey.Curve25519 as X25519
7import qualified Crypto.PubKey.Ed25519 as Ed25519
8import Data.ByteArray as BA (pack,unpack,Bytes)
9import Data.Modular
10import Data.Word
11
12-- 2^255 - 19
13type P25519 = 57896044618658097711785492504343953926634992332820282019728792003956564819949
14
15newtype FieldElement = FE (ℤ / P25519)
16
17
18fe_frombytes :: X25519.PublicKey -> FieldElement
19fe_frombytes pub = FE $ toMod $ decodeLittleEndian $ BA.unpack pub
20
21fe_tobytes :: FieldElement -> Ed25519.PublicKey
22fe_tobytes (FE x) = throwCryptoError $ Ed25519.publicKey (b :: Bytes)
23 where
24 b = BA.pack $ take 32 $ (encodeLittleEndian $ unMod x) ++ repeat 0
25
26fe_1 :: FieldElement
27fe_1 = FE $ toMod 1
28
29fe_sub :: FieldElement -> FieldElement -> FieldElement
30fe_sub (FE x) (FE y) = FE $ x - y
31
32fe_add :: FieldElement -> FieldElement -> FieldElement
33fe_add (FE x) (FE y) = FE $ x + y
34
35fe_invert :: FieldElement -> FieldElement
36fe_invert (FE x) = FE $ inv x
37
38fe_mul :: FieldElement -> FieldElement -> FieldElement
39fe_mul (FE x) (FE y) = FE (x * y)
40
41decodeLittleEndian :: [Word8] -> Integer
42decodeLittleEndian [] = 0
43decodeLittleEndian (x:xs) = fromIntegral x + 256 * decodeLittleEndian xs
44
45encodeLittleEndian :: Integer -> [Word8]
46encodeLittleEndian 0 = []
47encodeLittleEndian x = let (bs,b) = divMod x 256
48 in fromIntegral b : encodeLittleEndian bs
49
diff --git a/src/DPut.hs b/src/DPut.hs
deleted file mode 100644
index 38e532d0..00000000
--- a/src/DPut.hs
+++ /dev/null
@@ -1,75 +0,0 @@
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3module DPut where
4
5import Control.Monad.IO.Class
6import qualified Data.Map.Strict as Map
7import Data.Maybe
8import Data.IORef
9import System.IO.Unsafe (unsafePerformIO)
10import System.Log.Logger
11import qualified Data.ByteString.Char8 as B
12import qualified Data.Text as T
13import qualified Data.Text.Encoding as T
14import Debug.Trace
15import Data.Typeable
16import Data.Dynamic
17
18type IsDebugTag t = (Eq t, Ord t, Show t, Read t, Enum t, Bounded t,Typeable t)
19
20appName :: String
21appName = "toxmpp"
22
23(<.>) :: String -> String -> String
24a <.> b = a ++ "." ++ b
25
26dput :: (MonadIO m, IsDebugTag tag) => tag -> String -> m ()
27dput tag msg = liftIO $ debugM (appName <.> show tag) msg
28
29dputB :: (MonadIO m, IsDebugTag tag) => tag -> B.ByteString -> m ()
30dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
31
32{-# NOINLINE verbosityMap #-}
33verbosityMap :: IORef (Map.Map TypeRep Dynamic)
34verbosityMap = unsafePerformIO $ newIORef (Map.empty)
35
36-- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO.
37tput :: (Applicative m, IsDebugTag tag) => tag -> String -> m ()
38tput tag msg =
39 let mp = unsafePerformIO $ readIORef verbosityMap
40 in if maybe True (fromMaybe True . Map.lookup tag . flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp)
41 then trace msg (pure ())
42 else pure ()
43
44-- | like 'trace' but parameterized with 'DebugTag'
45dtrace :: forall a tag. IsDebugTag tag => tag -> String -> a -> a
46dtrace tag msg result = let mp = unsafePerformIO $ readIORef verbosityMap
47 mp' :: Map.Map tag Bool
48 mp' = maybe Map.empty (flip fromDyn Map.empty) (Map.lookup (typeOf tag) mp)
49 in if fromMaybe True (Map.lookup tag mp')
50 then trace msg result
51 else result
52
53setTagLevel :: forall tag. IsDebugTag tag => Priority -> tag -> IO ()
54setTagLevel level tag = do
55 updateGlobalLogger (appName <.> show tag) (setLevel level)
56 modifyIORef verbosityMap $ \mpByType -> do
57 case Map.lookup (typeOf tag) mpByType of
58 Nothing -> Map.insert (typeOf tag) (toDyn $ Map.fromList [(tag,(level <= DEBUG))]) mpByType
59 Just dyn -> let mpByTag :: Map.Map tag Bool
60 mpByTag = fromDyn dyn Map.empty
61 in Map.insert (typeOf tag) (toDyn $ Map.insert tag (level <= DEBUG) mpByTag) mpByType
62
63setQuiet :: forall tag. IsDebugTag tag => tag -> IO ()
64setQuiet = setTagLevel WARNING
65
66setVerbose :: forall tag. IsDebugTag tag => tag -> IO ()
67setVerbose = setTagLevel DEBUG
68
69getVerbose :: forall tag. IsDebugTag tag => tag -> IO Bool
70getVerbose tag = do
71 logger <- getLogger (appName <.> show tag)
72 case getLevel logger of
73 Just p | p <= DEBUG -> return True
74 _ -> return False
75
diff --git a/src/Data/BEncode/Pretty.hs b/src/Data/BEncode/Pretty.hs
deleted file mode 100644
index 8beb101b..00000000
--- a/src/Data/BEncode/Pretty.hs
+++ /dev/null
@@ -1,81 +0,0 @@
1{-# LANGUAGE CPP #-}
2module Data.BEncode.Pretty where -- (showBEncode) where
3
4import Data.BEncode.Types
5import qualified Data.ByteString as BS
6import qualified Data.ByteString.Lazy as BL
7import Data.Text (Text)
8import qualified Data.Text as T
9import Data.Text.Encoding
10import qualified Data.ByteString.Base16 as Base16
11#ifdef BENCODE_AESON
12import Data.BEncode.BDict hiding (map)
13import Data.Aeson.Types hiding (parse)
14import Data.Aeson.Encode.Pretty
15import qualified Data.HashMap.Strict as HashMap
16import qualified Data.Vector as Vector
17import Data.Foldable as Foldable
18#endif
19
20{-
21unhex :: Text -> BS.ByteString
22unhex t = BS.pack $ map unhex1 [0 .. BS.length nibs `div` 2]
23 where
24 nibs = encodeUtf8 t
25 unhex1 i = unnib (BS.index nibs (i * 2)) * 0x10
26 + unnib (BS.index nibs (i * 2 + 1))
27 unnib a | a <= 0x39 = a - 0x30
28 | otherwise = a - (0x41 - 10)
29
30hex :: BS.ByteString -> Text
31hex bs = T.concat $ map (T.pack . printf "%02X") $ BS.unpack bs
32-}
33
34#ifdef BENCODE_AESON
35
36quote_chr :: Char
37quote_chr = ' '
38
39quote :: Text -> Text
40quote t = quote_chr `T.cons` t `T.snoc` quote_chr
41
42encodeByteString :: BS.ByteString -> Text
43encodeByteString s = either (const . decodeUtf8 $ Base16.encode s) quote $ decodeUtf8' s
44
45decodeByteString :: Text -> BS.ByteString
46decodeByteString s
47 | T.head s==quote_chr = encodeUtf8 (T.takeWhile (/=quote_chr) $ T.drop 1 s)
48 | otherwise = fst (Base16.decode (encodeUtf8 s))
49
50instance ToJSON BValue where
51 toJSON (BInteger x) = Number $ fromIntegral x
52 toJSON (BString s) = String $ encodeByteString s
53 toJSON (BList xs) = Array $ Vector.fromList $ map toJSON xs
54 toJSON (BDict d) = toJSON d
55
56instance ToJSON a => ToJSON (BDictMap a) where
57 toJSON d = Object $ HashMap.fromList $ map convert $ toAscList d
58 where
59 convert (k,v) = (encodeByteString k,toJSON v)
60
61instance FromJSON BValue where
62 parseJSON (Number x) = pure $ BInteger (truncate x)
63 parseJSON (Bool x) = pure $ BInteger $ if x then 1 else 0
64 parseJSON (String s) = pure $ BString $ decodeByteString s
65 parseJSON (Array v) = BList <$> traverse parseJSON (Foldable.toList v)
66 parseJSON (Object d) = BDict <$> parseJSON (Object d)
67 parseJSON (Null) = pure $ BDict Nil
68
69instance FromJSON v => FromJSON (BDictMap v) where
70 parseJSON (Object d) = fromAscList <$> traverse convert (HashMap.toList d)
71 where
72 convert (k,v) = (,) (decodeByteString k) <$> parseJSON v
73 parseJSON _ = fail "Not a BDict"
74#endif
75
76showBEncode :: BValue -> BL.ByteString
77#ifdef BENCODE_AESON
78showBEncode b = encodePretty $ toJSON b
79#else
80showBEncode b = BL8.pack (show b)
81#endif
diff --git a/src/Data/Bits/ByteString.hs b/src/Data/Bits/ByteString.hs
deleted file mode 100644
index bf0316fd..00000000
--- a/src/Data/Bits/ByteString.hs
+++ /dev/null
@@ -1,132 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3-------------------------------------------------------------------------------
4-- |
5-- Module : Data.Bits.ByteString
6-- Copyright : (c) 2016 Michael Carpenter
7-- License : BSD3
8-- Maintainer : Michael Carpenter <oldmanmike.dev@gmail.com>
9-- Stability : experimental
10-- Portability : portable
11--
12-------------------------------------------------------------------------------
13module Data.Bits.ByteString where
14
15import Data.Bits
16import qualified Data.ByteString as B
17import Data.Word
18
19instance Bits B.ByteString where
20
21 (.&.) a b = B.pack $ B.zipWith (.&.) a b
22 {-# INLINE (.&.) #-}
23
24 (.|.) a b = B.pack $ B.zipWith (.|.) a b
25 {-# INLINE (.|.) #-}
26
27 xor a b = B.pack $ B.zipWith xor a b
28 {-# INLINE xor #-}
29
30 complement = B.map complement
31 {-# INLINE complement #-}
32
33 shift x i
34 | i < 0 = x `shiftR` (-i)
35 | i > 0 = x `shiftL` i
36 | otherwise = x
37 {-# INLINE shift #-}
38
39 shiftR bs 0 = bs
40 shiftR "" _ = B.empty
41 shiftR bs i
42 | i `mod` 8 == 0 =
43 B.take (B.length bs) $ B.append
44 (B.replicate (i `div` 8) 0)
45 (B.drop (i `div` 8) bs)
46 | i `mod` 8 /= 0 =
47 B.pack $ take (B.length bs)
48 $ (replicate (i `div` 8) (0 :: Word8))
49 ++ (go (i `mod` 8) 0 $ B.unpack (B.take (B.length bs - (i `div` 8)) bs))
50 where
51 go _ _ [] = []
52 go j w1 (w2:wst) = (maskR j w1 w2) : go j w2 wst
53 maskR j w1 w2 = (shiftL w1 (8-j)) .|. (shiftR w2 j)
54 shiftR _ _ = error "I can't believe you've done this."
55 {-# INLINE shiftR #-}
56
57 shiftL bs 0 = bs
58 shiftL "" _ = B.empty
59 shiftL bs i
60 | i `mod` 8 == 0 =
61 B.take (B.length bs) $ B.append
62 (B.drop (i `div` 8) bs)
63 (B.replicate (i `div` 8) 0)
64 | i `mod` 8 /= 0 =
65 B.pack $ drop ((i `div` 8) - B.length bs)
66 $ (tail (go (i `mod` 8) 0 $ B.unpack (B.drop (i `div` 8) bs)))
67 ++ (replicate (i `div` 8) 0)
68 where
69 go j w1 [] = [shiftL w1 j]
70 go j w1 (w2:wst) = (maskL j w1 w2) : go j w2 wst
71 maskL j w1 w2 = (shiftL w1 j) .|. (shiftR w2 (8-j))
72 shiftL _ _ = error "I can't believe you've done this."
73 {-# INLINE shiftL #-}
74
75 rotate x i
76 | i < 0 = x `rotateR` (-i)
77 | i > 0 = x `rotateL` i
78 | otherwise = x
79 {-# INLINE rotate #-}
80
81 rotateR bs 0 = bs
82 rotateR bs i
83 | B.length bs == 0 = B.empty
84 | B.length bs == 1 = B.singleton (rotateR (bs `B.index` 0) i)
85 | B.length bs > 1 = do
86 let shiftedWords =
87 B.append
88 (B.drop (nWholeWordsToShift i) bs)
89 (B.take (nWholeWordsToShift i) bs)
90 let tmpShiftedBits = (shiftR shiftedWords (i `mod` 8))
91 let rotatedBits = (shiftL (B.last shiftedWords) (8 - (i `mod` 8))) .|. (B.head tmpShiftedBits)
92 rotatedBits `B.cons` (B.tail tmpShiftedBits)
93 where
94 nWholeWordsToShift n = (B.length bs - (n `div` 8))
95 rotateR _ _ = error "I can't believe you've done this."
96 {-# INLINE rotateR #-}
97
98 rotateL bs 0 = bs
99 rotateL bs i
100 | B.length bs == 0 = B.empty
101 | B.length bs == 1 = B.singleton (rotateL (bs `B.index` 0) i)
102 | i `mod` 8 == 0 = B.append
103 (B.drop (i `div` 8) bs)
104 (B.take (i `div` 8) bs)
105 | B.length bs > 1 = do
106 let shiftedWords =
107 B.append
108 (B.drop (i `div` 8) bs)
109 (B.take (i `div` 8) bs)
110 let tmpShiftedBits = (shiftL shiftedWords (i `mod` 8))
111 let rotatedBits = (shiftR (B.head shiftedWords) (8 - (i `mod` 8))) .|. (B.last tmpShiftedBits)
112 (B.init tmpShiftedBits) `B.snoc` rotatedBits
113 rotateL _ _ = error "I can't believe you've done this."
114 {-# INLINE rotateL #-}
115
116 bitSize x = 8 * B.length x
117 {-# INLINE bitSize #-}
118
119 bitSizeMaybe x = Just (8 * B.length x)
120 {-# INLINE bitSizeMaybe #-}
121
122 isSigned _ = False
123 {-# INLINE isSigned #-}
124
125 testBit x i = testBit (B.index x (B.length x - (i `div` 8) - 1)) (i `mod` 8)
126 {-# INLINE testBit #-}
127
128 bit i = (bit $ mod i 8) `B.cons` (B.replicate (div i 8) (255 :: Word8))
129 {-# INLINE bit #-}
130
131 popCount x = sum $ map popCount $ B.unpack x
132 {-# INLINE popCount #-}
diff --git a/src/Data/Digest/CRC32C.hs b/src/Data/Digest/CRC32C.hs
deleted file mode 100644
index 18c1314f..00000000
--- a/src/Data/Digest/CRC32C.hs
+++ /dev/null
@@ -1,100 +0,0 @@
1module Data.Digest.CRC32C
2 ( crc32c
3 , crc32c_update
4 ) where
5
6import Data.Bits
7import Data.ByteString (ByteString)
8import Data.Word
9import Data.Array.Base (unsafeAt)
10import Data.Array.Unboxed
11
12import qualified Data.ByteString as B
13
14
15crc32c :: ByteString -> Word32
16crc32c = crc32c_update 0
17
18crc32c_update :: Word32 -> ByteString -> Word32
19crc32c_update crc bs = flipd $ step (flipd crc) bs
20 where
21 flipd = xor 0xffffffff
22
23step :: Word32 -> ByteString -> Word32
24step crc bs = B.foldl step' crc bs
25 where
26 step' acc b = let x = table !!! ((acc .&. 0xff) `xor` fromIntegral b)
27 in x `xor` (acc `shiftR` 8)
28{-# INLINEABLE step #-}
29
30(!!!) :: (IArray a e, Ix i, Integral i) => a i e -> i -> e
31arr !!! i = unsafeAt arr $ fromIntegral i
32{-# INLINEABLE (!!!) #-}
33
34table :: UArray Word32 Word32
35table = listArray (0,255) $
36 [ 0x00000000, 0xf26b8303, 0xe13b70f7, 0x1350f3f4
37 , 0xc79a971f, 0x35f1141c, 0x26a1e7e8, 0xd4ca64eb
38 , 0x8ad958cf, 0x78b2dbcc, 0x6be22838, 0x9989ab3b
39 , 0x4d43cfd0, 0xbf284cd3, 0xac78bf27, 0x5e133c24
40 , 0x105ec76f, 0xe235446c, 0xf165b798, 0x030e349b
41 , 0xd7c45070, 0x25afd373, 0x36ff2087, 0xc494a384
42 , 0x9a879fa0, 0x68ec1ca3, 0x7bbcef57, 0x89d76c54
43 , 0x5d1d08bf, 0xaf768bbc, 0xbc267848, 0x4e4dfb4b
44 , 0x20bd8ede, 0xd2d60ddd, 0xc186fe29, 0x33ed7d2a
45 , 0xe72719c1, 0x154c9ac2, 0x061c6936, 0xf477ea35
46 , 0xaa64d611, 0x580f5512, 0x4b5fa6e6, 0xb93425e5
47 , 0x6dfe410e, 0x9f95c20d, 0x8cc531f9, 0x7eaeb2fa
48 , 0x30e349b1, 0xc288cab2, 0xd1d83946, 0x23b3ba45
49 , 0xf779deae, 0x05125dad, 0x1642ae59, 0xe4292d5a
50 , 0xba3a117e, 0x4851927d, 0x5b016189, 0xa96ae28a
51 , 0x7da08661, 0x8fcb0562, 0x9c9bf696, 0x6ef07595
52 , 0x417b1dbc, 0xb3109ebf, 0xa0406d4b, 0x522bee48
53 , 0x86e18aa3, 0x748a09a0, 0x67dafa54, 0x95b17957
54 , 0xcba24573, 0x39c9c670, 0x2a993584, 0xd8f2b687
55 , 0x0c38d26c, 0xfe53516f, 0xed03a29b, 0x1f682198
56 , 0x5125dad3, 0xa34e59d0, 0xb01eaa24, 0x42752927
57 , 0x96bf4dcc, 0x64d4cecf, 0x77843d3b, 0x85efbe38
58 , 0xdbfc821c, 0x2997011f, 0x3ac7f2eb, 0xc8ac71e8
59 , 0x1c661503, 0xee0d9600, 0xfd5d65f4, 0x0f36e6f7
60 , 0x61c69362, 0x93ad1061, 0x80fde395, 0x72966096
61 , 0xa65c047d, 0x5437877e, 0x4767748a, 0xb50cf789
62 , 0xeb1fcbad, 0x197448ae, 0x0a24bb5a, 0xf84f3859
63 , 0x2c855cb2, 0xdeeedfb1, 0xcdbe2c45, 0x3fd5af46
64 , 0x7198540d, 0x83f3d70e, 0x90a324fa, 0x62c8a7f9
65 , 0xb602c312, 0x44694011, 0x5739b3e5, 0xa55230e6
66 , 0xfb410cc2, 0x092a8fc1, 0x1a7a7c35, 0xe811ff36
67 , 0x3cdb9bdd, 0xceb018de, 0xdde0eb2a, 0x2f8b6829
68 , 0x82f63b78, 0x709db87b, 0x63cd4b8f, 0x91a6c88c
69 , 0x456cac67, 0xb7072f64, 0xa457dc90, 0x563c5f93
70 , 0x082f63b7, 0xfa44e0b4, 0xe9141340, 0x1b7f9043
71 , 0xcfb5f4a8, 0x3dde77ab, 0x2e8e845f, 0xdce5075c
72 , 0x92a8fc17, 0x60c37f14, 0x73938ce0, 0x81f80fe3
73 , 0x55326b08, 0xa759e80b, 0xb4091bff, 0x466298fc
74 , 0x1871a4d8, 0xea1a27db, 0xf94ad42f, 0x0b21572c
75 , 0xdfeb33c7, 0x2d80b0c4, 0x3ed04330, 0xccbbc033
76 , 0xa24bb5a6, 0x502036a5, 0x4370c551, 0xb11b4652
77 , 0x65d122b9, 0x97baa1ba, 0x84ea524e, 0x7681d14d
78 , 0x2892ed69, 0xdaf96e6a, 0xc9a99d9e, 0x3bc21e9d
79 , 0xef087a76, 0x1d63f975, 0x0e330a81, 0xfc588982
80 , 0xb21572c9, 0x407ef1ca, 0x532e023e, 0xa145813d
81 , 0x758fe5d6, 0x87e466d5, 0x94b49521, 0x66df1622
82 , 0x38cc2a06, 0xcaa7a905, 0xd9f75af1, 0x2b9cd9f2
83 , 0xff56bd19, 0x0d3d3e1a, 0x1e6dcdee, 0xec064eed
84 , 0xc38d26c4, 0x31e6a5c7, 0x22b65633, 0xd0ddd530
85 , 0x0417b1db, 0xf67c32d8, 0xe52cc12c, 0x1747422f
86 , 0x49547e0b, 0xbb3ffd08, 0xa86f0efc, 0x5a048dff
87 , 0x8ecee914, 0x7ca56a17, 0x6ff599e3, 0x9d9e1ae0
88 , 0xd3d3e1ab, 0x21b862a8, 0x32e8915c, 0xc083125f
89 , 0x144976b4, 0xe622f5b7, 0xf5720643, 0x07198540
90 , 0x590ab964, 0xab613a67, 0xb831c993, 0x4a5a4a90
91 , 0x9e902e7b, 0x6cfbad78, 0x7fab5e8c, 0x8dc0dd8f
92 , 0xe330a81a, 0x115b2b19, 0x020bd8ed, 0xf0605bee
93 , 0x24aa3f05, 0xd6c1bc06, 0xc5914ff2, 0x37faccf1
94 , 0x69e9f0d5, 0x9b8273d6, 0x88d28022, 0x7ab90321
95 , 0xae7367ca, 0x5c18e4c9, 0x4f48173d, 0xbd23943e
96 , 0xf36e6f75, 0x0105ec76, 0x12551f82, 0xe03e9c81
97 , 0x34f4f86a, 0xc69f7b69, 0xd5cf889d, 0x27a40b9e
98 , 0x79b737ba, 0x8bdcb4b9, 0x988c474d, 0x6ae7c44e
99 , 0xbe2da0a5, 0x4c4623a6, 0x5f16d052, 0xad7d5351
100 ]
diff --git a/src/Data/IntervalSet.hs b/src/Data/IntervalSet.hs
deleted file mode 100644
index f1205274..00000000
--- a/src/Data/IntervalSet.hs
+++ /dev/null
@@ -1,129 +0,0 @@
1module Data.IntervalSet
2 ( IntSet
3 , null
4 , empty
5 , insert
6 , delete
7 , interval
8 , toIntervals
9 , nearestOutsider
10 , Data.IntervalSet.lookup
11 ) where
12
13import Prelude hiding (null)
14import qualified Data.IntMap.Strict as IntMap
15 ;import Data.IntMap.Strict (IntMap)
16import qualified Data.List as List
17import Data.Ord
18
19
20-- A set of integers.
21newtype IntSet = IntSet (IntMap Interval)
22 deriving Show
23
24-- Note: the intervalMin is not stored here but is the lookup key in an IntMap.
25data Interval = Interval
26 { intervalMax :: {-# UNPACK #-} !Int -- ^ Maximum value contained in this interval.
27 , intervalNext :: {-# UNPACK #-} !Int -- ^ Minimum value in next interval if there is one.
28 }
29 deriving Show
30
31null :: IntSet -> Bool
32null (IntSet m) = IntMap.null m
33
34empty :: IntSet
35empty = IntSet IntMap.empty
36
37
38insert :: Int -> IntSet -> IntSet
39insert x (IntSet m) = IntSet $ case IntMap.lookupLE x m of
40 Just (lb,Interval mx ub)
41 | x <= mx -> m
42 | otherwise -> case ub == maxBound of
43
44 True | x == mx + 1 -> IntMap.insert lb (Interval x maxBound) m
45 | otherwise -> IntMap.insert lb (Interval mx x)
46 $ IntMap.insert x (Interval x maxBound) m
47
48 False | mx + 2 == ub -> let (Just v', m')
49 = IntMap.updateLookupWithKey (\_ _ -> Nothing) ub m
50 in IntMap.insert lb v' m'
51 | mx + 1 == x -> IntMap.insert lb (Interval x ub) m
52 | otherwise -> IntMap.insert lb (Interval mx x)
53 $ if ub == x + 1
54 then let (Just v', m')
55 = IntMap.updateLookupWithKey
56 (\_ _ -> Nothing) ub m
57 in IntMap.insert x v' m'
58 else IntMap.insert x (Interval x ub) m
59
60 Nothing -> case IntMap.minViewWithKey m of
61
62 Just ((ub,v),m')
63 | x + 1 == ub -> IntMap.insert x v m'
64 | otherwise -> IntMap.insert x (Interval x ub) m
65
66 Nothing -> IntMap.singleton x (Interval x maxBound)
67
68member :: Int -> IntSet -> Bool
69member x (IntSet m) = case IntMap.lookupLE x m of
70 Just (lb,Interval mx _) -> x <= mx
71 Nothing -> False
72
73nearestOutsider :: Int -> IntSet -> Maybe Int
74nearestOutsider x (IntSet m)
75 | List.null xs = Nothing -- There are no integers outside the set!
76 | otherwise = Just $ List.minimumBy (comparing (\y -> abs (x - y))) xs
77 where
78 xs = case IntMap.lookupLE x m of
79 Nothing -> [x]
80 Just (lb,Interval mx ub)
81 -> if ub < maxBound
82 then case () of
83 () | x > mx -> [x]
84 | minBound < lb -> [lb-1, mx+1, ub-1]
85 | otherwise -> [mx+1, ub-1]
86 else case () of
87 () | x > mx -> [x]
88 | minBound < lb && mx < maxBound -> [lb-1, mx+1]
89 | minBound < lb -> [lb-1]
90 | mx < maxBound -> [mx+1]
91 | otherwise -> []
92
93-- Note this could possibly benefit from a intervalPrev field.
94delete :: Int -> IntSet -> IntSet
95delete x (IntSet m) = IntSet $ case IntMap.lookupLE x m of
96 Nothing -> m
97 Just (lb,Interval mx nxt) -> case compare x mx of
98
99 GT -> m
100
101 EQ | lb < mx -> IntMap.insert lb (Interval (mx - 1) nxt) m
102 | otherwise -> case IntMap.lookupLE (x-1) m of -- no intervalPrev
103 Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' nxt)
104 $ IntMap.delete lb m
105 Nothing -> IntMap.delete lb m
106
107 LT -> let m' = IntMap.insert (x+1) (Interval mx nxt) m
108 in if lb < x
109 then IntMap.insert lb (Interval (x - 1) (x+1)) m'
110 else if x == minBound
111 then IntMap.delete minBound m'
112 else case IntMap.lookupLE (x-1) m' of -- no intervalPrev
113 Just (lb',Interval mx' _) -> IntMap.insert lb' (Interval mx' (x+1))
114 $ IntMap.delete lb m'
115 Nothing -> IntMap.delete lb m'
116
117toIntervals :: IntSet -> [(Int,Int)]
118toIntervals (IntSet m) = List.map (\(lb,(Interval mx _)) -> (lb,mx))
119 $ IntMap.toList m
120
121interval :: Int -> Int -> IntSet
122interval lb mx
123 | lb <= mx = IntSet $ IntMap.singleton lb (Interval mx maxBound)
124 | otherwise = IntSet IntMap.empty
125
126lookup :: Int -> IntSet -> Maybe (Int,Int)
127lookup k (IntSet m) = case IntMap.lookupLE k m of
128 Nothing -> Nothing
129 Just (lb,Interval mx _) -> Just (lb,mx)
diff --git a/src/Data/MinMaxPSQ.hs b/src/Data/MinMaxPSQ.hs
deleted file mode 100644
index e7d7c760..00000000
--- a/src/Data/MinMaxPSQ.hs
+++ /dev/null
@@ -1,112 +0,0 @@
1{-# LANGUAGE BangPatterns, PatternSynonyms #-}
2module Data.MinMaxPSQ
3 ( module Data.MinMaxPSQ
4 , Binding'
5 , pattern Binding
6 ) where
7
8import Data.Ord
9import qualified Data.Wrapper.PSQ as PSQ
10 ;import Data.Wrapper.PSQ as PSQ hiding (insert, insert', null, size)
11import Prelude hiding (null, take)
12
13data MinMaxPSQ' k p v = MinMaxPSQ !Int !(PSQ' k p v) !(PSQ' k (Down p) v)
14type MinMaxPSQ k p = MinMaxPSQ' k p ()
15
16empty :: MinMaxPSQ' k p v
17empty = MinMaxPSQ 0 PSQ.empty PSQ.empty
18
19singleton' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v
20singleton' k v p = MinMaxPSQ 1 (PSQ.singleton' k v p) (PSQ.singleton' k v (Down p))
21
22null :: MinMaxPSQ' k p v -> Bool
23null (MinMaxPSQ sz _ _) = sz==0
24{-# INLINE null #-}
25
26size :: MinMaxPSQ' k p v -> Int
27size (MinMaxPSQ sz _ _) = sz
28{-# INLINE size #-}
29
30toList :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> [Binding' k p v]
31toList (MinMaxPSQ _ nq xq) = PSQ.toList nq
32
33fromList :: (PSQKey k, Ord p) => [Binding' k p v] -> MinMaxPSQ' k p v
34fromList kps = let nq = PSQ.fromList kps
35 xq = PSQ.fromList $ map (\(Binding k v p) -> Binding k v (Down p)) kps
36 in MinMaxPSQ (PSQ.size nq) nq xq
37
38findMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v)
39findMin (MinMaxPSQ _ nq xq) = PSQ.findMin nq
40
41findMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v)
42findMax (MinMaxPSQ _ nq xq) = fmap (\(Binding k v (Down p)) -> Binding k v p) $ PSQ.findMin xq
43
44insert :: (PSQKey k, Ord p) => k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p
45insert k p (MinMaxPSQ sz nq xq) = case PSQ.insertView k p () nq of
46 (Just _ ,nq') -> MinMaxPSQ sz nq' (PSQ.insert k (Down p) xq)
47 (Nothing,nq') -> MinMaxPSQ (sz+1) nq' (PSQ.insert k (Down p) xq)
48
49insert' :: (PSQKey k, Ord p) => k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
50insert' k v p (MinMaxPSQ sz nq xq) = case PSQ.insertView k p v nq of
51 (Just _ ,nq') -> MinMaxPSQ sz nq' (PSQ.insert' k v (Down p) xq)
52 (Nothing,nq') -> MinMaxPSQ (sz+1) nq' (PSQ.insert' k v (Down p) xq)
53
54delete :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
55delete k q@(MinMaxPSQ sz nq xq) = case PSQ.deleteView k nq of
56 Just (_,_,nq') -> MinMaxPSQ (sz - 1) nq' (PSQ.delete k xq)
57 Nothing -> q
58
59deleteMin :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v
60deleteMin q@(MinMaxPSQ sz nq xq) = case PSQ.minView nq of
61 Just (Binding k _ _, nq') -> MinMaxPSQ (sz - 1) nq' (PSQ.delete k xq)
62 Nothing -> q
63
64deleteMax :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> MinMaxPSQ' k p v
65deleteMax q@(MinMaxPSQ sz nq xq) = case PSQ.minView xq of
66 Just (Binding k _ _, xq') -> MinMaxPSQ (sz - 1) (PSQ.delete k nq) xq'
67 Nothing -> q
68
69minView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v)
70minView (MinMaxPSQ sz nq xq) = fmap (\(Binding k v p, nq') -> (Binding k v p, MinMaxPSQ (sz-1) nq' (PSQ.delete k xq)))
71 $ PSQ.minView nq
72
73maxView :: (PSQKey k, Ord p) => MinMaxPSQ' k p v -> Maybe (Binding' k p v, MinMaxPSQ' k p v)
74maxView (MinMaxPSQ sz nq xq) = fmap (\(Binding k v (Down p), xq') -> (Binding k v p, MinMaxPSQ (sz-1) (PSQ.delete k nq) xq'))
75 $ PSQ.minView xq
76
77-- | Maintains a bounded 'MinMaxPSQ' by deleting the maximum element if the
78-- insertion would cause the queue to have too many elements.
79insertTake :: (PSQKey k, Ord p) => Int -> k -> p -> MinMaxPSQ k p -> MinMaxPSQ k p
80insertTake n k p q
81 | size q < n = insert k p q
82 | size q == n = insert k p $ deleteMax q
83 | otherwise = take n $ insert k p q
84
85-- | Maintains a bounded 'MinMaxPSQ\'' by deleting the maximum element if the
86-- insertion would cause the queue to have too many elements.
87insertTake' :: (PSQKey k, Ord p) => Int -> k -> v -> p -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
88insertTake' n k v p q
89 | size q < n = insert' k v p q
90 | size q == n = insert' k v p $ deleteMax q
91 | otherwise = take n $ insert' k v p q
92
93
94-- | Truncate the 'MinMaxPSQ' to the given number of lowest priority elements.
95take :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> MinMaxPSQ' k p v
96take !n !q | (size q <= n) = q
97 | null q = q
98 | otherwise = take n $ deleteMax q
99
100-- | Like 'take', except it provides a list deleted bindings.
101takeView :: (PSQKey k, Ord p) => Int -> MinMaxPSQ' k p v -> ( [Binding' k p v], MinMaxPSQ' k p v )
102takeView !n !q | (size q <= n) = ([], q)
103 | null q = ([], q)
104 | otherwise = let Just (x,q') = maxView q
105 (xs,q'') = takeView n q'
106 ys = x:xs
107 in (ys, ys `seq` q'')
108
109
110
111lookup' :: (PSQKey k, Ord p) => k -> MinMaxPSQ' k p v -> Maybe (p, v)
112lookup' k (MinMaxPSQ _ q _) = PSQ.lookup k q
diff --git a/src/Data/PacketBuffer.hs b/src/Data/PacketBuffer.hs
deleted file mode 100644
index 17745664..00000000
--- a/src/Data/PacketBuffer.hs
+++ /dev/null
@@ -1,148 +0,0 @@
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE DeriveFunctor #-}
3module Data.PacketBuffer
4 ( PacketBuffer
5 , newPacketBuffer
6 , PacketOutboundEvent(..)
7 , PacketInboundEvent(..)
8 , grokOutboundPacket
9 , grokInboundPacket
10 , awaitReadyPacket
11 , packetNumbersToRequest
12 , expectingSequenceNumber
13 , nextToSendSequenceNumber
14 , retrieveForResend
15 , decompressSequenceNumbers
16 , compressSequenceNumbers
17 , pbReport
18 ) where
19
20import Data.PacketQueue as Q
21import DPut
22import DebugTag
23
24import Control.Concurrent.STM
25import Control.Monad
26import Data.Maybe
27import Data.Word
28
29data PacketBuffer a b = PacketBuffer
30 { inQueue :: PacketQueue a
31 , outBuffer :: PacketQueue b }
32
33-- | Initialize the packet buffers. Note, the capacity of the inbound packet
34-- queue is currently hardcoded to 200 packets and the capacity of the outbound
35-- buffer is hardcoded to 400 packets.
36newPacketBuffer :: STM (PacketBuffer a b)
37newPacketBuffer = PacketBuffer <$> Q.new 200 0
38 <*> Q.new 400 0
39
40-- | Input for 'grokPacket'.
41data PacketOutboundEvent b
42 = PacketSent { poSeqNum :: Word32 -- ^ Sequence number for payload.
43 , poSentPayload :: b -- ^ Payload packet we sent to them.
44 }
45 deriving Functor
46
47data PacketInboundEvent a
48 = PacketReceived { peSeqNum :: Word32 -- ^ Sequence number for payload.
49 , peReceivedPayload :: a -- ^ Payload packet they sent to us.
50 , peAcknowledgedNum :: Word32 -- ^ Earliest sequence number they've seen from us.
51 }
52 | PacketReceivedLossy { peSeqNum :: Word32 -- ^ Sequence number for lossy packet.
53 , peReceivedPayload :: a -- ^ Payload packet they sent to us (ignored).
54 , peAcknowledgedNum :: Word32 -- ^ Earliest sequence number they've seen from us.
55 }
56 deriving Functor
57
58-- | Whenever a packet is received or sent (but not resent) from the network,
59-- this function should be called to update the relevant buffers.
60--
61-- On outgoing packets, if the outbound buffer is full, this will return
62-- True. In this case, the caller may retry to enable blocking until
63-- 'grokInboundPacket' is called in another thread.
64grokOutboundPacket :: PacketBuffer a b -> PacketOutboundEvent b -> STM (Bool,(Word32,Word32))
65grokOutboundPacket (PacketBuffer _ outb) (PacketSent seqno a)
66 = do (n,r) <- Q.enqueue outb seqno a
67 return (n/=0,(n,r))
68
69grokInboundPacket :: PacketBuffer a b -> PacketInboundEvent a -> STM ()
70grokInboundPacket (PacketBuffer inb outb) (PacketReceived seqno a ack)
71 = do Q.enqueue inb seqno a
72 Q.dropPacketsBefore outb ack
73grokInboundPacket (PacketBuffer inb outb) (PacketReceivedLossy seqno _ ack)
74 = do Q.observeOutOfBand inb seqno
75 Q.dropPacketsBefore outb ack
76
77-- | Wait until an inbound packet is ready to process. Any necessary
78-- re-ordering will have been done.
79awaitReadyPacket :: PacketBuffer a b -> STM a
80awaitReadyPacket (PacketBuffer inb _) = Q.dequeue inb
81
82-- | Obtain a list of sequence numbers that may have been dropped. This would
83-- be any number not yet received that is prior to the maxium sequence number
84-- we have received. For convenience, a lowerbound for the missing squence numbers
85-- is also returned as the second item of the pair.
86packetNumbersToRequest :: PacketBuffer a b -> STM ([Word32],Word32)
87packetNumbersToRequest (PacketBuffer inb _) = do
88 ns <- Q.getMissing inb
89 lb <- Q.getLastDequeuedPlus1 inb
90 return (ns,lb)
91
92expectingSequenceNumber :: PacketBuffer a b -> STM Word32
93expectingSequenceNumber (PacketBuffer inb _ ) = Q.getLastDequeuedPlus1 inb
94
95nextToSendSequenceNumber :: PacketBuffer a b -> STM Word32
96nextToSendSequenceNumber (PacketBuffer _ outb) = Q.getLastEnqueuedPlus1 outb
97
98-- | Retrieve already-sent packets by their sequence numbers. See
99-- 'decompressSequenceNumbers' to obtain the sequence number list from a
100-- compressed encoding. There is no need to call 'grokPacket' when sending the
101-- packets returned from this call.
102retrieveForResend :: PacketBuffer a b -> [Word32] -> STM [(Word32,b)]
103retrieveForResend (PacketBuffer _ outb) seqnos =
104 catMaybes <$> forM seqnos (\no -> fmap (no,) <$> Q.lookup outb no)
105
106-- | Expand a compressed set of sequence numbers. The first sequence number is
107-- given directly and the rest are computed using 8-bit offsets. This is
108-- normally used to obtain input for 'retrieveForResend'.
109decompressSequenceNumbers :: Word32 -> [Word8] -> [Word32]
110decompressSequenceNumbers baseno ns = foldr doOne (const []) ns (baseno-1)
111 where
112 doOne :: Word8 -> (Word32 -> [Word32]) -> Word32 -> [Word32]
113 doOne 0 f addend = f (addend + 255)
114 doOne x f addend = let y = fromIntegral x + addend
115 in y : f y
116
117compressSequenceNumbers :: Word32 -> [Word32] -> [Word8]
118compressSequenceNumbers baseno xs = foldr doOne (const []) xs (baseno-1)
119 where
120 doOne :: Word32 -> (Word32 -> [Word8]) -> Word32 -> [Word8]
121 doOne y f addend = case y - addend of
122 x | x < 255 -> fromIntegral x : f y
123 | otherwise -> 0 : doOne y f (addend + 255)
124
125{-
126compressSequenceNumbers :: Word32 -> [Word32] -> [Word8]
127compressSequenceNumbers seqno xs = let r = map fromIntegral (reduceToSums ys >>= makeZeroes)
128 in dtrace XNetCrypto ("compressSequenceNumbers " ++ show seqno ++ show xs ++ " --> "++show r) r
129 where
130 ys = Prelude.map (subtract (seqno - 1)) xs
131 reduceToSums [] = []
132 reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs)
133 makeZeroes :: Word32 -> [Word32]
134 -- makeZeroes 0 = []
135 makeZeroes x
136 = let (d,m)= x `divMod` 255
137 zeros= Prelude.replicate (fromIntegral d) 0
138 in zeros ++ [m]
139-}
140
141pbReport :: String -> PacketBuffer a b -> STM String
142pbReport what (PacketBuffer inb outb) = do
143 inb_seqno <- getLastDequeuedPlus1 inb
144 inb_buffend <- getLastEnqueuedPlus1 inb
145 outb_seqno <- getLastDequeuedPlus1 outb
146 outb_bufend <- getLastEnqueuedPlus1 outb
147 return $ "PacketBuffer<"++what++"> Inbound" ++ show (inb_seqno, inb_buffend)
148 ++" Outbound" ++ show (outb_seqno, outb_bufend)
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
deleted file mode 100644
index 15a3b436..00000000
--- a/src/Data/PacketQueue.hs
+++ /dev/null
@@ -1,217 +0,0 @@
1-- | This module is useful for implementing a lossess protocol on top of a
2-- lossy datagram style protocol. It implements a buffer in which packets may
3-- be stored out of order, but from which they are extracted in the proper
4-- sequence.
5{-# LANGUAGE NamedFieldPuns #-}
6module Data.PacketQueue
7 ( PacketQueue
8 , getCapacity
9 , getLastDequeuedPlus1
10 , getLastEnqueuedPlus1
11 , new
12 , dequeue
13 , dropPacketsLogic
14 , dropPacketsBefore
15 , getMissing
16 -- , dequeueOrGetMissing
17 -- , markButNotDequeue
18 , enqueue
19 , observeOutOfBand
20 , packetQueueViewList
21 -- , mapQ
22 , Data.PacketQueue.lookup
23 ) where
24
25import Control.Concurrent.STM
26import Control.Monad
27import Data.Word
28import Data.Array.MArray
29import Data.Maybe
30
31data PacketQueue a = PacketQueue
32 { pktq :: TArray Word32 (Maybe a)
33 , seqno :: TVar Word32 -- (buffer_start)
34 , qsize :: Word32
35 , buffend :: TVar Word32 -- on incoming, next packet they'll send + 1
36 -- i.e. one more than the largest seen sequence number.
37 -- Written by:
38 -- observeOutOfBand
39 -- dropPacketsBefore
40 -- enqueue
41 }
42
43-- | Obtain a list of non-empty slots in the 'PacketQueue'. The numeric value
44-- is an index into the underlying array, not a sequence number.
45packetQueueViewList :: PacketQueue a -> STM [(Word32,a)]
46packetQueueViewList p = do
47 let f (n,Nothing) = Nothing
48 f (n,Just x) = Just (n,x)
49 catMaybes . map f <$> getAssocs (pktq p)
50
51-- | This returns the earliest sequence number with a slot in the queue.
52getLastDequeuedPlus1 :: PacketQueue a -> STM Word32
53getLastDequeuedPlus1 PacketQueue {seqno} = readTVar seqno
54
55-- | This returns the least upper bound of sequence numbers that have been
56-- enqueued.
57getLastEnqueuedPlus1 :: PacketQueue a -> STM Word32
58getLastEnqueuedPlus1 PacketQueue {buffend} = readTVar buffend
59
60
61-- | This is the number of consequetive sequence numbers, starting at
62-- 'getLastDequeuedPlus1' that can be stored in the queue
63getCapacity :: Applicative m => PacketQueue t -> m Word32
64getCapacity (PacketQueue { qsize }) = pure qsize
65
66-- | Create a new PacketQueue.
67new :: Word32 -- ^ Capacity of queue.
68 -> Word32 -- ^ Initial sequence number.
69 -> STM (PacketQueue a)
70new capacity seqstart = do
71 let cap = if capacity `mod` 2 == 0 then capacity else capacity + 1
72 q <- newArray (0,cap - 1) Nothing
73 seqv <- newTVar seqstart
74 bufe <- newTVar seqstart
75 return PacketQueue
76 { pktq = q
77 , seqno = seqv
78 , qsize = cap
79 , buffend = bufe
80 }
81
82-- | Update the packet queue given:
83--
84-- * packet queue
85--
86-- * the number of next lossless packet they intend to send you
87--
88-- This behaves exactly like 'enqueue' except that no packet data is written to
89-- the queue.
90observeOutOfBand :: PacketQueue a -> Word32-> STM ()
91observeOutOfBand PacketQueue { seqno, qsize, buffend } numberOfNextLosslessPacketThatTheyWillSend = do
92 low <- readTVar seqno
93 let proj = numberOfNextLosslessPacketThatTheyWillSend - low
94 -- Ignore packet if out of range.
95 when ( proj < qsize) $ do
96 modifyTVar' buffend (\be -> if be - low <= proj then numberOfNextLosslessPacketThatTheyWillSend + 1 else be)
97
98-- | If seqno < buffend then return expected packet numbers for all
99-- the Nothings in the array between them.
100-- Otherwise, return empty list.
101getMissing :: PacketQueue a -> STM [Word32]
102getMissing PacketQueue { pktq, seqno, qsize, buffend } = do
103 seqno0 <- readTVar seqno
104 buffend0 <- readTVar buffend
105 -- note relying on fact that [ b .. a ] is null when a < b
106 let indices = take (fromIntegral qsize) $ [ seqno0 .. buffend0 - 1]
107 maybes <- forM indices $ \i -> do
108 x <- readArray pktq $ i `mod` qsize
109 return (i,x)
110 let nums = map fst . filter (isNothing . snd) $ maybes
111 return nums
112
113-- -- | If seqno < buffend then return expected packet numbers for all
114-- -- the Nothings in the array between them.
115-- -- Otherwise, behave as 'dequeue' would.
116-- -- TODO: Do we need this function? Delete it if not.
117-- dequeueOrGetMissing :: PacketQueue a -> STM (Either [Word32] a)
118-- dequeueOrGetMissing PacketQueue { pktq, seqno, qsize, buffend } = do
119-- seqno0 <- readTVar seqno
120-- buffend0 <- readTVar buffend
121-- if seqno0 < buffend0
122-- then do
123-- maybes <- mapM (readArray pktq) (take (fromIntegral qsize) $ map (`mod` qsize) [ seqno0 .. buffend0 ])
124-- let nums = map fst . filter (isNothing . snd) $ zip [buffend0 ..] maybes
125-- return (Left nums)
126-- else do
127-- let i = seqno0 `mod` qsize
128-- x <- maybe retry return =<< readArray pktq i
129-- writeArray pktq i Nothing
130-- modifyTVar' seqno succ
131-- return (Right x)
132
133-- | Retry until the next expected packet is enqueued. Then return it.
134dequeue :: PacketQueue a -> STM a
135dequeue PacketQueue { pktq, seqno, qsize } = do
136 i0 <- readTVar seqno
137 let i = i0 `mod` qsize
138 x <- maybe retry return =<< readArray pktq i
139 writeArray pktq i Nothing
140 modifyTVar' seqno succ
141 return x
142
143-- | Helper to 'dropPacketsBefore'.
144dropPacketsLogic :: Word32 -> Word32 -> Word32 -> (Maybe Word32, Word32, [(Word32,Word32)])
145dropPacketsLogic qsize low no0 =
146 let no = no0 - 1 -- Unsigned: could overflow
147 proj = no - low -- Unsigned: could overflow
148 in if proj < qsize
149 then
150 let ilow = low `mod` qsize
151 i = no `mod` qsize
152 ranges = if ilow <= i then [(ilow, i)]
153 else [(0,i),(ilow,qsize-1)]
154 in (Nothing,no0,ranges) -- Clear some, but not all, slots.
155 else (Nothing,low,[]) -- out of bounds, do nothing -- (Just no0, no0, [(0,qsize - 1)]) -- Reset to empty queue.
156
157
158-- | Drop all packets preceding the given packet number.
159dropPacketsBefore :: PacketQueue a -> Word32 -> STM ()
160dropPacketsBefore PacketQueue{ pktq, seqno, qsize, buffend } no0 = do
161 low <- readTVar seqno
162 let (mbuffend, no, ranges) = dropPacketsLogic qsize low no0
163 mapM_ (writeTVar buffend) mbuffend
164 writeTVar seqno no
165 forM_ ranges $ \(lo,hi) -> forM_ [lo .. hi] $ \i -> writeArray pktq i Nothing
166
167
168-- -- | Like dequeue, but marks as viewed rather than removing
169-- markButNotDequeue :: PacketQueue (Bool,a) -> STM a
170-- markButNotDequeue PacketQueue { pktq, seqno, qsize } = do
171-- i0 <- readTVar seqno
172-- let i = i0 `mod` qsize
173-- (b,x) <- maybe retry return =<< readArray pktq i
174-- writeArray pktq i (Just (True,x))
175-- modifyTVar' seqno succ
176-- return x
177
178-- | Enqueue a packet. Packets need not be enqueued in order as long as there
179-- is spare capacity in the queue. If there is not, the packet will be
180-- silently discarded without blocking. (Unless this is an Overwrite-queue, in
181-- which case, the packets will simply wrap around overwriting the old ones.)
182--
183-- If the packet was enqueued, (0,i) will be retuned where /i/ is the index at
184-- which the new packet was stored in the buffer. If the queue was full, the
185-- first of the returned pair will be non-zero.
186enqueue :: PacketQueue a -- ^ The packet queue.
187 -> Word32 -- ^ Sequence number of the packet.
188 -> a -- ^ The packet.
189 -> STM (Word32,Word32)
190enqueue PacketQueue{ pktq, seqno, qsize, buffend} no x = do
191 low <- readTVar seqno
192 let proj = no - low
193 -- Ignore packet if out of range.
194 when ( proj < qsize) $ do
195 let i = no `mod` qsize
196 writeArray pktq i (Just x)
197 modifyTVar' buffend (\be -> if be - low <= proj then no + 1 else be)
198 return (proj `divMod` qsize)
199
200-- | Obtain the packet with the given sequence number if it is stored in the
201-- queue, otherwise /Nothing/ is returned without blocking.
202lookup :: PacketQueue a -> Word32 -> STM (Maybe a)
203lookup PacketQueue{ pktq, seqno, qsize } no = do
204 low <- readTVar seqno
205 let proj = no - low
206 if proj < qsize
207 then let i = no `mod` qsize
208 in readArray pktq i
209 else return Nothing
210
211-- -- | For each item in the queue, modify or delete it.
212-- mapQ :: (a -> Maybe a) -> PacketQueue a -> STM ()
213-- mapQ f PacketQueue{pktq} = do
214-- (z,n) <- getBounds pktq
215-- forM_ [z .. n] $ \i -> do
216-- e <- readArray pktq i
217-- writeArray pktq i (e>>=f)
diff --git a/src/Data/Sized.hs b/src/Data/Sized.hs
deleted file mode 100644
index 0d3d5845..00000000
--- a/src/Data/Sized.hs
+++ /dev/null
@@ -1,14 +0,0 @@
1module Data.Sized where
2
3import Data.Typeable
4
5
6-- | Info about a type's serialized length. Either the length is known
7-- independently of the value, or the length depends on the value.
8data Size a
9 = VarSize (a -> Int)
10 | ConstSize !Int
11 deriving Typeable
12
13class Sized a where size :: Size a
14
diff --git a/src/Data/TableMethods.hs b/src/Data/TableMethods.hs
deleted file mode 100644
index e4208a69..00000000
--- a/src/Data/TableMethods.hs
+++ /dev/null
@@ -1,105 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE PartialTypeSignatures #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
8module Data.TableMethods where
9
10import Data.Functor.Contravariant
11import Data.Time.Clock.POSIX
12import Data.Word
13import qualified Data.IntMap.Strict as IntMap
14 ;import Data.IntMap.Strict (IntMap)
15import qualified Data.Map.Strict as Map
16 ;import Data.Map.Strict (Map)
17import qualified Data.Word64Map as W64Map
18 ;import Data.Word64Map (Word64Map)
19
20import Data.Wrapper.PSQ as PSQ
21
22type Priority = POSIXTime
23
24data OptionalPriority t tid x
25 = NoPriority
26 | HasPriority (Priority -> t x -> ([(tid, Priority, x)], t x))
27
28-- | The standard lookup table methods.
29data TableMethods t tid = TableMethods
30 { -- | Insert a new /tid/ entry into the transaction table.
31 tblInsert :: forall a. tid -> a -> Priority -> t a -> t a
32 -- | Delete transaction /tid/ from the transaction table.
33 , tblDelete :: forall a. tid -> t a -> t a
34 -- | Lookup the value associated with transaction /tid/.
35 , tblLookup :: forall a. tid -> t a -> Maybe a
36 }
37
38data QMethods t tid x = QMethods
39 { qTbl :: TableMethods t tid
40 , qAtMostView :: OptionalPriority t tid x
41 }
42
43vanillaTable :: TableMethods t tid -> QMethods t tid x
44vanillaTable tbl = QMethods tbl NoPriority
45
46priorityTable :: TableMethods t tid
47 -> (Priority -> t x -> ([(k, Priority, x)], t x))
48 -> (k -> x -> tid)
49 -> QMethods t tid x
50priorityTable tbl atmost f = QMethods
51 { qTbl = tbl
52 , qAtMostView = HasPriority $ \p t -> case atmost p t of
53 (es,t') -> (map (\(k,p,a) -> (f k a, p, a)) es, t')
54 }
55
56-- | Methods for using 'Data.IntMap'.
57intMapMethods :: TableMethods IntMap Int
58intMapMethods = TableMethods
59 { tblInsert = \tid a p -> IntMap.insert tid a
60 , tblDelete = IntMap.delete
61 , tblLookup = IntMap.lookup
62 }
63
64-- | Methods for using 'Data.Word64Map'.
65w64MapMethods :: TableMethods Word64Map Word64
66w64MapMethods = TableMethods
67 { tblInsert = \tid a p -> W64Map.insert tid a
68 , tblDelete = W64Map.delete
69 , tblLookup = W64Map.lookup
70 }
71
72-- | Methods for using 'Data.Map'
73mapMethods :: Ord tid => TableMethods (Map tid) tid
74mapMethods = TableMethods
75 { tblInsert = \tid a p -> Map.insert tid a
76 , tblDelete = Map.delete
77 , tblLookup = Map.lookup
78 }
79
80-- psqMethods :: PSQKey tid => QMethods (HashPSQ tid Priority) tid x
81psqMethods :: PSQKey k => (tid -> k) -> (k -> x -> tid) -> QMethods (PSQ' k Priority) tid x
82psqMethods g f = priorityTable (contramap g tbl) PSQ.atMostView f
83 where
84 tbl :: PSQKey tid => TableMethods (PSQ' tid Priority) tid
85 tbl = TableMethods
86 { tblInsert = PSQ.insert'
87 , tblDelete = PSQ.delete
88 , tblLookup = \tid t -> case PSQ.lookup tid t of
89 Just (p,a) -> Just a
90 Nothing -> Nothing
91 }
92
93
94-- | Change the key type for a lookup table implementation.
95--
96-- This can be used with 'intMapMethods' or 'mapMethods' to restrict lookups to
97-- only a part of the generated /tid/ value. This is useful for /tid/ types
98-- that are especially large due their use for other purposes, such as secure
99-- nonces for encryption.
100instance Contravariant (TableMethods t) where
101 -- contramap :: (tid -> t1) -> TableMethods t t1 -> TableMethods t tid
102 contramap f (TableMethods ins del lookup) =
103 TableMethods (\k p v t -> ins (f k) p v t)
104 (\k t -> del (f k) t)
105 (\k t -> lookup (f k) t)
diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs
deleted file mode 100644
index 32c709be..00000000
--- a/src/Data/Torrent.hs
+++ /dev/null
@@ -1,1347 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- Torrent file contains metadata about files and folders but not
9-- content itself. The files are bencoded dictionaries. There is
10-- also other info which is used to help join the swarm.
11--
12-- This module provides torrent metainfo serialization and info hash
13-- extraction.
14--
15-- For more info see:
16-- <http://www.bittorrent.org/beps/bep_0003.html#metainfo-files>,
17-- <https://wiki.theory.org/BitTorrentSpecification#Metainfo_File_Structure>
18--
19{-# LANGUAGE CPP #-}
20{-# LANGUAGE NamedFieldPuns #-}
21{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE MultiParamTypeClasses #-}
23{-# LANGUAGE BangPatterns #-}
24{-# LANGUAGE GeneralizedNewtypeDeriving #-}
25{-# LANGUAGE StandaloneDeriving #-}
26{-# LANGUAGE DeriveDataTypeable #-}
27{-# LANGUAGE DeriveFunctor #-}
28{-# LANGUAGE DeriveFoldable #-}
29{-# LANGUAGE DeriveTraversable #-}
30{-# LANGUAGE TemplateHaskell #-}
31{-# OPTIONS -fno-warn-orphans #-}
32module Data.Torrent
33 ( -- * InfoHash
34 -- $infohash
35 InfoHash(..)
36 , textToInfoHash
37 , longHex
38 , shortHex
39
40 -- * File layout
41 -- ** FileInfo
42 , FileOffset
43 , FileSize
44 , FileInfo (..)
45#ifdef USE_lens
46 , fileLength
47 , filePath
48 , fileMD5Sum
49#endif
50
51 -- ** Layout info
52 , LayoutInfo (..)
53#ifdef USE_lens
54 , singleFile
55 , multiFile
56 , rootDirName
57#endif
58 , joinFilePath
59 , isSingleFile
60 , isMultiFile
61 , suggestedName
62 , contentLength
63 , fileCount
64 , blockCount
65
66 -- ** Flat layout info
67 , FileLayout
68 , flatLayout
69 , accumPositions
70 , fileOffset
71
72 -- ** Internal
73 , sizeInBase
74
75 -- * Pieces
76 -- ** Attributes
77 , PieceIx
78 , PieceCount
79 , PieceSize
80 , minPieceSize
81 , maxPieceSize
82 , defaultPieceSize
83 , PieceHash
84
85 -- ** Piece data
86 , Piece (..)
87 , pieceSize
88 , hashPiece
89
90 -- ** Piece control
91 , HashList (..)
92 , PieceInfo (..)
93#ifdef USE_lens
94 , pieceLength
95 , pieceHashes
96#endif
97 , pieceCount
98
99 -- ** Validation
100 , pieceHash
101 , checkPieceLazy
102
103 -- * Info dictionary
104 , InfoDict (..)
105#ifdef USE_lens
106 , infohash
107 , layoutInfo
108 , pieceInfo
109 , isPrivate
110#endif
111#ifdef VERSION_bencoding
112 , infoDictionary
113#endif
114
115 -- * Torrent file
116 , Torrent(..)
117
118#ifdef USE_lens
119 -- ** Lenses
120 , announce
121 , announceList
122 , comment
123 , createdBy
124 , creationDate
125 , encoding
126 , infoDict
127 , publisher
128 , publisherURL
129 , signature
130#endif
131
132 -- ** Utils
133 , nullTorrent
134 , typeTorrent
135 , torrentExt
136 , isTorrentPath
137#ifdef VERSION_bencoding
138 , fromFile
139 , toFile
140#endif
141
142 -- * Magnet
143 -- $magnet-link
144 , Magnet(..)
145 , nullMagnet
146 , simpleMagnet
147 , detailedMagnet
148 , parseMagnet
149 , renderMagnet
150
151 -- ** URN
152 , URN (..)
153 , NamespaceId
154 , btih
155 , infohashURN
156 , parseURN
157 , renderURN
158 ) where
159
160import Prelude hiding ((<>))
161import Control.Applicative
162import Control.DeepSeq
163import Control.Exception
164-- import Control.Lens
165import Control.Monad
166import Crypto.Hash
167#ifdef VERSION_bencoding
168import Data.BEncode as BE
169import Data.BEncode.Types as BE
170#endif
171import Data.Bits
172#ifdef VERSION_bits_extras
173import Data.Bits.Extras
174#endif
175import qualified Data.ByteArray as Bytes
176import Data.ByteString as BS
177import Data.ByteString.Base16 as Base16
178import Data.ByteString.Base32 as Base32
179import Data.ByteString.Base64 as Base64
180import Data.ByteString.Char8 as BC (pack, unpack)
181import Data.ByteString.Lazy as BL
182import Data.Char
183import Data.Convertible
184import Data.Default
185import Data.Hashable as Hashable
186import Data.Int
187import Data.List as L
188import Data.Map as M
189import Data.Maybe
190import Data.Serialize as S
191import Data.String
192import Data.Text as T
193import Data.Text.Encoding as T
194import Data.Text.Read
195import Data.Time.Clock.POSIX
196import Data.Typeable
197import Network (HostName)
198import Network.HTTP.Types.QueryLike
199import Network.HTTP.Types.URI
200import Network.URI
201import Text.ParserCombinators.ReadP as P
202import Text.PrettyPrint as PP
203import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
204import System.FilePath
205import System.Posix.Types
206
207import Network.Address
208
209
210{-----------------------------------------------------------------------
211-- Info hash
212-----------------------------------------------------------------------}
213-- TODO
214--
215-- data Word160 = Word160 {-# UNPACK #-} !Word64
216-- {-# UNPACK #-} !Word64
217-- {-# UNPACK #-} !Word32
218--
219-- newtype InfoHash = InfoHash Word160
220--
221-- reason: bytestring have overhead = 8 words, while infohash have length 20 bytes
222
223-- $infohash
224--
225-- Infohash is a unique identifier of torrent.
226
227-- | Exactly 20 bytes long SHA1 hash of the info part of torrent file.
228newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString }
229 deriving (Eq, Ord, Typeable)
230
231infoHashLen :: Int
232infoHashLen = 20
233
234-- | Meaningless placeholder value.
235instance Default InfoHash where
236 def = "0123456789012345678901234567890123456789"
237
238-- | Hash raw bytes. (no encoding)
239instance Hashable InfoHash where
240 hashWithSalt s (InfoHash ih) = hashWithSalt s ih
241 {-# INLINE hashWithSalt #-}
242
243#ifdef VERSION_bencoding
244-- | Convert to\/from raw bencoded string. (no encoding)
245instance BEncode InfoHash where
246 toBEncode = toBEncode . getInfoHash
247 fromBEncode be = InfoHash <$> fromBEncode be
248#endif
249
250#if 0
251instance TableKey KMessageOf InfoHash where
252 toNodeId = either (error msg) id . S.decode . S.encode
253 where -- TODO unsafe coerse?
254 msg = "tableKey: impossible"
255#endif
256
257
258-- | Convert to\/from raw bytestring. (no encoding)
259instance Serialize InfoHash where
260 put (InfoHash ih) = putByteString ih
261 {-# INLINE put #-}
262
263 get = InfoHash <$> getBytes infoHashLen
264 {-# INLINE get #-}
265
266-- | Convert to raw query value. (no encoding)
267instance QueryValueLike InfoHash where
268 toQueryValue (InfoHash ih) = Just ih
269 {-# INLINE toQueryValue #-}
270
271-- | Convert to base16 encoded string.
272instance Show InfoHash where
273 show (InfoHash ih) = BC.unpack (Base16.encode ih)
274
275-- | Convert to base16 encoded Doc string.
276instance Pretty InfoHash where
277 pPrint = text . show
278
279-- | Read base16 encoded string.
280instance Read InfoHash where
281 readsPrec _ = readP_to_S $ do
282 str <- replicateM (infoHashLen * 2) (satisfy isHexDigit)
283 return $ InfoHash $ decodeIH str
284 where
285 decodeIH = BS.pack . L.map fromHex . pair
286 fromHex (a, b) = read $ '0' : 'x' : a : b : []
287
288 pair (a : b : xs) = (a, b) : pair xs
289 pair _ = []
290
291-- | Convert raw bytes to info hash.
292instance Convertible BS.ByteString InfoHash where
293 safeConvert bs
294 | BS.length bs == infoHashLen = pure (InfoHash bs)
295 | otherwise = convError "invalid length" bs
296
297-- | Parse infohash from base16\/base32\/base64 encoded string.
298instance Convertible Text InfoHash where
299 safeConvert t
300 | 20 == hashLen = pure (InfoHash hashStr)
301 | 26 <= hashLen && hashLen <= 28 =
302 case Base64.decode hashStr of
303 Left msg -> convError ("invalid base64 encoding " ++ msg) t
304 Right ihStr -> safeConvert ihStr
305
306 | hashLen == 32 =
307 case Base32.decode hashStr of
308 Left msg -> convError msg t
309 Right ihStr -> safeConvert ihStr
310
311 | hashLen == 40 =
312 let (ihStr, inv) = Base16.decode hashStr
313 in if BS.length inv /= 0
314 then convError "invalid base16 encoding" t
315 else safeConvert ihStr
316
317 | otherwise = convError "invalid length" t
318 where
319 hashLen = BS.length hashStr
320 hashStr = T.encodeUtf8 t
321
322-- | Decode from base16\/base32\/base64 encoded string.
323instance IsString InfoHash where
324 fromString = either (error . prettyConvertError) id . safeConvert . T.pack
325
326ignoreErrorMsg :: Either a b -> Maybe b
327ignoreErrorMsg = either (const Nothing) Just
328
329-- | Tries both base16 and base32 while decoding info hash.
330--
331-- Use 'safeConvert' for detailed error messages.
332--
333textToInfoHash :: Text -> Maybe InfoHash
334textToInfoHash = ignoreErrorMsg . safeConvert
335
336-- | Hex encode infohash to text, full length.
337longHex :: InfoHash -> Text
338longHex = T.decodeUtf8 . Base16.encode . getInfoHash
339
340-- | The same as 'longHex', but only first 7 characters.
341shortHex :: InfoHash -> Text
342shortHex = T.take 7 . longHex
343
344{-----------------------------------------------------------------------
345-- File info
346-----------------------------------------------------------------------}
347
348-- | Size of a file in bytes.
349type FileSize = FileOffset
350
351#ifdef VERSION_bencoding
352deriving instance BEncode FileOffset
353#endif
354
355-- | Contain metainfo about one single file.
356data FileInfo a = FileInfo {
357 fiLength :: {-# UNPACK #-} !FileSize
358 -- ^ Length of the file in bytes.
359
360 -- TODO unpacked MD5 sum
361 , fiMD5Sum :: !(Maybe BS.ByteString)
362 -- ^ 32 character long MD5 sum of the file. Used by third-party
363 -- tools, not by bittorrent protocol itself.
364
365 , fiName :: !a
366 -- ^ One or more string elements that together represent the
367 -- path and filename. Each element in the list corresponds to
368 -- either a directory name or (in the case of the last element)
369 -- the filename. For example, the file:
370 --
371 -- > "dir1/dir2/file.ext"
372 --
373 -- would consist of three string elements:
374 --
375 -- > ["dir1", "dir2", "file.ext"]
376 --
377 } deriving (Show, Read, Eq, Typeable
378 , Functor, Foldable
379 )
380
381#ifdef USE_lens
382makeLensesFor
383 [ ("fiLength", "fileLength")
384 , ("fiMD5Sum", "fileMD5Sum")
385 , ("fiName" , "filePath" )
386 ]
387 ''FileInfo
388#endif
389
390instance NFData a => NFData (FileInfo a) where
391 rnf FileInfo {..} = rnf fiName
392 {-# INLINE rnf #-}
393
394#ifdef VERSION_bencoding
395instance BEncode (FileInfo [BS.ByteString]) where
396 toBEncode FileInfo {..} = toDict $
397 "length" .=! fiLength
398 .: "md5sum" .=? fiMD5Sum
399 .: "path" .=! fiName
400 .: endDict
401 {-# INLINE toBEncode #-}
402
403 fromBEncode = fromDict $ do
404 FileInfo <$>! "length"
405 <*>? "md5sum"
406 <*>! "path"
407 {-# INLINE fromBEncode #-}
408
409type Put a = a -> BDict -> BDict
410#endif
411
412#ifdef VERSION_bencoding
413putFileInfoSingle :: Data.Torrent.Put (FileInfo BS.ByteString)
414putFileInfoSingle FileInfo {..} cont =
415 "length" .=! fiLength
416 .: "md5sum" .=? fiMD5Sum
417 .: "name" .=! fiName
418 .: cont
419
420getFileInfoSingle :: BE.Get (FileInfo BS.ByteString)
421getFileInfoSingle = do
422 FileInfo <$>! "length"
423 <*>? "md5sum"
424 <*>! "name"
425
426instance BEncode (FileInfo BS.ByteString) where
427 toBEncode = toDict . (`putFileInfoSingle` endDict)
428 {-# INLINE toBEncode #-}
429
430 fromBEncode = fromDict getFileInfoSingle
431 {-# INLINE fromBEncode #-}
432#endif
433
434instance Pretty (FileInfo BS.ByteString) where
435 pPrint FileInfo {..} =
436 "Path: " <> text (T.unpack (T.decodeUtf8 fiName))
437 $$ "Size: " <> text (show fiLength)
438 $$ maybe PP.empty ppMD5 fiMD5Sum
439 where
440 ppMD5 md5 = "MD5 : " <> text (show (Base16.encode md5))
441
442-- | Join file path.
443joinFilePath :: FileInfo [BS.ByteString] -> FileInfo BS.ByteString
444joinFilePath = fmap (BS.intercalate "/")
445
446{-----------------------------------------------------------------------
447-- Layout info
448-----------------------------------------------------------------------}
449
450-- | Original (found in torrent file) layout info is either:
451--
452-- * Single file with its /name/.
453--
454-- * Multiple files with its relative file /paths/.
455--
456data LayoutInfo
457 = SingleFile
458 { -- | Single file info.
459 liFile :: !(FileInfo BS.ByteString)
460 }
461 | MultiFile
462 { -- | List of the all files that torrent contains.
463 liFiles :: ![FileInfo [BS.ByteString]]
464
465 -- | The /suggested/ name of the root directory in which to
466 -- store all the files.
467 , liDirName :: !BS.ByteString
468 } deriving (Show, Read, Eq, Typeable)
469
470#ifdef USE_lens
471makeLensesFor
472 [ ("liFile" , "singleFile" )
473 , ("liFiles" , "multiFile" )
474 , ("liDirName", "rootDirName")
475 ]
476 ''LayoutInfo
477#endif
478
479instance NFData LayoutInfo where
480 rnf SingleFile {..} = ()
481 rnf MultiFile {..} = rnf liFiles
482
483-- | Empty multifile layout.
484instance Default LayoutInfo where
485 def = MultiFile [] ""
486
487#ifdef VERSION_bencoding
488getLayoutInfo :: BE.Get LayoutInfo
489getLayoutInfo = single <|> multi
490 where
491 single = SingleFile <$> getFileInfoSingle
492 multi = MultiFile <$>! "files" <*>! "name"
493
494putLayoutInfo :: Data.Torrent.Put LayoutInfo
495putLayoutInfo SingleFile {..} = putFileInfoSingle liFile
496putLayoutInfo MultiFile {..} = \ cont ->
497 "files" .=! liFiles
498 .: "name" .=! liDirName
499 .: cont
500
501instance BEncode LayoutInfo where
502 toBEncode = toDict . (`putLayoutInfo` endDict)
503 fromBEncode = fromDict getLayoutInfo
504#endif
505
506instance Pretty LayoutInfo where
507 pPrint SingleFile {..} = pPrint liFile
508 pPrint MultiFile {..} = vcat $ L.map (pPrint . joinFilePath) liFiles
509
510-- | Test if this is single file torrent.
511isSingleFile :: LayoutInfo -> Bool
512isSingleFile SingleFile {} = True
513isSingleFile _ = False
514{-# INLINE isSingleFile #-}
515
516-- | Test if this is multifile torrent.
517isMultiFile :: LayoutInfo -> Bool
518isMultiFile MultiFile {} = True
519isMultiFile _ = False
520{-# INLINE isMultiFile #-}
521
522-- | Get name of the torrent based on the root path piece.
523suggestedName :: LayoutInfo -> BS.ByteString
524suggestedName (SingleFile FileInfo {..}) = fiName
525suggestedName MultiFile {..} = liDirName
526{-# INLINE suggestedName #-}
527
528-- | Find sum of sizes of the all torrent files.
529contentLength :: LayoutInfo -> FileSize
530contentLength SingleFile { liFile = FileInfo {..} } = fiLength
531contentLength MultiFile { liFiles = tfs } = L.sum (L.map fiLength tfs)
532
533-- | Get number of all files in torrent.
534fileCount :: LayoutInfo -> Int
535fileCount SingleFile {..} = 1
536fileCount MultiFile {..} = L.length liFiles
537
538-- | Find number of blocks of the specified size. If torrent size is
539-- not a multiple of block size then the count is rounded up.
540blockCount :: Int -> LayoutInfo -> Int
541blockCount blkSize ci = contentLength ci `sizeInBase` blkSize
542
543------------------------------------------------------------------------
544
545-- | File layout specifies the order and the size of each file in the
546-- storage. Note that order of files is highly important since we
547-- coalesce all the files in the given order to get the linear block
548-- address space.
549--
550type FileLayout a = [(FilePath, a)]
551
552-- | Extract files layout from torrent info with the given root path.
553flatLayout
554 :: FilePath -- ^ Root path for the all torrent files.
555 -> LayoutInfo -- ^ Torrent content information.
556 -> FileLayout FileSize -- ^ The all file paths prefixed with the given root.
557flatLayout prefixPath SingleFile { liFile = FileInfo {..} }
558 = [(prefixPath </> BC.unpack fiName, fiLength)]
559flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles
560 where -- TODO use utf8 encoding in name
561 mkPath FileInfo {..} = (_path, fiLength)
562 where
563 _path = prefixPath </> BC.unpack liDirName
564 </> joinPath (L.map BC.unpack fiName)
565
566-- | Calculate offset of each file based on its length, incrementally.
567accumPositions :: FileLayout FileSize -> FileLayout (FileOffset, FileSize)
568accumPositions = go 0
569 where
570 go !_ [] = []
571 go !offset ((n, s) : xs) = (n, (offset, s)) : go (offset + s) xs
572
573-- | Gives global offset of a content file for a given full path.
574fileOffset :: FilePath -> FileLayout FileOffset -> Maybe FileOffset
575fileOffset = L.lookup
576{-# INLINE fileOffset #-}
577
578------------------------------------------------------------------------
579
580-- | Divide and round up.
581sizeInBase :: Integral a => a -> Int -> Int
582sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align
583 where
584 align = if n `mod` fromIntegral b == 0 then 0 else 1
585{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-}
586{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-}
587
588{-----------------------------------------------------------------------
589-- Piece attributes
590-----------------------------------------------------------------------}
591
592-- | Zero-based index of piece in torrent content.
593type PieceIx = Int
594
595-- | Size of piece in bytes. Should be a power of 2.
596--
597-- NOTE: Have max and min size constrained to wide used
598-- semi-standard values. This bounds should be used to make decision
599-- about piece size for new torrents.
600--
601type PieceSize = Int
602
603-- | Number of pieces in torrent or a part of torrent.
604type PieceCount = Int
605
606defaultBlockSize :: Int
607defaultBlockSize = 16 * 1024
608
609-- | Optimal number of pieces in torrent.
610optimalPieceCount :: PieceCount
611optimalPieceCount = 1000
612{-# INLINE optimalPieceCount #-}
613
614-- | Piece size should not be less than this value.
615minPieceSize :: Int
616minPieceSize = defaultBlockSize * 4
617{-# INLINE minPieceSize #-}
618
619-- | To prevent transfer degradation piece size should not exceed this
620-- value.
621maxPieceSize :: Int
622maxPieceSize = 4 * 1024 * 1024
623{-# INLINE maxPieceSize #-}
624
625toPow2 :: Int -> Int
626#ifdef VERSION_bits_extras
627toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x)
628#else
629toPow2 x = bit $ fromIntegral (countLeadingZeros (0 :: Int) - countLeadingZeros x)
630#endif
631
632-- | Find the optimal piece size for a given torrent size.
633defaultPieceSize :: Int64 -> Int
634defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc
635 where
636 pc = fromIntegral (x `div` fromIntegral optimalPieceCount)
637
638{-----------------------------------------------------------------------
639-- Piece data
640-----------------------------------------------------------------------}
641
642type PieceHash = BS.ByteString
643
644hashsize :: Int
645hashsize = 20
646{-# INLINE hashsize #-}
647
648-- TODO check if pieceLength is power of 2
649-- | Piece payload should be strict or lazy bytestring.
650data Piece a = Piece
651 { -- | Zero-based piece index in torrent.
652 pieceIndex :: {-# UNPACK #-} !PieceIx
653
654 -- | Payload.
655 , pieceData :: !a
656 } deriving (Show, Read, Eq, Functor, Typeable)
657
658instance NFData a => NFData (Piece a) where
659 rnf (Piece a b) = rnf a `seq` rnf b
660
661-- | Payload bytes are omitted.
662instance Pretty (Piece a) where
663 pPrint Piece {..} = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex)
664
665-- | Get size of piece in bytes.
666pieceSize :: Piece BL.ByteString -> PieceSize
667pieceSize Piece {..} = fromIntegral (BL.length pieceData)
668
669-- | Get piece hash.
670hashPiece :: Piece BL.ByteString -> PieceHash
671hashPiece Piece {..} = Bytes.convert (hashlazy pieceData :: Digest SHA1)
672
673{-----------------------------------------------------------------------
674-- Piece control
675-----------------------------------------------------------------------}
676
677-- | A flat array of SHA1 hash for each piece.
678newtype HashList = HashList { unHashList :: BS.ByteString }
679 deriving ( Show, Read, Eq, Typeable
680#ifdef VERSION_bencoding
681 , BEncode
682#endif
683 )
684
685-- | Empty hash list.
686instance Default HashList where
687 def = HashList ""
688
689-- | Part of torrent file used for torrent content validation.
690data PieceInfo = PieceInfo
691 { piPieceLength :: {-# UNPACK #-} !PieceSize
692 -- ^ Number of bytes in each piece.
693
694 , piPieceHashes :: !HashList
695 -- ^ Concatenation of all 20-byte SHA1 hash values.
696 } deriving (Show, Read, Eq, Typeable)
697
698#ifdef USE_lens
699-- | Number of bytes in each piece.
700makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo
701
702-- | Concatenation of all 20-byte SHA1 hash values.
703makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo
704#endif
705
706instance NFData PieceInfo where
707 rnf (PieceInfo a (HashList b)) = rnf a `seq` rnf b
708
709instance Default PieceInfo where
710 def = PieceInfo 1 def
711
712
713#ifdef VERSION_bencoding
714putPieceInfo :: Data.Torrent.Put PieceInfo
715putPieceInfo PieceInfo {..} cont =
716 "piece length" .=! piPieceLength
717 .: "pieces" .=! piPieceHashes
718 .: cont
719
720getPieceInfo :: BE.Get PieceInfo
721getPieceInfo = do
722 PieceInfo <$>! "piece length"
723 <*>! "pieces"
724
725instance BEncode PieceInfo where
726 toBEncode = toDict . (`putPieceInfo` endDict)
727 fromBEncode = fromDict getPieceInfo
728#endif
729
730-- | Hashes are omitted.
731instance Pretty PieceInfo where
732 pPrint PieceInfo {..} = "Piece size: " <> int piPieceLength
733
734slice :: Int -> Int -> BS.ByteString -> BS.ByteString
735slice start len = BS.take len . BS.drop start
736{-# INLINE slice #-}
737
738-- | Extract validation hash by specified piece index.
739pieceHash :: PieceInfo -> PieceIx -> PieceHash
740pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashList piPieceHashes)
741
742-- | Find count of pieces in the torrent. If torrent size is not a
743-- multiple of piece size then the count is rounded up.
744pieceCount :: PieceInfo -> PieceCount
745pieceCount PieceInfo {..} = BS.length (unHashList piPieceHashes) `quot` hashsize
746
747-- | Test if this is last piece in torrent content.
748isLastPiece :: PieceInfo -> PieceIx -> Bool
749isLastPiece ci i = pieceCount ci == succ i
750
751-- | Validate piece with metainfo hash.
752checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool
753checkPieceLazy pinfo @ PieceInfo {..} Piece {..}
754 = (fromIntegral (BL.length pieceData) == piPieceLength
755 || isLastPiece pinfo pieceIndex)
756 && Bytes.convert (hashlazy pieceData :: Digest SHA1) == pieceHash pinfo pieceIndex
757
758{-----------------------------------------------------------------------
759-- Info dictionary
760-----------------------------------------------------------------------}
761
762{- note that info hash is actually reduntant field
763 but it's better to keep it here to avoid heavy recomputations
764-}
765
766-- | Info part of the .torrent file contain info about each content file.
767data InfoDict = InfoDict
768 { idInfoHash :: !InfoHash
769 -- ^ SHA1 hash of the (other) 'DictInfo' fields.
770
771 , idLayoutInfo :: !LayoutInfo
772 -- ^ File layout (name, size, etc) information.
773
774 , idPieceInfo :: !PieceInfo
775 -- ^ Content validation information.
776
777 , idPrivate :: !Bool
778 -- ^ If set the client MUST publish its presence to get other
779 -- peers ONLY via the trackers explicity described in the
780 -- metainfo file.
781 --
782 -- BEP 27: <http://www.bittorrent.org/beps/bep_0027.html>
783 } deriving (Show, Read, Eq, Typeable)
784
785#ifdef VERISON_lens
786makeLensesFor
787 [ ("idInfoHash" , "infohash" )
788 , ("idLayoutInfo", "layoutInfo")
789 , ("idPieceInfo" , "pieceInfo" )
790 , ("idPrivate" , "isPrivate" )
791 ]
792 ''InfoDict
793#endif
794
795instance NFData InfoDict where
796 rnf InfoDict {..} = rnf idLayoutInfo
797
798instance Hashable InfoDict where
799 hashWithSalt = Hashable.hashUsing idInfoHash
800 {-# INLINE hashWithSalt #-}
801
802-- | Hash lazy bytestring using SHA1 algorithm.
803hashLazyIH :: BL.ByteString -> InfoHash
804hashLazyIH = either (const (error msg)) id . safeConvert . (Bytes.convert :: Digest SHA1 -> BS.ByteString) . hashlazy
805 where
806 msg = "Infohash.hash: impossible: SHA1 is always 20 bytes long"
807
808#ifdef VERSION_bencoding
809-- | Empty info dictionary with zero-length content.
810instance Default InfoDict where
811 def = infoDictionary def def False
812
813-- | Smart constructor: add a info hash to info dictionary.
814infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict
815infoDictionary li pinfo private = InfoDict ih li pinfo private
816 where
817 ih = hashLazyIH $ BE.encode $ InfoDict def li pinfo private
818
819getPrivate :: BE.Get Bool
820getPrivate = (Just True ==) <$>? "private"
821
822putPrivate :: Bool -> BDict -> BDict
823putPrivate False = id
824putPrivate True = \ cont -> "private" .=! True .: cont
825
826instance BEncode InfoDict where
827 toBEncode InfoDict {..} = toDict $
828 putLayoutInfo idLayoutInfo $
829 putPieceInfo idPieceInfo $
830 putPrivate idPrivate $
831 endDict
832
833 fromBEncode dict = (`fromDict` dict) $ do
834 InfoDict ih <$> getLayoutInfo
835 <*> getPieceInfo
836 <*> getPrivate
837 where
838 ih = hashLazyIH (BE.encode dict)
839#endif
840
841ppPrivacy :: Bool -> Doc
842ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public"
843
844--ppAdditionalInfo :: InfoDict -> Doc
845--ppAdditionalInfo layout = PP.empty
846
847instance Pretty InfoDict where
848 pPrint InfoDict {..} =
849 pPrint idLayoutInfo $$
850 pPrint idPieceInfo $$
851 ppPrivacy idPrivate
852
853{-----------------------------------------------------------------------
854-- Torrent info
855-----------------------------------------------------------------------}
856-- TODO add torrent file validation
857
858-- | Metainfo about particular torrent.
859data Torrent = Torrent
860 { tAnnounce :: !(Maybe URI)
861 -- ^ The URL of the tracker.
862
863 , tAnnounceList :: !(Maybe [[URI]])
864 -- ^ Announce list add multiple tracker support.
865 --
866 -- BEP 12: <http://www.bittorrent.org/beps/bep_0012.html>
867
868 , tComment :: !(Maybe Text)
869 -- ^ Free-form comments of the author.
870
871 , tCreatedBy :: !(Maybe Text)
872 -- ^ Name and version of the program used to create the .torrent.
873
874 , tCreationDate :: !(Maybe POSIXTime)
875 -- ^ Creation time of the torrent, in standard UNIX epoch.
876
877 , tEncoding :: !(Maybe Text)
878 -- ^ String encoding format used to generate the pieces part of
879 -- the info dictionary in the .torrent metafile.
880
881 , tInfoDict :: !InfoDict
882 -- ^ Info about each content file.
883
884 , tNodes :: !(Maybe [NodeAddr HostName])
885 -- ^ This key should be set to the /K closest/ nodes in the
886 -- torrent generating client's routing table. Alternatively, the
887 -- key could be set to a known good 'Network.Address.Node'
888 -- such as one operated by the person generating the torrent.
889 --
890 -- Please do not automatically add \"router.bittorrent.com\" to
891 -- this list because different bittorrent software may prefer to
892 -- use different bootstrap node.
893
894 , tPublisher :: !(Maybe URI)
895 -- ^ Containing the RSA public key of the publisher of the
896 -- torrent. Private counterpart of this key that has the
897 -- authority to allow new peers onto the swarm.
898
899 , tPublisherURL :: !(Maybe URI)
900 , tSignature :: !(Maybe BS.ByteString)
901 -- ^ The RSA signature of the info dictionary (specifically, the
902 -- encrypted SHA-1 hash of the info dictionary).
903 } deriving (Show, Eq, Typeable)
904
905#ifdef USE_lens
906makeLensesFor
907 [ ("tAnnounce" , "announce" )
908 , ("tAnnounceList", "announceList")
909 , ("tComment" , "comment" )
910 , ("tCreatedBy" , "createdBy" )
911 , ("tCreationDate", "creationDate")
912 , ("tEncoding" , "encoding" )
913 , ("tInfoDict" , "infoDict" )
914 , ("tPublisher" , "publisher" )
915 , ("tPublisherURL", "publisherURL")
916 , ("tSignature" , "signature" )
917 ]
918 ''Torrent
919#endif
920
921instance NFData Torrent where
922 rnf Torrent {..} = rnf tInfoDict
923
924#ifdef VERSION_bencoding
925-- TODO move to bencoding
926instance BEncode URI where
927 toBEncode uri = toBEncode (BC.pack (uriToString id uri ""))
928 {-# INLINE toBEncode #-}
929
930 fromBEncode (BString s) | Just url <- parseURI (BC.unpack s) = return url
931 fromBEncode b = decodingError $ "url <" ++ show b ++ ">"
932 {-# INLINE fromBEncode #-}
933
934--pico2uni :: Pico -> Uni
935--pico2uni = undefined
936
937-- TODO move to bencoding
938instance BEncode POSIXTime where
939 toBEncode pt = toBEncode (floor pt :: Integer)
940 fromBEncode (BInteger i) = return $ fromIntegral i
941 fromBEncode _ = decodingError $ "POSIXTime"
942
943-- TODO to bencoding package
944instance {-# OVERLAPPING #-} BEncode String where
945 toBEncode = toBEncode . T.pack
946 fromBEncode v = T.unpack <$> fromBEncode v
947
948instance BEncode Torrent where
949 toBEncode Torrent {..} = toDict $
950 "announce" .=? tAnnounce
951 .: "announce-list" .=? tAnnounceList
952 .: "comment" .=? tComment
953 .: "created by" .=? tCreatedBy
954 .: "creation date" .=? tCreationDate
955 .: "encoding" .=? tEncoding
956 .: "info" .=! tInfoDict
957 .: "nodes" .=? tNodes
958 .: "publisher" .=? tPublisher
959 .: "publisher-url" .=? tPublisherURL
960 .: "signature" .=? tSignature
961 .: endDict
962
963 fromBEncode = fromDict $ do
964 Torrent <$>? "announce"
965 <*>? "announce-list"
966 <*>? "comment"
967 <*>? "created by"
968 <*>? "creation date"
969 <*>? "encoding"
970 <*>! "info"
971 <*>? "nodes"
972 <*>? "publisher"
973 <*>? "publisher-url"
974 <*>? "signature"
975#endif
976
977(<:>) :: Doc -> Doc -> Doc
978name <:> v = name <> ":" <+> v
979
980(<:>?) :: Doc -> Maybe Doc -> Doc
981_ <:>? Nothing = PP.empty
982name <:>? (Just d) = name <:> d
983
984instance Pretty Torrent where
985 pPrint Torrent {..} =
986 "InfoHash: " <> pPrint (idInfoHash tInfoDict)
987 $$ hang "General" 4 generalInfo
988 $$ hang "Tracker" 4 trackers
989 $$ pPrint tInfoDict
990 where
991 trackers = case tAnnounceList of
992 Nothing -> text (show tAnnounce)
993 Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs
994 where
995 ppTier (n, xs) = "Tier #" <> int n <:> vcat (L.map (text . show) xs)
996
997 generalInfo =
998 "Comment" <:>? ((text . T.unpack) <$> tComment) $$
999 "Created by" <:>? ((text . T.unpack) <$> tCreatedBy) $$
1000 "Created on" <:>? ((text . show . posixSecondsToUTCTime)
1001 <$> tCreationDate) $$
1002 "Encoding" <:>? ((text . T.unpack) <$> tEncoding) $$
1003 "Publisher" <:>? ((text . show) <$> tPublisher) $$
1004 "Publisher URL" <:>? ((text . show) <$> tPublisherURL) $$
1005 "Signature" <:>? ((text . show) <$> tSignature)
1006
1007#ifdef VERSION_bencoding
1008-- | No files, no trackers, no nodes, etc...
1009instance Default Torrent where
1010 def = nullTorrent def
1011#endif
1012
1013-- | A simple torrent contains only required fields.
1014nullTorrent :: InfoDict -> Torrent
1015nullTorrent info = Torrent
1016 Nothing Nothing Nothing Nothing Nothing Nothing
1017 info Nothing Nothing Nothing Nothing
1018
1019-- | Mime type of torrent files.
1020typeTorrent :: BS.ByteString
1021typeTorrent = "application/x-bittorrent"
1022
1023-- | Extension usually used for torrent files.
1024torrentExt :: String
1025torrentExt = "torrent"
1026
1027-- | Test if this path has proper extension.
1028isTorrentPath :: FilePath -> Bool
1029isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt
1030
1031#ifdef VERSION_bencoding
1032-- | Read and decode a .torrent file.
1033fromFile :: FilePath -> IO Torrent
1034fromFile filepath = do
1035 contents <- BS.readFile filepath
1036 case BE.decode contents of
1037 Right !t -> return t
1038 Left msg -> throwIO $ userError $ msg ++ " while reading torrent file"
1039
1040-- | Encode and write a .torrent file.
1041toFile :: FilePath -> Torrent -> IO ()
1042toFile filepath = BL.writeFile filepath . BE.encode
1043#endif
1044
1045{-----------------------------------------------------------------------
1046-- URN
1047-----------------------------------------------------------------------}
1048
1049-- | Namespace identifier determines the syntactic interpretation of
1050-- namespace-specific string.
1051type NamespaceId = [Text]
1052
1053-- | BitTorrent Info Hash (hence the name) namespace
1054-- identifier. Namespace-specific string /should/ be a base16\/base32
1055-- encoded SHA1 hash of the corresponding torrent /info/ dictionary.
1056--
1057btih :: NamespaceId
1058btih = ["btih"]
1059
1060-- | URN is pesistent location-independent identifier for
1061-- resources. In particular, URNs are used represent torrent names
1062-- as a part of magnet link, see 'Data.Torrent.Magnet.Magnet' for
1063-- more info.
1064--
1065data URN = URN
1066 { urnNamespace :: NamespaceId -- ^ a namespace identifier;
1067 , urnString :: Text -- ^ a corresponding
1068 -- namespace-specific string.
1069 } deriving (Eq, Ord, Typeable)
1070
1071-----------------------------------------------------------------------
1072
1073instance Convertible URN InfoHash where
1074 safeConvert u @ URN {..}
1075 | urnNamespace /= btih = convError "invalid namespace" u
1076 | otherwise = safeConvert urnString
1077
1078-- | Make resource name for torrent with corresponding
1079-- infohash. Infohash is base16 (hex) encoded.
1080--
1081infohashURN :: InfoHash -> URN
1082infohashURN = URN btih . longHex
1083
1084-- | Meaningless placeholder value.
1085instance Default URN where
1086 def = infohashURN def
1087
1088------------------------------------------------------------------------
1089
1090-- | Render URN to its text representation.
1091renderURN :: URN -> Text
1092renderURN URN {..}
1093 = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString]
1094
1095instance Pretty URN where
1096 pPrint = text . T.unpack . renderURN
1097
1098instance Show URN where
1099 showsPrec n = showsPrec n . T.unpack . renderURN
1100
1101instance QueryValueLike URN where
1102 toQueryValue = toQueryValue . renderURN
1103 {-# INLINE toQueryValue #-}
1104
1105-----------------------------------------------------------------------
1106
1107_unsnoc :: [a] -> Maybe ([a], a)
1108_unsnoc [] = Nothing
1109_unsnoc xs = Just (L.init xs, L.last xs)
1110
1111instance Convertible Text URN where
1112 safeConvert t = case T.split (== ':') t of
1113 uriScheme : body
1114 | T.toLower uriScheme == "urn" ->
1115 case _unsnoc body of
1116 Just (namespace, val) -> pure URN
1117 { urnNamespace = namespace
1118 , urnString = val
1119 }
1120 Nothing -> convError "missing URN string" body
1121 | otherwise -> convError "invalid URN scheme" uriScheme
1122 [] -> convError "missing URN scheme" t
1123
1124instance IsString URN where
1125 fromString = either (error . prettyConvertError) id
1126 . safeConvert . T.pack
1127
1128-- | Try to parse an URN from its text representation.
1129--
1130-- Use 'safeConvert' for detailed error messages.
1131--
1132parseURN :: Text -> Maybe URN
1133parseURN = either (const Nothing) pure . safeConvert
1134
1135{-----------------------------------------------------------------------
1136-- Magnet
1137-----------------------------------------------------------------------}
1138-- $magnet-link
1139--
1140-- Magnet URI scheme is an standard defining Magnet links. Magnet
1141-- links are refer to resources by hash, in particular magnet links
1142-- can refer to torrent using corresponding infohash. In this way,
1143-- magnet links can be used instead of torrent files.
1144--
1145-- This module provides bittorrent specific implementation of magnet
1146-- links.
1147--
1148-- For generic magnet uri scheme see:
1149-- <http://magnet-uri.sourceforge.net/magnet-draft-overview.txt>,
1150-- <http://www.iana.org/assignments/uri-schemes/prov/magnet>
1151--
1152-- Bittorrent specific details:
1153-- <http://www.bittorrent.org/beps/bep_0009.html>
1154--
1155
1156-- TODO multiple exact topics
1157-- TODO render/parse supplement for URI/query
1158
1159-- | An URI used to identify torrent.
1160data Magnet = Magnet
1161 { -- | Torrent infohash hash. Can be used in DHT queries if no
1162 -- 'tracker' provided.
1163 exactTopic :: !InfoHash -- TODO InfoHash -> URN?
1164
1165 -- | A filename for the file to download. Can be used to
1166 -- display name while waiting for metadata.
1167 , displayName :: Maybe Text
1168
1169 -- | Size of the resource in bytes.
1170 , exactLength :: Maybe Integer
1171
1172 -- | URI pointing to manifest, e.g. a list of further items.
1173 , manifest :: Maybe Text
1174
1175 -- | Search string.
1176 , keywordTopic :: Maybe Text
1177
1178 -- | A source to be queried after not being able to find and
1179 -- download the file in the bittorrent network in a defined
1180 -- amount of time.
1181 , acceptableSource :: Maybe URI
1182
1183 -- | Direct link to the resource.
1184 , exactSource :: Maybe URI
1185
1186 -- | URI to the tracker.
1187 , tracker :: Maybe URI
1188
1189 -- | Additional or experimental parameters.
1190 , supplement :: Map Text Text
1191 } deriving (Eq, Ord, Typeable)
1192
1193instance QueryValueLike Integer where
1194 toQueryValue = toQueryValue . show
1195
1196instance QueryValueLike URI where
1197 toQueryValue = toQueryValue . show
1198
1199instance QueryLike Magnet where
1200 toQuery Magnet {..} =
1201 [ ("xt", toQueryValue $ infohashURN exactTopic)
1202 , ("dn", toQueryValue displayName)
1203 , ("xl", toQueryValue exactLength)
1204 , ("mt", toQueryValue manifest)
1205 , ("kt", toQueryValue keywordTopic)
1206 , ("as", toQueryValue acceptableSource)
1207 , ("xs", toQueryValue exactSource)
1208 , ("tr", toQueryValue tracker)
1209 ]
1210
1211instance QueryValueLike Magnet where
1212 toQueryValue = toQueryValue . renderMagnet
1213
1214instance Convertible QueryText Magnet where
1215 safeConvert xs = do
1216 urnStr <- getTextMsg "xt" "exact topic not defined" xs
1217 infoHash <- convertVia (error "safeConvert" :: URN) urnStr
1218 return Magnet
1219 { exactTopic = infoHash
1220 , displayName = getText "dn" xs
1221 , exactLength = getText "xl" xs >>= getInt
1222 , manifest = getText "mt" xs
1223 , keywordTopic = getText "kt" xs
1224 , acceptableSource = getText "as" xs >>= getURI
1225 , exactSource = getText "xs" xs >>= getURI
1226 , tracker = getText "tr" xs >>= getURI
1227 , supplement = M.empty
1228 }
1229 where
1230 getInt = either (const Nothing) (Just . fst) . signed decimal
1231 getURI = parseURI . T.unpack
1232 getText p = join . L.lookup p
1233 getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps
1234
1235magnetScheme :: URI
1236magnetScheme = URI
1237 { uriScheme = "magnet:"
1238 , uriAuthority = Nothing
1239 , uriPath = ""
1240 , uriQuery = ""
1241 , uriFragment = ""
1242 }
1243
1244isMagnetURI :: URI -> Bool
1245isMagnetURI u = u { uriQuery = "" } == magnetScheme
1246
1247-- | Can be used instead of 'parseMagnet'.
1248instance Convertible URI Magnet where
1249 safeConvert u @ URI {..}
1250 | not (isMagnetURI u) = convError "this is not a magnet link" u
1251 | otherwise = safeConvert $ parseQueryText $ BC.pack uriQuery
1252
1253-- | Can be used instead of 'renderMagnet'.
1254instance Convertible Magnet URI where
1255 safeConvert m = pure $ magnetScheme
1256 { uriQuery = BC.unpack $ renderQuery True $ toQuery m }
1257
1258instance Convertible String Magnet where
1259 safeConvert str
1260 | Just uri <- parseURI str = safeConvert uri
1261 | otherwise = convError "unable to parse uri" str
1262
1263------------------------------------------------------------------------
1264
1265-- | Meaningless placeholder value.
1266instance Default Magnet where
1267 def = Magnet
1268 { exactTopic = def
1269 , displayName = Nothing
1270 , exactLength = Nothing
1271 , manifest = Nothing
1272 , keywordTopic = Nothing
1273 , acceptableSource = Nothing
1274 , exactSource = Nothing
1275 , tracker = Nothing
1276 , supplement = M.empty
1277 }
1278
1279-- | Set 'exactTopic' ('xt' param) only, other params are empty.
1280nullMagnet :: InfoHash -> Magnet
1281nullMagnet u = Magnet
1282 { exactTopic = u
1283 , displayName = Nothing
1284 , exactLength = Nothing
1285 , manifest = Nothing
1286 , keywordTopic = Nothing
1287 , acceptableSource = Nothing
1288 , exactSource = Nothing
1289 , tracker = Nothing
1290 , supplement = M.empty
1291 }
1292
1293-- | Like 'nullMagnet' but also include 'displayName' ('dn' param).
1294simpleMagnet :: Torrent -> Magnet
1295simpleMagnet Torrent {tInfoDict = InfoDict {..}}
1296 = (nullMagnet idInfoHash)
1297 { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo
1298 }
1299
1300-- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and
1301-- 'tracker' ('tr' param).
1302--
1303detailedMagnet :: Torrent -> Magnet
1304detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce}
1305 = (simpleMagnet t)
1306 { exactLength = Just $ fromIntegral $ contentLength idLayoutInfo
1307 , tracker = tAnnounce
1308 }
1309
1310-----------------------------------------------------------------------
1311
1312parseMagnetStr :: String -> Maybe Magnet
1313parseMagnetStr = either (const Nothing) Just . safeConvert
1314
1315renderMagnetStr :: Magnet -> String
1316renderMagnetStr = show . (convert :: Magnet -> URI)
1317
1318instance Pretty Magnet where
1319 pPrint = PP.text . renderMagnetStr
1320
1321instance Show Magnet where
1322 show = renderMagnetStr
1323 {-# INLINE show #-}
1324
1325instance Read Magnet where
1326 readsPrec _ xs
1327 | Just m <- parseMagnetStr mstr = [(m, rest)]
1328 | otherwise = []
1329 where
1330 (mstr, rest) = L.break (== ' ') xs
1331
1332instance IsString Magnet where
1333 fromString str = fromMaybe (error msg) $ parseMagnetStr str
1334 where
1335 msg = "unable to parse magnet: " ++ str
1336
1337-- | Try to parse magnet link from urlencoded string. Use
1338-- 'safeConvert' to find out error location.
1339--
1340parseMagnet :: Text -> Maybe Magnet
1341parseMagnet = parseMagnetStr . T.unpack
1342{-# INLINE parseMagnet #-}
1343
1344-- | Render magnet link to urlencoded string
1345renderMagnet :: Magnet -> Text
1346renderMagnet = T.pack . renderMagnetStr
1347{-# INLINE renderMagnet #-}
diff --git a/src/Data/Tox/Message.hs b/src/Data/Tox/Message.hs
deleted file mode 100644
index 9f1ce339..00000000
--- a/src/Data/Tox/Message.hs
+++ /dev/null
@@ -1,84 +0,0 @@
1-- | This module assigns meaningful symbolic names to Tox message ids and
2-- classifies messages as lossy or lossless.
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE ViewPatterns #-}
6module Data.Tox.Message where
7
8import Data.Word
9
10-- | The one-byte type code prefix that classifies a 'CryptoMessage'.
11newtype MessageID = MessageID Word8 deriving (Eq,Enum,Ord,Bounded)
12pattern Padding = MessageID 0 -- ^ 0 padding (skipped until we hit a non zero (data id) byte)
13pattern PacketRequest = MessageID 1 -- ^ 1 packet request packet (lossy packet)
14pattern KillPacket = MessageID 2 -- ^ 2 connection kill packet (lossy packet)
15pattern UnspecifiedPacket003 = MessageID 3 -- ^ 3+ unspecified
16pattern PING = MessageID 16 -- ^ 16+ reserved for Messenger usage (lossless packets)
17-- TODO: rename to ALIVE 16
18-- SHARE_RELAYS 17
19-- FRIEND_REQUESTS 18
20pattern ONLINE = MessageID 24 -- 1 byte
21pattern OFFLINE = MessageID 25 -- 1 byte
22-- LOSSLESS_RANGE_SIZE 32
23pattern NICKNAME = MessageID 48 -- up to 129 bytes
24pattern STATUSMESSAGE = MessageID 49 -- up to 1008 bytes
25pattern USERSTATUS = MessageID 50 -- 2 bytes
26pattern TYPING = MessageID 51 -- 2 bytes
27-- LOSSY_RANGE_SIZE 63
28pattern MESSAGE = MessageID 64 -- up to 1373 bytes
29pattern ACTION = MessageID 65 -- up to 1373 bytes
30pattern MSI = MessageID 69
31pattern FILE_SENDREQUEST = MessageID 80 -- 1+1+4+8+32+max255 = up to 301
32pattern FILE_CONTROL = MessageID 81 -- 8 bytes if seek, otherwise 4
33pattern FILE_DATA = MessageID 82 -- up to 1373
34pattern INVITE_GROUPCHAT = MessageID 95
35pattern INVITE_GROUPCHAT0 = MessageID 96 -- 0x60
36-- TODO: rename to INVITE_CONFERENCE 96
37pattern ONLINE_PACKET = MessageID 97 -- 0x61
38pattern DIRECT_GROUPCHAT = MessageID 98 -- 0x62
39-- TODO: rename to DIRECT_CONFERENCE 98
40pattern MESSAGE_GROUPCHAT = MessageID 99 -- 0x63
41-- TODO: rename to MESSAGE_CONFERENCE 99
42-- LOSSLESS_RANGE_START 160
43pattern MessengerLossy192 = MessageID 192 -- ^ 192+ reserved for Messenger usage (lossy packets)
44pattern LOSSY_GROUPCHAT = MessageID 199 -- 0xC7
45pattern Messenger255 = MessageID 255 -- ^ 255 reserved for Messenger usage (lossless packet)
46
47instance Show MessageID where
48 show Padding = "Padding"
49 show PacketRequest = "PacketRequest"
50 show KillPacket = "KillPacket"
51 show UnspecifiedPacket003 = "UnspecifiedPacket003"
52 show PING = "PING"
53 show ONLINE = "ONLINE"
54 show OFFLINE = "OFFLINE"
55 show NICKNAME = "NICKNAME"
56 show STATUSMESSAGE = "STATUSMESSAGE"
57 show USERSTATUS = "USERSTATUS"
58 show TYPING = "TYPING"
59 show MESSAGE = "MESSAGE"
60 show ACTION = "ACTION"
61 show MSI = "MSI"
62 show FILE_SENDREQUEST = "FILE_SENDREQUEST"
63 show FILE_CONTROL = "FILE_CONTROL"
64 show FILE_DATA = "FILE_DATA"
65 show INVITE_GROUPCHAT = "INVITE_GROUPCHAT"
66 show ONLINE_PACKET = "ONLINE_PACKET"
67 show DIRECT_GROUPCHAT = "DIRECT_GROUPCHAT"
68 show MESSAGE_GROUPCHAT = "MESSAGE_GROUPCHAT"
69 show MessengerLossy192 = "MessengerLossy192"
70 show LOSSY_GROUPCHAT = "LOSSY_GROUPCHAT"
71 show Messenger255 = "Messenger255"
72 show (MessageID n) = "MessageID " ++ show n
73
74data LossyOrLossless = Lossless | Lossy
75 deriving (Eq,Ord,Enum,Show,Bounded)
76
77-- | Classify a packet as lossy or lossless.
78lossyness :: MessageID -> LossyOrLossless
79lossyness (fromEnum -> x) | x < 3 = Lossy
80lossyness (fromEnum -> x) | {-16 <= x,-} x < 192 = Lossless
81lossyness (fromEnum -> x) | 192 <= x, x < 255 = Lossy
82lossyness (fromEnum -> 255) = Lossless
83
84
diff --git a/src/Data/Tox/Msg.hs b/src/Data/Tox/Msg.hs
deleted file mode 100644
index 66ec6eb1..00000000
--- a/src/Data/Tox/Msg.hs
+++ /dev/null
@@ -1,311 +0,0 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TypeFamilies #-}
11module Data.Tox.Msg where
12
13import Crypto.Error
14import qualified Crypto.PubKey.Ed25519 as Ed25519
15import Data.ByteArray as BA
16import Data.ByteString as B
17import Data.Dependent.Sum
18import Data.Functor.Contravariant
19import Data.Functor.Identity
20import Data.GADT.Compare
21import Data.GADT.Show
22import Data.Monoid
23import Data.Serialize
24import Data.Text as T
25import Data.Text.Encoding as T
26import Data.Typeable
27import Data.Word
28import GHC.TypeLits
29
30import Crypto.Tox
31import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers)
32import Network.Tox.NodeId
33
34newtype Unknown = Unknown B.ByteString deriving (Eq,Show)
35newtype Padded = Padded B.ByteString deriving (Eq,Show)
36
37-- The 'UserStatus' equivalent in Presence is:
38--
39-- data JabberShow = Offline
40-- | ExtendedAway
41-- | Away -- Tox equiv: Away (1)
42-- | DoNotDisturb -- Tox equiv: Busy (2)
43-- | Available -- Tox equiv: Online (0)
44-- | Chatty
45-- deriving (Show,Enum,Ord,Eq,Read)
46--
47-- The Enum instance on 'UserStatus' is not arbitrary. It corresponds
48-- to on-the-wire id numbers.
49data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum)
50
51instance Serialize UserStatus where
52 get = do
53 x <- get :: Get Word8
54 return (toEnum8 x)
55 put x = put (fromEnum8 x)
56
57
58newtype MissingPackets = MissingPackets [Word32]
59 deriving (Eq,Show)
60
61data Msg (n :: Nat) t where
62 Padding :: Msg 0 Padded
63 PacketRequest :: Msg 1 MissingPackets
64 KillPacket :: Msg 2 ()
65 ALIVE :: Msg 16 ()
66 SHARE_RELAYS :: Msg 17 Unknown
67 FRIEND_REQUESTS :: Msg 18 Unknown
68 ONLINE :: Msg 24 ()
69 OFFLINE :: Msg 25 ()
70 NICKNAME :: Msg 48 Text
71 STATUSMESSAGE :: Msg 49 Text
72 USERSTATUS :: Msg 50 UserStatus
73 TYPING :: Msg 51 Bool
74 MESSAGE :: Msg 64 Text
75 ACTION :: Msg 65 Text
76 MSI :: Msg 69 Unknown
77 FILE_SENDREQUEST :: Msg 80 Unknown
78 FILE_CONTROL :: Msg 81 Unknown
79 FILE_DATA :: Msg 82 Unknown
80 INVITE_GROUPCHAT :: Msg 95 Invite
81 INVITE_CONFERENCE :: Msg 96 Unknown
82 ONLINE_PACKET :: Msg 97 Unknown
83 DIRECT_CONFERENCE :: Msg 98 Unknown
84 MESSAGE_CONFERENCE :: Msg 99 Unknown
85 LOSSY_CONFERENCE :: Msg 199 Unknown
86
87deriving instance Show (Msg n a)
88
89msgbyte :: KnownNat n => Msg n a -> Word8
90msgbyte m = fromIntegral (natVal $ proxy m)
91 where proxy :: Msg n a -> Proxy n
92 proxy _ = Proxy
93
94data Pkt a where Pkt :: (KnownNat n, Packet a, KnownMsg n) => Msg n a -> Pkt a
95
96deriving instance (Show (Pkt a))
97
98type CryptoMessage = DSum Pkt Identity
99
100msgID (Pkt mid :=> Identity _) = M mid
101
102-- TODO
103instance GShow Pkt where gshowsPrec = showsPrec
104instance ShowTag Pkt Identity where
105 showTaggedPrec (Pkt _) = showsPrec
106
107instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
108instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
109
110someMsgVal :: KnownMsg n => Msg n a -> SomeMsg
111someMsgVal m = msgid (proxy m)
112 where proxy :: Msg n a -> Proxy n
113 proxy _ = Proxy
114
115class KnownMsg (n::Nat) where msgid :: proxy n -> SomeMsg
116
117instance KnownMsg 0 where msgid _ = M Padding
118instance KnownMsg 1 where msgid _ = M PacketRequest
119instance KnownMsg 2 where msgid _ = M KillPacket
120instance KnownMsg 16 where msgid _ = M ALIVE
121instance KnownMsg 17 where msgid _ = M SHARE_RELAYS
122instance KnownMsg 18 where msgid _ = M FRIEND_REQUESTS
123instance KnownMsg 24 where msgid _ = M ONLINE
124instance KnownMsg 25 where msgid _ = M OFFLINE
125instance KnownMsg 48 where msgid _ = M NICKNAME
126instance KnownMsg 49 where msgid _ = M STATUSMESSAGE
127instance KnownMsg 50 where msgid _ = M USERSTATUS
128instance KnownMsg 51 where msgid _ = M TYPING
129instance KnownMsg 64 where msgid _ = M MESSAGE
130instance KnownMsg 65 where msgid _ = M ACTION
131instance KnownMsg 69 where msgid _ = M MSI
132instance KnownMsg 80 where msgid _ = M FILE_SENDREQUEST
133instance KnownMsg 81 where msgid _ = M FILE_CONTROL
134instance KnownMsg 82 where msgid _ = M FILE_DATA
135instance KnownMsg 95 where msgid _ = M INVITE_GROUPCHAT
136instance KnownMsg 96 where msgid _ = M INVITE_CONFERENCE
137instance KnownMsg 97 where msgid _ = M ONLINE_PACKET
138instance KnownMsg 98 where msgid _ = M DIRECT_CONFERENCE
139instance KnownMsg 99 where msgid _ = M MESSAGE_CONFERENCE
140
141msgTag :: Word8 -> Maybe SomeMsg
142msgTag 0 = Just $ M Padding
143msgTag 1 = Just $ M PacketRequest
144msgTag 2 = Just $ M KillPacket
145msgTag 16 = Just $ M ALIVE
146msgTag 17 = Just $ M SHARE_RELAYS
147msgTag 18 = Just $ M FRIEND_REQUESTS
148msgTag 24 = Just $ M ONLINE
149msgTag 25 = Just $ M OFFLINE
150msgTag 48 = Just $ M NICKNAME
151msgTag 49 = Just $ M STATUSMESSAGE
152msgTag 50 = Just $ M USERSTATUS
153msgTag 51 = Just $ M TYPING
154msgTag 64 = Just $ M MESSAGE
155msgTag 65 = Just $ M ACTION
156msgTag 69 = Just $ M MSI
157msgTag 80 = Just $ M FILE_SENDREQUEST
158msgTag 81 = Just $ M FILE_CONTROL
159msgTag 82 = Just $ M FILE_DATA
160msgTag 95 = Just $ M INVITE_GROUPCHAT
161msgTag 96 = Just $ M INVITE_CONFERENCE
162msgTag 97 = Just $ M ONLINE_PACKET
163msgTag 98 = Just $ M DIRECT_CONFERENCE
164msgTag 99 = Just $ M MESSAGE_CONFERENCE
165msgTag _ = Nothing
166
167
168class (Typeable t, Eq t, Show t, Sized t) => Packet t where
169 getPacket :: Word32 -> Get t
170 putPacket :: Word32 -> t -> Put
171 default getPacket :: Serialize t => Word32 -> Get t
172 getPacket _ = get
173 default putPacket :: Serialize t => Word32 -> t -> Put
174 putPacket _ t = put t
175
176instance Sized UserStatus where size = ConstSize 1
177instance Packet UserStatus
178
179instance Sized () where size = ConstSize 0
180instance Packet () where
181 getPacket _ = return ()
182 putPacket _ _ = return ()
183
184instance Sized MissingPackets where size = VarSize $ \(MissingPackets ws) -> Prelude.length ws
185instance Packet MissingPackets where
186 getPacket seqno = do
187 bs <- B.unpack <$> (remaining >>= getBytes)
188 return $ MissingPackets (decompressSequenceNumbers seqno bs)
189 putPacket seqno (MissingPackets ws) = do
190 mapM_ putWord8 $ compressSequenceNumbers seqno ws
191
192instance Sized Unknown where size = VarSize $ \(Unknown bs) -> B.length bs
193instance Packet Unknown where
194 getPacket _ = Unknown <$> (remaining >>= getBytes)
195 putPacket _ (Unknown bs) = putByteString bs
196
197instance Sized Padded where size = VarSize $ \(Padded bs) -> B.length bs
198instance Packet Padded where
199 getPacket _ = Padded <$> (remaining >>= getBytes)
200 putPacket _ (Padded bs) = putByteString bs
201
202instance Sized Text where size = VarSize (B.length . T.encodeUtf8)
203instance Packet Text where
204 getPacket _ = T.decodeUtf8 <$> (remaining >>= getBytes)
205 putPacket _ = putByteString . T.encodeUtf8
206
207instance Sized Bool where size = ConstSize 1
208instance Packet Bool where
209 getPacket _ = (/= 0) <$> getWord8
210 putPacket _ False = putWord8 0
211 putPacket _ True = putWord8 1
212
213data SomeMsg where
214 M :: (KnownMsg n, KnownNat n, Packet t) => Msg n t -> SomeMsg
215
216instance Eq SomeMsg where
217 M m == M n = msgbyte m == msgbyte n
218
219instance Show SomeMsg where
220 show (M m) = show m
221
222toEnum8 :: (Enum a, Integral word8) => word8 -> a
223toEnum8 = toEnum . fromIntegral
224
225fromEnum8 :: Enum a => a -> Word8
226fromEnum8 = fromIntegral . fromEnum
227
228data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded)
229
230someLossyness (M m) = lossyness m
231
232lossyness :: KnownNat n => Msg n t -> LossyOrLossless
233lossyness m = case msgbyte m of
234 x | x < 3 -> Lossy
235 | {-16 <= x,-} x < 192 -> Lossless
236 | 192 <= x, x < 255 -> Lossy
237 | otherwise -> Lossless
238
239
240newtype ChatID = ChatID Ed25519.PublicKey
241 deriving Eq
242
243instance Sized ChatID where size = ConstSize 32
244
245instance Serialize ChatID where
246 get = do
247 bs <- getBytes 32
248 case Ed25519.publicKey bs of
249 CryptoPassed ed -> return $ ChatID ed
250 CryptoFailed e -> fail (show e)
251 put (ChatID ed) = putByteString $ BA.convert ed
252
253instance Read ChatID where
254 readsPrec _ s
255 | Right bs <- parseToken32 s
256 , CryptoPassed ed <- Ed25519.publicKey bs
257 = [ (ChatID ed, Prelude.drop 43 s) ]
258 | otherwise = []
259
260instance Show ChatID where
261 show (ChatID ed) = showToken32 ed
262
263data InviteType = GroupInvite { groupName :: Text }
264 | AcceptedInvite
265 | ConfirmedInvite { inviteNodes :: [NodeInfo] }
266 deriving (Eq,Show)
267
268instance Sized InviteType where
269 size = VarSize $ \x -> case x of
270 GroupInvite name -> B.length (T.encodeUtf8 name)
271 AcceptedInvite -> 0
272 ConfirmedInvite ns -> 0 -- TODO: size of node list.
273
274data Invite = Invite
275 { inviteChatID :: ChatID
276 , inviteChatKey :: PublicKey
277 , invite :: InviteType
278 }
279 deriving (Eq,Show)
280
281instance Sized Invite where
282 size = contramap inviteChatID size
283 <> contramap (key2id . inviteChatKey) size
284 <> contramap invite size
285
286instance Serialize Invite where
287 get = do
288 group_packet_id <- getWord8 -- expecting 254=GP_FRIEND_INVITE
289 invite_type <- getWord8
290 chatid <- get
291 chatkey <- getPublicKey
292 Invite chatid chatkey <$> case invite_type of
293 0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state.
294 return $ GroupInvite $ decodeUtf8 bs
295 1 -> return AcceptedInvite
296 2 -> return $ ConfirmedInvite [] -- TODO: decode nodes
297
298 put x = do
299 putWord8 254 -- GP_FRIEND_INVITE
300 putWord8 $ case invite x of
301 GroupInvite {} -> 0 -- GROUP_INVITE
302 AcceptedInvite -> 1 -- GROUP_INVITE_ACCEPTED
303 ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION
304 put $ inviteChatID x
305 putPublicKey $ inviteChatKey x
306 case invite x of
307 GroupInvite name -> putByteString $ encodeUtf8 name
308 AcceptedInvite -> return ()
309 ConfirmedInvite ns -> return () -- TODO: encode nodes.
310
311instance Packet Invite where
diff --git a/src/Data/Tox/Onion.hs b/src/Data/Tox/Onion.hs
deleted file mode 100644
index bd802c75..00000000
--- a/src/Data/Tox/Onion.hs
+++ /dev/null
@@ -1,1029 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE PartialTypeSignatures #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19module Data.Tox.Onion where
20
21
22import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
23import Network.QueryResponse
24import Crypto.Tox hiding (encrypt,decrypt)
25import Network.Tox.NodeId
26import qualified Crypto.Tox as ToxCrypto
27import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo)
28
29import Control.Applicative
30import Control.Arrow
31import Control.Concurrent.STM
32import Control.Monad
33import qualified Data.ByteString as B
34 ;import Data.ByteString (ByteString)
35import Data.Data
36import Data.Function
37import Data.Functor.Contravariant
38import Data.Functor.Identity
39#if MIN_VERSION_iproute(1,7,4)
40import Data.IP hiding (fromSockAddr)
41#else
42import Data.IP
43#endif
44import Data.Maybe
45import Data.Monoid
46import Data.Serialize as S
47import Data.Type.Equality
48import Data.Typeable
49import Data.Word
50import GHC.Generics ()
51import GHC.TypeLits
52import Network.Socket
53import qualified Text.ParserCombinators.ReadP as RP
54import Data.Hashable
55import DPut
56import DebugTag
57import Data.Word64Map (fitsInInt)
58import Data.Bits (shiftR,shiftL)
59import qualified Rank2
60
61type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
62
63type UDPTransport = Transport String SockAddr ByteString
64
65
66getOnionAsymm :: Get (Asymm (Encrypted DataToRoute))
67getOnionAsymm = getAliasedAsymm
68
69putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put
70putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a
71
72data OnionMessage (f :: * -> *)
73 = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8)))
74 | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) -- XXX: Why is Nonce8 transmitted in the clear?
75 | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm
76 | OnionToRouteResponse (Asymm (Encrypted DataToRoute))
77
78deriving instance ( Eq (f (AnnounceRequest, Nonce8))
79 , Eq (f AnnounceResponse)
80 , Eq (f DataToRoute)
81 ) => Eq (OnionMessage f)
82
83deriving instance ( Ord (f (AnnounceRequest, Nonce8))
84 , Ord (f AnnounceResponse)
85 , Ord (f DataToRoute)
86 ) => Ord (OnionMessage f)
87
88deriving instance ( Show (f (AnnounceRequest, Nonce8))
89 , Show (f AnnounceResponse)
90 , Show (f DataToRoute)
91 ) => Show (OnionMessage f)
92
93instance Data (OnionMessage Encrypted) where
94 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
95 toConstr _ = error "OnionMessage.toConstr"
96 gunfold _ _ = error "OnionMessage.gunfold"
97#if MIN_VERSION_base(4,2,0)
98 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage"
99#else
100 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionMessage"
101#endif
102
103instance Rank2.Functor OnionMessage where
104 f <$> m = mapPayload (Proxy :: Proxy Serialize) f m
105
106instance Payload Serialize OnionMessage where
107 mapPayload _ f (OnionAnnounce a) = OnionAnnounce (fmap f a)
108 mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a)
109 mapPayload _ f (OnionToRoute k a) = OnionToRoute k a
110 mapPayload _ f (OnionToRouteResponse a) = OnionToRouteResponse a
111
112
113msgNonce :: OnionMessage f -> Nonce24
114msgNonce (OnionAnnounce a) = asymmNonce a
115msgNonce (OnionAnnounceResponse _ n24 _) = n24
116msgNonce (OnionToRoute _ a) = asymmNonce a
117msgNonce (OnionToRouteResponse a) = asymmNonce a
118
119data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey
120 deriving (Eq,Show)
121
122data OnionDestination r
123 = OnionToOwner
124 { onionNodeInfo :: NodeInfo
125 , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us.
126 }
127 | OnionDestination
128 { onionAliasSelector' :: AliasSelector
129 , onionNodeInfo :: NodeInfo
130 , onionRouteSpec :: Maybe r -- ^ Our own onion-path.
131 }
132 deriving Show
133
134onionAliasSelector :: OnionDestination r -> AliasSelector
135onionAliasSelector (OnionToOwner {} ) = SearchingAlias
136onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel
137
138onionKey :: OnionDestination r -> PublicKey
139onionKey od = id2key . nodeId $ onionNodeInfo od
140
141instance Sized (OnionMessage Encrypted) where
142 size = VarSize $ \case
143 OnionAnnounce a -> case size of ConstSize n -> n + 1
144 VarSize f -> f a + 1
145 OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33
146 VarSize f -> f x + 33
147 OnionToRoute pubkey a -> case size of ConstSize n -> n + 33
148 VarSize f -> f a + 33
149 OnionToRouteResponse a -> case size of ConstSize n -> n + 1
150 VarSize f -> f a + 1
151
152instance Serialize (OnionMessage Encrypted) where
153 get = do
154 typ <- get
155 case typ :: Word8 of
156 0x83 -> OnionAnnounce <$> getAliasedAsymm
157 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm
158 t -> fail ("Unknown onion payload: " ++ show t)
159 `fromMaybe` getOnionReply t
160 put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAsymm a
161 put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a
162 put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
163 put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAsymm a
164
165onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r)
166onionToOwner asymm ret3 saddr = do
167 ni <- nodeInfo (key2id $ senderKey asymm) saddr
168 return $ OnionToOwner ni ret3
169-- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr
170
171
172onion :: Sized msg =>
173 ByteString
174 -> SockAddr
175 -> Get (Asymm (Encrypted msg) -> t)
176 -> Either String (t, OnionDestination r)
177onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
178 oaddr <- onionToOwner asymm ret3 saddr
179 return (f asymm, oaddr)
180
181parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r)))
182 -> (ByteString, SockAddr)
183 -> IO (Either (OnionMessage Encrypted,OnionDestination r)
184 (ByteString,SockAddr))
185parseOnionAddr lookupSender (msg,saddr)
186 | Just (typ,bs) <- B.uncons msg
187 , let right = Right (msg,saddr)
188 query = return . either (const right) Left
189 = case typ of
190 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request
191 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request
192 _ -> case flip runGet bs <$> getOnionReply typ of
193 Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do
194 maddr <- lookupSender saddr n8
195 maybe (return right) -- Response unsolicited or too late.
196 (return . Left . \od -> (msg,od))
197 maddr
198 Just (Right msg@(OnionToRouteResponse asym)) -> do
199 let ni = asymNodeInfo saddr asym
200 return $ Left (msg, OnionDestination SearchingAlias ni Nothing)
201 _ -> return right
202
203getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted))
204getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get
205getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm
206getOnionReply _ = Nothing
207
208putOnionMsg :: OnionMessage Encrypted -> Put
209putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a
210putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a
211putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
212putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a
213
214newtype RouteId = RouteId Int
215 deriving Show
216
217
218-- We used to derive the RouteId from the Nonce8 associated with the query.
219-- This is problematic because a nonce generated by toxcore will not validate
220-- if it is received via a different route than it was issued. This is
221-- described by the Tox spec:
222--
223-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current
224-- time, some secret bytes generated when the instance is created, the
225-- current time divided by a 20 second timeout, the public key of the
226-- requester and the source ip/port that the packet was received from. Since
227-- the ip/port that the packet was received from is in the `ping_id`, the
228-- announce packets being sent with a ping id must be sent using the same
229-- path as the packet that we received the `ping_id` from or announcing will
230-- fail.
231--
232-- The original idea was:
233--
234-- > routeId :: Nonce8 -> RouteId
235-- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12
236--
237-- Instead, we'll just hash the destination node id.
238routeId :: NodeId -> RouteId
239routeId nid = RouteId $ mod (hash nid) 12
240
241
242
243forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport
244forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP }
245
246forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a
247forwardAwait crypto udp sendTCP kont = do
248 fix $ \another -> do
249 awaitMessage udp $ \case
250 m@(Just (Right (bs,saddr))) -> case B.head bs of
251 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another
252 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another
253 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another
254 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another
255 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another
256 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another
257 _ -> kont m
258 m -> kont m
259
260forward :: forall c b b1. (Serialize b, Show b) =>
261 (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
262forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs
263
264class SumToThree a b
265
266instance SumToThree N0 N3
267instance SumToThree (S a) b => SumToThree a (S b)
268
269class ( Serialize (ReturnPath n)
270 , Serialize (ReturnPath (S n))
271 , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
272 , ThreeMinus n ~ S (ThreeMinus (S n))
273 ) => LessThanThree n
274
275instance LessThanThree N0
276instance LessThanThree N1
277instance LessThanThree N2
278
279type family ThreeMinus n where
280 ThreeMinus N3 = N0
281 ThreeMinus N2 = N1
282 ThreeMinus N1 = N2
283 ThreeMinus N0 = N3
284
285-- n = 0, 1, 2
286data OnionRequest n = OnionRequest
287 { onionNonce :: Nonce24
288 , onionForward :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
289 , pathFromOwner :: ReturnPath n
290 }
291 deriving (Eq,Ord)
292
293
294{-
295instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n)
296 , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
297 ) => Data (OnionRequest n) where
298 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
299 toConstr _ = error "OnionRequest.toConstr"
300 gunfold _ _ = error "OnionRequest.gunfold"
301#if MIN_VERSION_base(4,2,0)
302 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionRequest"
303#else
304 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionRequest"
305#endif
306-}
307
308
309instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where
310 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
311 toConstr _ = error "OnionResponse.toConstr"
312 gunfold _ _ = error "OnionResponse.gunfold"
313#if MIN_VERSION_base(4,2,0)
314 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionResponse"
315#else
316 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionResponse"
317#endif
318
319deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
320 , KnownNat (PeanoNat n)
321 ) => Show (OnionRequest n)
322
323instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce.
324 size = contramap onionNonce size
325 <> contramap onionForward size
326 <> contramap pathFromOwner size
327
328instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
329 , Sized (ReturnPath n)
330 , Serialize (ReturnPath n)
331 , Typeable n
332 ) => Serialize (OnionRequest n) where
333 get = do
334 -- TODO share code with 'getOnionRequest'
335 n24 <- case eqT :: Maybe (n :~: N3) of
336 Just Refl -> return $ Nonce24 zeros24
337 Nothing -> get
338 cnt <- remaining
339 let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
340 fwd <- isolate fwdsize get
341 rpath <- get
342 return $ OnionRequest n24 fwd rpath
343 put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
344
345-- getRequest :: _
346-- getRequest = OnionRequest <$> get <*> get <*> get
347
348-- n = 1, 2, 3
349-- Attributed (Encrypted (
350
351data OnionResponse n = OnionResponse
352 { pathToOwner :: ReturnPath n
353 , msgToOwner :: OnionMessage Encrypted
354 }
355 deriving (Eq,Ord)
356
357deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)
358
359instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
360 get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
361 . getOnionReply)
362 put (OnionResponse p m) = put p >> putOnionMsg m
363
364instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where
365 size = contramap pathToOwner size <> contramap msgToOwner size
366
367data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
368 | TCPIndex { tcpIndex :: Int, unaddressed :: a }
369 deriving (Eq,Ord,Show)
370
371instance (Typeable a, Serialize a) => Data (Addressed a) where
372 gfoldl f z a = z (either error id . S.decode) `f` S.encode a
373 toConstr _ = error "Addressed.toConstr"
374 gunfold _ _ = error "Addressed.gunfold"
375#if MIN_VERSION_base(4,2,0)
376 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.Addressed"
377#else
378 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.Addressed"
379#endif
380
381instance Sized a => Sized (Addressed a) where
382 size = case size :: Size a of
383 ConstSize n -> ConstSize $ 1{-family-} + 16{-ip-} + 2{-port-} + n
384 VarSize f -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x)
385
386getForwardAddr :: S.Get SockAddr
387getForwardAddr = do
388 addrfam <- S.get :: S.Get Word8
389 ip <- getIP addrfam
390 case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
391 IPv6 _ -> return ()
392 port <- S.get :: S.Get PortNumber
393 return $ setPort port $ toSockAddr ip
394
395
396putForwardAddr :: SockAddr -> S.Put
397putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
398 port <- sockAddrPort saddr
399 ip <- fromSockAddr $ either id id $ either4or6 saddr
400 return $ do
401 case ip of
402 IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
403 IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
404 S.put port
405
406addrToIndex :: SockAddr -> Int
407addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) =
408 if fitsInInt (Proxy :: Proxy Word64)
409 then fromIntegral lo + (fromIntegral hi `shiftL` 32)
410 else fromIntegral lo
411addrToIndex _ = 0
412
413indexToAddr :: Int -> SockAddr
414indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0
415
416-- Note, toxcore would check an address family byte here to detect a TCP-bound
417-- packet, but we instead use the IPv6 id and rely on the port number being
418-- zero. Since it will be symmetrically encrypted for our eyes only, it's not
419-- important to conform on this point.
420instance Serialize a => Serialize (Addressed a) where
421 get = do saddr <- getForwardAddr
422 a <- get
423 case sockAddrPort saddr of
424 Just 0 -> return $ TCPIndex (addrToIndex saddr) a
425 _ -> return $ Addressed saddr a
426 put (Addressed addr x) = putForwardAddr addr >> put x
427 put (TCPIndex idx x) = putForwardAddr (indexToAddr idx) >> put x
428
429data N0
430data S n
431type N1 = S N0
432type N2 = S N1
433type N3 = S N2
434
435deriving instance Data N0
436deriving instance Data n => Data (S n)
437
438class KnownPeanoNat n where
439 peanoVal :: p n -> Int
440
441instance KnownPeanoNat N0 where
442 peanoVal _ = 0
443instance KnownPeanoNat n => KnownPeanoNat (S n) where
444 peanoVal _ = 1 + peanoVal (Proxy :: Proxy n)
445
446type family PeanoNat p where
447 PeanoNat N0 = 0
448 PeanoNat (S n) = 1 + PeanoNat n
449
450data ReturnPath n where
451 NoReturnPath :: ReturnPath N0
452 ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)
453
454deriving instance Eq (ReturnPath n)
455deriving instance Ord (ReturnPath n)
456
457-- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
458instance Sized (ReturnPath N0) where size = ConstSize 0
459instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
460 size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
461 in error "non-constant ReturnPath size")
462 (size :: Size (ReturnPath n))
463
464{-
465instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
466 size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
467-}
468
469instance Serialize (ReturnPath N0) where get = pure NoReturnPath
470 put NoReturnPath = pure ()
471
472instance Serialize (ReturnPath N1) where
473 get = ReturnPath <$> get <*> get
474 put (ReturnPath n24 p) = put n24 >> put p
475
476instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
477 get = ReturnPath <$> get <*> get
478 put (ReturnPath n24 p) = put n24 >> put p
479
480
481{-
482-- This doesn't work because it tried to infer it for (0 - 1)
483instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where
484 get = ReturnPath <$> get <*> get
485 put (ReturnPath n24 p) = put n24 >> put p
486-}
487
488instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
489 show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))
490
491
492-- instance KnownNat n => Serialize (ReturnPath n) where
493-- -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
494-- get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
495-- put (ReturnPath bs) = putByteString bs
496
497
498data Forwarding n msg where
499 NotForwarded :: msg -> Forwarding N0 msg
500 Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg
501
502deriving instance Eq msg => Eq (Forwarding n msg)
503deriving instance Ord msg => Ord (Forwarding n msg)
504
505instance Show msg => Show (Forwarding N0 msg) where
506 show (NotForwarded x) = "NotForwarded "++show x
507
508instance ( KnownNat (PeanoNat (S n))
509 , Show (Encrypted (Addressed (Forwarding n msg)))
510 ) => Show (Forwarding (S n) msg) where
511 show (Forwarding k a) = unwords [ "Forwarding"
512 , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")"
513 , show (key2id k)
514 , show a
515 ]
516
517instance Sized msg => Sized (Forwarding N0 msg)
518 where size = case size :: Size msg of
519 ConstSize n -> ConstSize n
520 VarSize f -> VarSize $ \(NotForwarded x) -> f x
521
522instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
523 where size = ConstSize 32
524 <> contramap (\(Forwarding _ e) -> e)
525 (size :: Size (Encrypted (Addressed (Forwarding n msg))))
526
527instance Serialize msg => Serialize (Forwarding N0 msg) where
528 get = NotForwarded <$> get
529 put (NotForwarded msg) = put msg
530
531instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
532 get = Forwarding <$> getPublicKey <*> get
533 put (Forwarding k x) = putPublicKey k >> put x
534
535{-
536rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)),
537 Serialize (ReturnPath n),
538 Serialize
539 (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) =>
540 TransportCrypto
541 -> (forall x. x -> Addressed x)
542 -> OnionRequest n
543 -> IO (Either String (OnionRequest (S n), SockAddr))
544rewrap crypto saddr (OnionRequest nonce msg rpath) = do
545 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
546 <*> transportNewNonce crypto )
547 peeled <- peelOnion crypto nonce msg
548 return $ peeled >>= \case
549 Addressed dst msg'
550 -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst)
551 _ -> Left "Onion forward to TCP client?"
552-}
553
554handleOnionRequest :: forall a proxy n.
555 ( LessThanThree n
556 , KnownPeanoNat n
557 , Sized (ReturnPath n)
558 , Typeable n
559 ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a
560handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
561 let n = peanoVal rpath
562 dput XOnion $ "handleOnionRequest " ++ show n
563 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
564 <*> transportNewNonce crypto )
565 peeled <- peelOnion crypto nonce msg
566 let showDestination = case saddr () of
567 Addressed a _ -> either show show $ either4or6 a
568 TCPIndex i _ -> "TCP" ++ show [i]
569
570 case peeled of
571 Left e -> do
572 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
573 kont
574 Right (Addressed dst msg') -> do
575 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"]
576 sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
577 kont
578 Right (TCPIndex {}) -> do
579 dput XUnexpected "handleOnionRequest: Onion forward to TCP client?"
580 kont
581
582wrapSymmetric :: Serialize (ReturnPath n) =>
583 SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n)
584wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath)
585
586peelSymmetric :: Serialize (Addressed (ReturnPath n))
587 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
588peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain
589
590
591peelOnion :: Serialize (Addressed (Forwarding n t))
592 => TransportCrypto
593 -> Nonce24
594 -> Forwarding (S n) t
595 -> IO (Either String (Addressed (Forwarding n t)))
596peelOnion crypto nonce (Forwarding k fwd) = do
597 fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
598
599handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n), Typeable n) =>
600 proxy (S n)
601 -> TransportCrypto
602 -> SockAddr
603 -> UDPTransport
604 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send.
605 -> IO a
606 -> OnionResponse (S n)
607 -> IO a
608handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do
609 sym <- atomically $ transportSymmetric crypto
610 case peelSymmetric sym path of
611 Left e -> do
612 -- todo report encryption error
613 let n = peanoVal path
614 dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
615 kont
616 Right (Addressed dst path') -> do
617 sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
618 kont
619 Right (TCPIndex dst path') -> do
620 case peanoVal path' of
621 0 -> sendTCP dst msg
622 n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
623 kont
624
625
626data AnnounceRequest = AnnounceRequest
627 { announcePingId :: Nonce32 -- Ping ID
628 , announceSeeking :: NodeId -- Public key we are searching for
629 , announceKey :: NodeId -- Public key that we want those sending back data packets to use
630 }
631 deriving Show
632
633instance Sized AnnounceRequest where size = ConstSize (32*3)
634
635instance S.Serialize AnnounceRequest where
636 get = AnnounceRequest <$> S.get <*> S.get <*> S.get
637 put (AnnounceRequest p s k) = S.put (p,s,k)
638
639getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3)
640getOnionRequest = do
641 -- Assumes return path is constant size so that we can isolate
642 -- the variable-sized prefix.
643 cnt <- remaining
644 a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n)
645 getAliasedAsymm
646 path <- get
647 return (a,path)
648
649putRequest :: ( KnownPeanoNat n
650 , Serialize (OnionRequest n)
651 , Typeable n
652 ) => OnionRequest n -> Put
653putRequest req = do
654 let tag = 0x80 + fromIntegral (peanoVal req)
655 when (tag <= 0x82) (putWord8 tag)
656 put req
657
658putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
659putResponse resp = do
660 let tag = 0x8f - fromIntegral (peanoVal resp)
661 -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag
662 -- in it's Serialize instance.
663 when (tag /= 0x8f) (putWord8 tag)
664 put resp
665
666
667data KeyRecord = NotStored Nonce32
668 | SendBackKey PublicKey
669 | Acknowledged Nonce32
670 deriving Show
671
672instance Sized KeyRecord where size = ConstSize 33
673
674instance S.Serialize KeyRecord where
675 get = do
676 is_stored <- S.get :: S.Get Word8
677 case is_stored of
678 1 -> SendBackKey <$> getPublicKey
679 2 -> Acknowledged <$> S.get
680 _ -> NotStored <$> S.get
681 put (NotStored n32) = S.put (0 :: Word8) >> S.put n32
682 put (SendBackKey key) = S.put (1 :: Word8) >> putPublicKey key
683 put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
684
685data AnnounceResponse = AnnounceResponse
686 { is_stored :: KeyRecord
687 , announceNodes :: SendNodes
688 }
689 deriving Show
690
691instance Sized AnnounceResponse where
692 size = contramap is_stored size <> contramap announceNodes size
693
694getNodeList :: S.Get [NodeInfo]
695getNodeList = do
696 n <- S.get
697 (:) n <$> (getNodeList <|> pure [])
698
699instance S.Serialize AnnounceResponse where
700 get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
701 put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
702
703data DataToRoute = DataToRoute
704 { dataFromKey :: PublicKey -- Real public key of sender
705 , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c
706 }
707 deriving Show
708
709instance Sized DataToRoute where
710 size = ConstSize 32 <> contramap dataToRoute size
711
712instance Serialize DataToRoute where
713 get = DataToRoute <$> getPublicKey <*> get
714 put (DataToRoute k dta) = putPublicKey k >> put dta
715
716data OnionData
717 = -- | type 0x9c
718 --
719 -- We send this packet every 30 seconds if there is more than one peer (in
720 -- the 8) that says they our friend is announced on them. This packet can
721 -- also be sent through the DHT module as a DHT request packet (see DHT) if
722 -- we know the DHT public key of the friend and are looking for them in the
723 -- DHT but have not connected to them yet. 30 second is a reasonable
724 -- timeout to not flood the network with too many packets while making sure
725 -- the other will eventually receive the packet. Since packets are sent
726 -- through every peer that knows the friend, resending it right away
727 -- without waiting has a high likelihood of failure as the chances of
728 -- packet loss happening to all (up to to 8) packets sent is low.
729 --
730 -- If a friend is online and connected to us, the onion will stop all of
731 -- its actions for that friend. If the peer goes offline it will restart
732 -- searching for the friend as if toxcore was just started.
733 OnionDHTPublicKey DHTPublicKey
734 | -- | type 0x20
735 --
736 --
737 OnionFriendRequest FriendRequest -- 0x20
738 deriving (Eq,Show)
739
740instance Sized OnionData where
741 size = VarSize $ \case
742 OnionDHTPublicKey dhtpk -> case size of
743 ConstSize n -> n -- Override because OnionData probably
744 -- should be treated as variable sized.
745 VarSize f -> f dhtpk
746 -- FIXME: inconsitantly, we have to add in the tag byte for this case.
747 OnionFriendRequest req -> 1 + case size of
748 ConstSize n -> n
749 VarSize f -> f req
750
751instance Serialize OnionData where
752 get = do
753 tag <- get
754 case tag :: Word8 of
755 0x9c -> OnionDHTPublicKey <$> get
756 0x20 -> OnionFriendRequest <$> get
757 _ -> fail $ "Unknown onion data: "++show tag
758 put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
759 put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
760
761selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
762selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
763 = return (skey, pkey)
764selectKey crypto msg rpath = return $ aliasKey crypto rpath
765
766encrypt :: TransportCrypto
767 -> OnionMessage Identity
768 -> OnionDestination r
769 -> IO (OnionMessage Encrypted, OnionDestination r)
770encrypt crypto msg rpath = do
771 (skey,pkey) <- selectKey crypto msg rpath -- source key
772 let okey = onionKey rpath -- destination key
773 encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a
774 encipher1 sk pk n a = Composed $ do
775 secret <- lookupSharedSecret crypto sk pk n
776 return $ ToxCrypto.encrypt secret $ encodePlain a
777 encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a
778 encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d
779 m <- sequenceMessage $ transcode encipher msg
780 return (m, rpath)
781
782decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
783decrypt crypto msg addr = do
784 (skey,pkey) <- selectKey crypto msg addr
785 let decipher1 :: Serialize a =>
786 TransportCrypto -> SecretKey -> Nonce24
787 -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a))
788 -> (IO ∘ Either String ∘ Identity) a
789 decipher1 crypto k n arg = Composed $ do
790 let (sender,e) = either id (senderKey &&& asymmData) arg
791 secret <- lookupSharedSecret crypto k sender n
792 return $ Composed $ do
793 plain <- ToxCrypto.decrypt secret e
794 Identity <$> decodePlain plain
795 decipher :: Serialize a
796 => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a))
797 -> (IO ∘ Either String ∘ Identity) a
798 decipher = (\n -> decipher1 crypto skey n . left (senderkey addr))
799 foo <- sequenceMessage $ transcode decipher msg
800 return $ do
801 msg <- sequenceMessage foo
802 Right (msg, addr)
803
804senderkey :: OnionDestination r -> t -> (PublicKey, t)
805senderkey addr e = (onionKey addr, e)
806
807aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey)
808aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto
809aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto
810
811dhtKey :: TransportCrypto -> (SecretKey,PublicKey)
812dhtKey crypto = (transportSecret &&& transportPublic) crypto
813
814decryptMessage :: Serialize x =>
815 TransportCrypto
816 -> (SecretKey,PublicKey)
817 -> Nonce24
818 -> Either (PublicKey, Encrypted x)
819 (Asymm (Encrypted x))
820 -> IO ((Either String ∘ Identity) x)
821decryptMessage crypto (sk,pk) n arg = do
822 let (sender,e) = either id (senderKey &&& asymmData) arg
823 plain = Composed . fmap Identity . (>>= decodePlain)
824 secret <- lookupSharedSecret crypto sk sender n
825 return $ plain $ ToxCrypto.decrypt secret e
826
827sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
828sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
829sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
830sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a
831sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
832-- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
833
834transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g
835transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) }
836transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
837transcode f (OnionToRoute pub a) = OnionToRoute pub a
838transcode f (OnionToRouteResponse a) = OnionToRouteResponse a
839-- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) }
840
841
842data OnionRoute = OnionRoute
843 { routeAliasA :: SecretKey
844 , routeAliasB :: SecretKey
845 , routeAliasC :: SecretKey
846 , routeNodeA :: NodeInfo
847 , routeNodeB :: NodeInfo
848 , routeNodeC :: NodeInfo
849 , routeRelayPort :: Maybe PortNumber
850 }
851
852
853wrapOnion :: Serialize (Forwarding n msg) =>
854 TransportCrypto
855 -> SecretKey
856 -> Nonce24
857 -> PublicKey
858 -> SockAddr
859 -> Forwarding n msg
860 -> IO (Forwarding (S n) msg)
861wrapOnion crypto skey nonce destkey saddr fwd = do
862 let plain = encodePlain $ Addressed saddr fwd
863 secret <- lookupSharedSecret crypto skey destkey nonce
864 return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain
865
866wrapOnionPure :: Serialize (Forwarding n msg) =>
867 SecretKey
868 -> ToxCrypto.State
869 -> SockAddr
870 -> Forwarding n msg
871 -> Forwarding (S n) msg
872wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain)
873 where
874 plain = encodePlain $ Addressed saddr fwd
875
876
877
878-- TODO
879-- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
880--
881-- (1) DHT public key packet (0x9c)
882--
883-- (2) Friend request
884data Rendezvous = Rendezvous
885 { rendezvousKey :: PublicKey
886 , rendezvousNode :: NodeInfo
887 }
888 deriving Eq
889
890instance Show Rendezvous where
891 showsPrec d (Rendezvous k ni)
892 = showsPrec d (key2id k)
893 . (':' :)
894 . showsPrec d ni
895
896instance Read Rendezvous where
897 readsPrec d = RP.readP_to_S $ do
898 rkstr <- RP.munch (/=':')
899 RP.char ':'
900 nistr <- RP.munch (const True)
901 return Rendezvous
902 { rendezvousKey = id2key $ read rkstr
903 , rendezvousNode = read nistr
904 }
905
906
907data AnnouncedRendezvous = AnnouncedRendezvous
908 { remoteUserKey :: PublicKey
909 , rendezvous :: Rendezvous
910 }
911 deriving Eq
912
913instance Show AnnouncedRendezvous where
914 showsPrec d (AnnouncedRendezvous remote rendez)
915 = showsPrec d (key2id remote)
916 . (':' :)
917 . showsPrec d rendez
918
919instance Read AnnouncedRendezvous where
920 readsPrec d = RP.readP_to_S $ do
921 ukstr <- RP.munch (/=':')
922 RP.char ':'
923 rkstr <- RP.munch (/=':')
924 RP.char ':'
925 nistr <- RP.munch (const True)
926 return AnnouncedRendezvous
927 { remoteUserKey = id2key $ read ukstr
928 , rendezvous = Rendezvous
929 { rendezvousKey = id2key $ read rkstr
930 , rendezvousNode = read nistr
931 }
932 }
933
934
935selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
936selectAlias crypto pkey = do
937 ks <- filter (\(sk,pk) -> pk == id2key pkey)
938 <$> userKeys crypto
939 maybe (return SearchingAlias)
940 (return . uncurry AnnouncingAlias)
941 (listToMaybe ks)
942
943
944parseDataToRoute
945 :: TransportCrypto
946 -> (OnionMessage Encrypted,OnionDestination r)
947 -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
948parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
949 ks <- atomically $ userKeys crypto
950
951 omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto)
952 (asymmNonce dta)
953 (Right dta) -- using Asymm{senderKey} as remote key
954 let eOuter = fmap runIdentity $ uncomposed omsg0
955
956 anyRight [] f = return $ Left "parseDataToRoute: no user key"
957 anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right)
958
959 -- TODO: We don't currently have a way to look up which user key we
960 -- announced using along this onion route. Therefore, for now, we will
961 -- try all our user keys to see if any can decrypt the packet.
962 eInner <- case eOuter of
963 Left e -> return $ Left e
964 Right dtr -> anyRight ks $ \(sk,pk) -> do
965 omsg0 <- decryptMessage crypto
966 (sk,pk)
967 (asymmNonce dta)
968 (Left (dataFromKey dtr, dataToRoute dtr))
969 return $ do
970 omsg <- fmap runIdentity . uncomposed $ omsg0
971 Right (pk,dtr,omsg)
972
973 let e = do
974 (pk,dtr,omsg) <- eInner
975 return ( (pk, omsg)
976 , AnnouncedRendezvous
977 (dataFromKey dtr)
978 $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
979 r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
980 -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
981 case e of
982 Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
983 Right _ -> return ()
984 dput XMisc $ unlines
985 [ "parseDataToRoute " ++ either id (const "Right") e
986 , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
987 , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
988 , " outer.me = " ++ show (key2id $ rendezvousPublic crypto)
989 , " outer.them = " ++ show (key2id $ senderKey dta)
990 ]
991 return r
992parseDataToRoute _ msg = return $ Right msg
993
994encodeDataToRoute :: TransportCrypto
995 -> ((PublicKey,OnionData),AnnouncedRendezvous)
996 -> IO (Maybe (OnionMessage Encrypted,OnionDestination r))
997encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do
998 nonce <- atomically $ transportNewNonce crypto
999 asel <- atomically $ selectAlias crypto (key2id me)
1000 let (sk,pk) = case asel of
1001 AnnouncingAlias sk pk -> (sk,pk)
1002 _ -> (onionAliasSecret crypto, onionAliasPublic crypto)
1003 innerSecret <- lookupSharedSecret crypto sk toxid nonce
1004 let plain = encodePlain $ DataToRoute { dataFromKey = pk
1005 , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg
1006 }
1007 outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce
1008 let dta = ToxCrypto.encrypt outerSecret plain
1009 dput XOnion $ unlines
1010 [ "encodeDataToRoute me=" ++ show (key2id me)
1011 , " dhtpk=" ++ case omsg of
1012 OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg)
1013 OnionFriendRequest fr -> "friend request"
1014 , " ns=" ++ case omsg of
1015 OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg)
1016 OnionFriendRequest fr -> "friend request"
1017 , " crypto inner.me =" ++ show (key2id pk)
1018 , " inner.you=" ++ show (key2id toxid)
1019 , " outer.me =" ++ show (key2id $ onionAliasPublic crypto)
1020 , " outer.you=" ++ show (key2id pub)
1021 , " " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni))
1022 , " " ++ show dta
1023 ]
1024 return $ Just ( OnionToRoute toxid -- Public key of destination node
1025 Asymm { senderKey = onionAliasPublic crypto
1026 , asymmNonce = nonce
1027 , asymmData = dta
1028 }
1029 , OnionDestination SearchingAlias ni Nothing )
diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
deleted file mode 100644
index c563db8d..00000000
--- a/src/Data/Tox/Relay.hs
+++ /dev/null
@@ -1,232 +0,0 @@
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Data.Tox.Relay where
11
12import Data.Aeson (ToJSON(..),FromJSON(..))
13import qualified Data.Aeson as JSON
14import Data.ByteString as B
15import Data.Data
16import Data.Functor.Contravariant
17import Data.Hashable
18import qualified Data.HashMap.Strict as HashMap
19import Data.Monoid
20import Data.Serialize
21import qualified Data.Vector as Vector
22import Data.Word
23import Network.Socket
24import qualified Rank2
25import qualified Text.ParserCombinators.ReadP as RP
26
27import Crypto.Tox
28import Data.Tox.Onion
29import qualified Network.Tox.NodeId as UDP
30
31newtype ConId = ConId Word8
32 deriving (Eq,Show,Ord,Data,Serialize)
33
34badcon :: ConId
35badcon = ConId 0
36
37-- Maps to a range -120 .. 119
38c2key :: ConId -> Maybe Int
39c2key (ConId x) | x < 16 = Nothing
40 | otherwise = Just $ case divMod (x - 15) 2 of
41 (q,0) -> negate $ fromIntegral q
42 (q,1) -> fromIntegral q
43
44-- Maps to range 16 .. 255
45-- negatives become odds
46key2c :: Int -> ConId
47key2c y = ConId $ if y < 0 then 15 + fromIntegral (negate y * 2)
48 else 16 + fromIntegral (y * 2)
49
50data RelayPacket
51 = RoutingRequest PublicKey
52 | RoutingResponse ConId PublicKey -- 0 for refusal, 16-255 for success.
53 | ConnectNotification ConId
54 | DisconnectNotification ConId
55 | RelayPing Nonce8
56 | RelayPong Nonce8
57 | OOBSend PublicKey ByteString
58 | OOBRecv PublicKey ByteString
59 | OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0)
60 | OnionPacketResponse (OnionMessage Encrypted)
61 -- 0x0A through 0x0F reserved for future use.
62 | RelayData ByteString ConId
63 deriving (Eq,Ord,Show,Data)
64
65newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 }
66 deriving (Eq,Ord,Show)
67
68pattern PingPacket = PacketNumber 4
69pattern OnionPacketID = PacketNumber 8
70
71packetNumber :: RelayPacket -> PacketNumber
72packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed.
73packetNumber rp = PacketNumber $ fromIntegral $ pred $ constrIndex $ toConstr rp
74
75instance Sized RelayPacket where
76 size = mappend (ConstSize 1) $ VarSize $ \x -> case x of
77 RoutingRequest k -> 32
78 RoutingResponse rpid k -> 33
79 ConnectNotification conid -> 1
80 DisconnectNotification conid -> 1
81 RelayPing pingid -> 8
82 RelayPong pingid -> 8
83 OOBSend k bs -> 32 + B.length bs
84 OOBRecv k bs -> 32 + B.length bs
85 OnionPacket n24 query -> 24 + case contramap (`asTypeOf` query) size of
86 ConstSize n -> n
87 VarSize f -> f query
88 OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of
89 ConstSize n -> n
90 VarSize f -> f answer
91 RelayData bs _ -> B.length bs
92
93instance Serialize RelayPacket where
94
95 get = do
96 pktid <- getWord8
97 case pktid of
98 0 -> RoutingRequest <$> getPublicKey
99 1 -> RoutingResponse <$> get <*> getPublicKey
100 2 -> ConnectNotification <$> get
101 3 -> DisconnectNotification <$> get
102 4 -> RelayPing <$> get
103 5 -> RelayPong <$> get
104 6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes)
105 7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes)
106 8 -> OnionPacket <$> get <*> get
107 9 -> OnionPacketResponse <$> get
108 conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes)
109
110 put rp = do
111 putWord8 $ packetNumberToWord8 $ packetNumber rp
112 case rp of
113 RoutingRequest k -> putPublicKey k
114 RoutingResponse rpid k -> put rpid >> putPublicKey k
115 ConnectNotification conid -> put conid
116 DisconnectNotification conid -> put conid
117 RelayPing pingid -> put pingid
118 RelayPong pingid -> put pingid
119 OOBSend k bs -> putPublicKey k >> putByteString bs
120 OOBRecv k bs -> putPublicKey k >> putByteString bs
121 OnionPacket n24 query -> put n24 >> put query
122 OnionPacketResponse answer -> put answer
123 RelayData bs _ -> putByteString bs
124
125-- | Initial client-to-server handshake message.
126newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData))
127
128deriving instance Show (f HelloData) => Show (Hello f)
129
130helloFrom :: Hello f -> PublicKey
131helloFrom (Hello x) = senderKey x
132
133helloNonce :: Hello f -> Nonce24
134helloNonce (Hello x) = asymmNonce x
135
136helloData :: Hello f -> f HelloData
137helloData (Hello x) = asymmData x
138
139instance Rank2.Functor Hello where
140 f <$> Hello (Asymm k n dta) = Hello $ Asymm k n (f dta)
141
142instance Payload Serialize Hello where
143 mapPayload _ f (Hello (Asymm k n dta)) = Hello $ Asymm k n (f dta)
144
145instance Rank2.Foldable Hello where
146 foldMap f (Hello (Asymm k n dta)) = f dta
147
148instance Rank2.Traversable Hello where
149 traverse f (Hello (Asymm k n dta)) = Hello . Asymm k n <$> f dta
150
151instance Sized (Hello Encrypted) where
152 size = ConstSize 56 <> contramap helloData size
153
154instance Serialize (Hello Encrypted) where
155 get = Hello <$> getAsymm
156 put (Hello asym) = putAsymm asym
157
158data HelloData = HelloData
159 { sessionPublicKey :: PublicKey
160 , sessionBaseNonce :: Nonce24
161 }
162 deriving Show
163
164instance Sized HelloData where size = ConstSize 56
165
166instance Serialize HelloData where
167 get = HelloData <$> getPublicKey <*> get
168 put (HelloData k n) = putPublicKey k >> put n
169
170-- | Handshake server-to-client response packet.
171data Welcome (f :: * -> *) = Welcome
172 { welcomeNonce :: Nonce24
173 , welcomeData :: f HelloData
174 }
175
176deriving instance Show (f HelloData) => Show (Welcome f)
177
178instance Rank2.Functor Welcome where
179 f <$> Welcome n dta = Welcome n (f dta)
180
181instance Payload Serialize Welcome where
182 mapPayload _ f (Welcome n dta) = Welcome n (f dta)
183
184instance Rank2.Foldable Welcome where
185 foldMap f (Welcome _ dta) = f dta
186
187instance Rank2.Traversable Welcome where
188 traverse f (Welcome n dta) = Welcome n <$> f dta
189
190instance Sized (Welcome Encrypted) where
191 size = ConstSize 24 <> contramap welcomeData size
192
193instance Serialize (Welcome Encrypted) where
194 get = Welcome <$> get <*> get
195 put (Welcome n dta) = put n >> put dta
196
197data NodeInfo = NodeInfo
198 { udpNodeInfo :: UDP.NodeInfo
199 , tcpPort :: PortNumber
200 }
201 deriving (Eq,Ord)
202
203instance Read NodeInfo where
204 readsPrec _ = RP.readP_to_S $ do
205 udp <- RP.readS_to_P reads
206 port <- RP.between (RP.char '{') (RP.char '}') $ do
207 mapM_ RP.char ("tcp:" :: String)
208 w16 <- RP.readS_to_P reads
209 return $ fromIntegral (w16 :: Word16)
210 return $ NodeInfo udp port
211
212instance ToJSON NodeInfo where
213 toJSON (NodeInfo udp port) = case (toJSON udp) of
214 JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
215 (JSON.Array $ Vector.fromList
216 [JSON.Number (fromIntegral port)])
217 tbl
218 x -> x -- Shouldn't happen.
219
220instance FromJSON NodeInfo where
221 parseJSON json = do
222 udp <- parseJSON json
223 port <- case json of
224 JSON.Object v -> do
225 portnum:_ <- v JSON..: "tcp_ports"
226 return (fromIntegral (portnum :: Word16))
227 _ -> fail "TCP.NodeInfo: Expected JSON object."
228 return $ NodeInfo udp port
229
230instance Hashable NodeInfo where
231 hashWithSalt s n = hashWithSalt s (udpNodeInfo n)
232
diff --git a/src/Data/Word64Map.hs b/src/Data/Word64Map.hs
deleted file mode 100644
index adc9c27e..00000000
--- a/src/Data/Word64Map.hs
+++ /dev/null
@@ -1,66 +0,0 @@
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE UnboxedTuples #-}
4module Data.Word64Map where
5
6import Data.Bits
7import qualified Data.IntMap as IntMap
8 ;import Data.IntMap (IntMap)
9import Data.Monoid
10import Data.Typeable
11import Data.Word
12
13-- | Since 'Int' may be 32 or 64 bits, this function is provided as a
14-- convenience to test if an integral type, such as 'Data.Word.Word64', can be
15-- safely transformed into an 'Int' for use with 'IntMap'.
16--
17-- Returns 'True' if the proxied type can be losslessly converted to 'Int' using
18-- 'fromIntegral'.
19fitsInInt :: forall proxy word. (Bounded word, Integral word) => proxy word -> Bool
20fitsInInt proxy = (original == casted)
21 where
22 original = div maxBound 2 :: word
23 casted = fromIntegral (fromIntegral original :: Int) :: word
24
25newtype Word64Map a = Word64Map (IntMap (IntMap a))
26
27size :: Word64Map a -> Int
28size (Word64Map m) = getSum $ foldMap (\n -> Sum (IntMap.size n)) m
29
30empty :: Word64Map a
31empty = Word64Map IntMap.empty
32
33-- Warning: This function assumes an 'Int' is either 64 or 32 bits.
34keyFrom64 :: Word64 -> (# Int,Int #)
35keyFrom64 w8 =
36 if fitsInInt (Proxy :: Proxy Word64)
37 then (# fromIntegral w8 , 0 #)
38 else (# fromIntegral (w8 `shiftR` 32), fromIntegral w8 #)
39{-# INLINE keyFrom64 #-}
40
41lookup :: Word64 -> Word64Map b -> Maybe b
42lookup w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8 = do
43 m' <- IntMap.lookup hi m
44 IntMap.lookup lo m'
45{-# INLINE lookup #-}
46
47insert :: Word64 -> b -> Word64Map b -> Word64Map b
48insert w8 b (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
49 = Word64Map $ IntMap.alter (Just . maybe (IntMap.singleton lo b)
50 (IntMap.insert lo b))
51 hi
52 m
53{-# INLINE insert #-}
54
55delete :: Word64 -> Word64Map b -> Word64Map b
56delete w8 (Word64Map m) | (# hi,lo #) <- keyFrom64 w8
57 = Word64Map $ IntMap.alter (maybe Nothing
58 (\m' -> case IntMap.delete lo m' of
59 m'' | IntMap.null m'' -> Nothing
60 m'' -> Just m''))
61 hi
62 m
63{-# INLINE delete #-}
64
65
66
diff --git a/src/Data/Wrapper/PSQ.hs b/src/Data/Wrapper/PSQ.hs
deleted file mode 100644
index 4fdeec67..00000000
--- a/src/Data/Wrapper/PSQ.hs
+++ /dev/null
@@ -1,91 +0,0 @@
1{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
4module Data.Wrapper.PSQ
5#if 0
6 ( module Data.Wrapper.PSQ , module Data.PSQueue ) where
7
8import Data.PSQueue hiding (foldr, foldl)
9import qualified Data.PSQueue as PSQueue
10
11type PSQKey k = (Ord k)
12
13-- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface.
14fold' :: (Ord k, Ord p) => (k -> p -> () -> a -> a) -> a -> PSQ k p -> a
15fold' f a q = PSQueue.foldr f' a q
16 where
17 f' (k :-> prio) x = f k prio () x
18
19#else
20 ( module Data.Wrapper.PSQ , module HashPSQ ) where
21
22-- import Data.OrdPSQ as OrdPSQ hiding (insert, map, singleton, minView)
23-- import qualified Data.OrdPSQ as OrdPSQ
24
25import Data.Hashable
26import qualified Data.HashPSQ as Q
27 ;import Data.HashPSQ as HashPSQ hiding (insert, map, minView,
28 singleton)
29import Data.Time.Clock.POSIX (POSIXTime)
30
31-- type PSQ' k p v = HashPSQ k p v
32type PSQ' = HashPSQ
33type PSQ k p = PSQ' k p ()
34
35type Binding' k p v = (k,p,v)
36type Binding k p = Binding' k p ()
37
38type PSQKey k = (Hashable k, Ord k)
39
40pattern (:->) :: k -> p -> Binding k p
41pattern k :-> p <- (k,p,_) where k :-> p = (k,p,())
42
43-- I tried defining (::->) :: (k,v) -> p -> Binding' k p v
44-- but no luck...
45pattern Binding :: k -> v -> p -> Binding' k p v
46pattern Binding k v p <- (k,p,v) where Binding k v p = (k,p,v)
47
48key :: (k,p,v) -> k
49key (k,p,v) = k
50{-# INLINE key #-}
51
52prio :: (k,p,v) -> p
53prio (k,p,v) = p
54{-# INLINE prio #-}
55
56insert :: (PSQKey k, Ord p) => k -> p -> PSQ k p -> PSQ k p
57insert k p q = Q.insert k p () q
58{-# INLINE insert #-}
59
60insert' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v -> PSQ' k p v
61insert' k v p q = Q.insert k p v q
62{-# INLINE insert' #-}
63
64insertWith :: (PSQKey k, Ord p) => (p -> p -> p) -> k -> p -> PSQ k p -> PSQ k p
65insertWith f k p0 q = snd $ Q.alter f' k q
66 where
67 f' (Just (p,())) = ((),Just (f p0 p, ()))
68 f' Nothing = ((),Just (p0,()))
69{-# INLINE insertWith #-}
70
71singleton :: (PSQKey k, Ord p) => k -> p -> PSQ k p
72singleton k p = Q.singleton k p ()
73{-# INLINE singleton #-}
74
75singleton' :: (PSQKey k, Ord p) => k -> v -> p -> PSQ' k p v
76singleton' k v p = Q.singleton k p v
77{-# INLINE singleton' #-}
78
79
80minView :: (PSQKey k, Ord p) => PSQ' k p v -> Maybe (Binding' k p v, PSQ' k p v)
81minView q = fmap (\(k,p,v,q') -> (Binding k v p, q')) $ Q.minView q
82{-# INLINE minView #-}
83
84
85-- | Utility to convert a 'POSIXTime' delta into microseconds suitable for
86-- passing to 'threadDelay'.
87toMicroseconds :: POSIXTime -> Int
88toMicroseconds = round . (* 1000) . (* 1000)
89
90
91#endif
diff --git a/src/Data/Wrapper/PSQInt.hs b/src/Data/Wrapper/PSQInt.hs
deleted file mode 100644
index 5badb8b2..00000000
--- a/src/Data/Wrapper/PSQInt.hs
+++ /dev/null
@@ -1,53 +0,0 @@
1{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE ConstraintKinds #-}
4module Data.Wrapper.PSQInt
5#if 0
6 ( module Data.Wrapper.PSQInt , module Data.PSQueue ) where
7
8import Data.PSQueue hiding (foldr, foldl, PSQ)
9import qualified Data.PSQueue as PSQueue
10
11type PSQ p = PSQueue.PSQ Int p
12
13-- | Wrapper over PSQueue-style foldr to implement a psqueues-style interface.
14fold' :: (Ord p) => (Int -> p -> () -> a -> a) -> a -> PSQ p -> a
15fold' f a q = PSQueue.foldr f' a q
16 where
17 f' (k :-> prio) x = f k prio () x
18
19#else
20 ( module Data.Wrapper.PSQInt
21 , module IntPSQ
22 , module Data.Wrapper.PSQ
23 ) where
24
25import Data.Wrapper.PSQ (Binding, pattern (:->), key, prio, toMicroseconds)
26
27import Data.IntPSQ as IntPSQ hiding (insert, map, singleton, minView)
28import qualified Data.IntPSQ as Q
29
30type PSQ p = IntPSQ p ()
31
32type PSQKey = ()
33
34insert :: (Ord p) => Int -> p -> PSQ p -> PSQ p
35insert k p q = Q.insert k p () q
36{-# INLINE insert #-}
37
38insertWith :: (Ord p) => (p -> p -> p) -> Int -> p -> PSQ p -> PSQ p
39insertWith f k p0 q = snd $ Q.alter f' k q
40 where
41 f' (Just (p,())) = ((),Just (f p0 p, ()))
42 f' Nothing = ((),Nothing)
43{-# INLINE insertWith #-}
44
45singleton :: (Ord p) => Int -> p -> PSQ p
46singleton k p = Q.singleton k p ()
47{-# INLINE singleton #-}
48
49minView :: (Ord p) => PSQ p -> Maybe (Binding Int p, PSQ p)
50minView q = fmap (\(k,p,(),q') -> (k :-> p, q')) $ Q.minView q
51{-# INLINE minView #-}
52
53#endif
diff --git a/src/DebugTag.hs b/src/DebugTag.hs
deleted file mode 100644
index 9ac04bb0..00000000
--- a/src/DebugTag.hs
+++ /dev/null
@@ -1,24 +0,0 @@
1module DebugTag where
2
3import Data.Typeable
4
5-- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
6data DebugTag
7 = XAnnounce
8 | XBitTorrent
9 | XDHT
10 | XLan
11 | XMan
12 | XNetCrypto
13 | XNetCryptoOut
14 | XOnion
15 | XRoutes
16 | XPing
17 | XRefresh
18 | XJabber
19 | XTCP
20 | XMisc
21 | XNodeinfoSearch
22 | XUnexpected -- Used only for special anomalous errors that we didn't expect to happen.
23 | XUnused -- Never commit code that uses XUnused.
24 deriving (Eq, Ord, Show, Read, Enum, Bounded,Typeable)
diff --git a/src/DebugUtil.hs b/src/DebugUtil.hs
deleted file mode 100644
index e7a10397..00000000
--- a/src/DebugUtil.hs
+++ /dev/null
@@ -1,41 +0,0 @@
1{-# LANGUAGE CPP #-}
2module DebugUtil where
3
4import Control.Monad
5import Data.Time.Clock
6import Data.List
7import Text.Printf
8import GHC.Conc (threadStatus,ThreadStatus(..))
9#ifdef THREAD_DEBUG
10import Control.Concurrent.Lifted.Instrument
11#else
12import Control.Concurrent.Lifted
13import GHC.Conc (labelThread)
14#endif
15
16showReport :: [(String,String)] -> String
17showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
18
19showColumns :: [[String]] -> String
20showColumns rows = do
21 let cols = transpose rows
22 ws = map (maximum . map (succ . length)) cols
23 fs <- rows
24 _ <- take 1 fs -- Guard against empty rows so that 'last' is safe.
25 " " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
26
27
28threadReport :: Bool -> IO String
29threadReport want_ss = do
30 threads <- threadsInformation
31 tm <- getCurrentTime
32 let (ss,ts) = partition (("search" `isPrefixOf`) . lbl . snd)
33 threads
34 r <- forM (if want_ss then threads else ts) $ \(tid,PerThread{..}) -> do
35 stat <- threadStatus tid
36 let showStat (ThreadBlocked reason) = show reason
37 showStat stat = show stat
38 return [show lbl,show (diffUTCTime tm startTime),showStat stat]
39 return $ unlines [ showColumns r
40 , (if want_ss then " There are " else " and ")
41 ++ show (length ss) ++ " search threads." ]
diff --git a/src/Hans/Checksum.hs b/src/Hans/Checksum.hs
deleted file mode 100644
index 7afc93c7..00000000
--- a/src/Hans/Checksum.hs
+++ /dev/null
@@ -1,136 +0,0 @@
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE BangPatterns #-}
3
4-- BANNERSTART
5-- - Copyright 2006-2008, Galois, Inc.
6-- - This software is distributed under a standard, three-clause BSD license.
7-- - Please see the file LICENSE, distributed with this software, for specific
8-- - terms and conditions.
9-- Author: Adam Wick <awick@galois.com>
10-- BANNEREND
11-- |A module providing checksum computations to other parts of Hans. The
12-- checksum here is the standard Internet 16-bit checksum (the one's
13-- complement of the one's complement sum of the data).
14
15module Hans.Checksum(
16 -- * Checksums
17 computeChecksum,
18 Checksum(..),
19 PartialChecksum(),
20 emptyPartialChecksum,
21 finalizeChecksum,
22 stepChecksum,
23
24 Pair8(..),
25 ) where
26
27import Data.Bits (Bits(shiftL,shiftR,complement,clearBit,(.&.)))
28import Data.List (foldl')
29import Data.Word (Word8,Word16,Word32)
30import qualified Data.ByteString as S
31import qualified Data.ByteString.Lazy as L
32import qualified Data.ByteString.Short as Sh
33import qualified Data.ByteString.Unsafe as S
34
35
36data PartialChecksum = PartialChecksum { pcAccum :: {-# UNPACK #-} !Word32
37 , pcCarry :: !(Maybe Word8)
38 } deriving (Eq,Show)
39
40emptyPartialChecksum :: PartialChecksum
41emptyPartialChecksum = PartialChecksum
42 { pcAccum = 0
43 , pcCarry = Nothing
44 }
45
46finalizeChecksum :: PartialChecksum -> Word16
47finalizeChecksum pc = complement (fromIntegral (fold32 (fold32 result)))
48 where
49 fold32 :: Word32 -> Word32
50 fold32 x = (x .&. 0xFFFF) + (x `shiftR` 16)
51
52 result = case pcCarry pc of
53 Nothing -> pcAccum pc
54 Just prev -> stepChecksum (pcAccum pc) prev 0
55{-# INLINE finalizeChecksum #-}
56
57
58computeChecksum :: Checksum a => a -> Word16
59computeChecksum a = finalizeChecksum (extendChecksum a emptyPartialChecksum)
60{-# INLINE computeChecksum #-}
61
62-- | Incremental checksum computation interface.
63class Checksum a where
64 extendChecksum :: a -> PartialChecksum -> PartialChecksum
65
66
67data Pair8 = Pair8 !Word8 !Word8
68
69instance Checksum Pair8 where
70 extendChecksum (Pair8 hi lo) = \ PartialChecksum { .. } ->
71 case pcCarry of
72 Nothing -> PartialChecksum { pcAccum = stepChecksum pcAccum hi lo
73 , pcCarry = Nothing }
74 Just c -> PartialChecksum { pcAccum = stepChecksum pcAccum c hi
75 , pcCarry = Just lo }
76 {-# INLINE extendChecksum #-}
77
78instance Checksum Word16 where
79 extendChecksum w = \pc -> extendChecksum (Pair8 hi lo) pc
80 where
81 lo = fromIntegral w
82 hi = fromIntegral (w `shiftR` 8)
83 {-# INLINE extendChecksum #-}
84
85instance Checksum Word32 where
86 extendChecksum w = \pc ->
87 extendChecksum (fromIntegral w :: Word16) $
88 extendChecksum (fromIntegral (w `shiftR` 16) :: Word16) pc
89 {-# INLINE extendChecksum #-}
90
91instance Checksum a => Checksum [a] where
92 extendChecksum as = \pc -> foldl' (flip extendChecksum) pc as
93 {-# INLINE extendChecksum #-}
94
95instance Checksum L.ByteString where
96 extendChecksum lbs = \pc -> extendChecksum (L.toChunks lbs) pc
97 {-# INLINE extendChecksum #-}
98
99-- XXX this could be faster if we could mirror the structure of the instance for
100-- S.ByteString
101instance Checksum Sh.ShortByteString where
102 extendChecksum shb = \ pc -> extendChecksum (Sh.fromShort shb) pc
103
104
105instance Checksum S.ByteString where
106 extendChecksum b pc
107 | S.null b = pc
108 | otherwise = case pcCarry pc of
109 Nothing -> result
110 Just prev -> extendChecksum (S.tail b) PartialChecksum
111 { pcCarry = Nothing
112 , pcAccum = stepChecksum (pcAccum pc) prev (S.unsafeIndex b 0)
113 }
114 where
115
116 n' = S.length b
117 n = clearBit n' 0 -- aligned to two
118
119 result = PartialChecksum
120 { pcAccum = loop (pcAccum pc) 0
121 , pcCarry = carry
122 }
123
124 carry
125 | odd n' = Just $! S.unsafeIndex b n
126 | otherwise = Nothing
127
128 loop !acc off
129 | off < n = loop (stepChecksum acc hi lo) (off + 2)
130 | otherwise = acc
131 where hi = S.unsafeIndex b off
132 lo = S.unsafeIndex b (off+1)
133
134stepChecksum :: Word32 -> Word8 -> Word8 -> Word32
135stepChecksum acc hi lo = acc + fromIntegral hi `shiftL` 8 + fromIntegral lo
136{-# INLINE stepChecksum #-}
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
deleted file mode 100644
index e1cec34d..00000000
--- a/src/Network/Address.hs
+++ /dev/null
@@ -1,1253 +0,0 @@
1-- |
2-- Module : Network.Address
3-- Copyright : (c) Sam Truzjan 2013
4-- (c) Daniel Gröber 2013
5-- License : BSD3
6-- Maintainer : pxqr.sta@gmail.com
7-- Stability : provisional
8-- Portability : portable
9--
10-- Peer and Node addresses.
11--
12{-# LANGUAGE CPP #-}
13{-# LANGUAGE FlexibleInstances #-}
14{-# LANGUAGE FlexibleContexts #-}
15{-# LANGUAGE RecordWildCards #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE ViewPatterns #-}
19{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20{-# LANGUAGE MultiParamTypeClasses #-}
21{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE DeriveFunctor #-}
23{-# LANGUAGE DeriveFoldable #-}
24{-# LANGUAGE DeriveTraversable #-}
25{-# LANGUAGE TemplateHaskell #-}
26{-# OPTIONS -fno-warn-orphans #-}
27module Network.Address
28 ( -- * Address
29 Address (..)
30 , fromAddr
31 , PortNumber
32 , SockAddr
33
34 -- ** IP
35 , IPv4
36 , IPv6
37 , IP (..)
38 , un4map
39 , WantIP (..)
40 , ipFamily
41 , is4mapped
42 , either4or6
43
44 -- * PeerId
45 -- $peer-id
46 , PeerId
47
48 -- ** Generation
49 , genPeerId
50 , timestamp
51 , entropy
52
53 -- ** Encoding
54 , azureusStyle
55 , shadowStyle
56 , defaultClientId
57 , defaultVersionNumber
58
59 -- * PeerAddr
60 -- $peer-addr
61 , PeerAddr(..)
62 , defaultPorts
63 , peerSockAddr
64 , peerSocket
65
66 -- * Node
67 , NodeAddr (..)
68
69 -- ** Id
70 , testIdBit
71 , bucketRange
72 , genBucketSample
73 , genBucketSample'
74
75 -- * Fingerprint
76 -- $fingerprint
77 , Software (..)
78 , Fingerprint (..)
79 , libFingerprint
80 , fingerprint
81
82 -- * Utils
83 , libUserAgent
84 , sockAddrPort
85 , setPort
86 , getBindAddress
87 , localhost4
88 , localhost6
89 , linesBy
90 ) where
91
92import Control.Applicative
93import Control.Monad
94import Control.Exception (onException)
95#ifdef VERSION_bencoding
96import Data.BEncode as BE
97import Data.BEncode.BDict (BKey)
98#endif
99import Data.Bits
100import qualified Data.ByteString as BS
101import qualified Data.ByteString.Internal as BS
102import Data.ByteString.Char8 as BC
103import Data.ByteString.Char8 as BS8
104import qualified Data.ByteString.Lazy as BL
105import qualified Data.ByteString.Lazy.Builder as BS
106import Data.Char
107import Data.Convertible
108import Data.Default
109#if MIN_VERSION_iproute(1,7,4)
110import Data.IP hiding (fromSockAddr)
111#else
112import Data.IP
113#endif
114import Data.List as L
115import Data.Maybe (fromMaybe, catMaybes)
116import Data.Monoid
117import Data.Hashable
118import Data.Serialize as S
119import Data.String
120import Data.Time
121import Data.Typeable
122import Data.Version
123import Data.Word
124import qualified Text.ParserCombinators.ReadP as RP
125import Text.Read (readMaybe)
126import Network.HTTP.Types.QueryLike
127import Network.Socket
128import Text.PrettyPrint as PP hiding ((<>))
129import Text.PrettyPrint.HughesPJClass hiding ((<>),($$))
130#if !MIN_VERSION_time(1,5,0)
131import System.Locale (defaultTimeLocale)
132#endif
133import System.Entropy
134import DPut
135import DebugTag
136
137-- import Paths_bittorrent (version)
138
139instance Pretty UTCTime where
140 pPrint = PP.text . show
141
142setPort :: PortNumber -> SockAddr -> SockAddr
143setPort port (SockAddrInet _ h ) = SockAddrInet port h
144setPort port (SockAddrInet6 _ f h s) = SockAddrInet6 port f h s
145setPort _ addr = addr
146{-# INLINE setPort #-}
147
148-- | Obtains the port associated with a socket address
149-- if one is associated with it.
150sockAddrPort :: SockAddr -> Maybe PortNumber
151sockAddrPort (SockAddrInet p _ ) = Just p
152sockAddrPort (SockAddrInet6 p _ _ _) = Just p
153sockAddrPort _ = Nothing
154{-# INLINE sockAddrPort #-}
155
156class (Eq a, Serialize a, Typeable a, Hashable a, Pretty a)
157 => Address a where
158 toSockAddr :: a -> SockAddr
159 fromSockAddr :: SockAddr -> Maybe a
160
161fromAddr :: (Address a, Address b) => a -> Maybe b
162fromAddr = fromSockAddr . toSockAddr
163
164-- | Note that port is zeroed.
165instance Address IPv4 where
166 toSockAddr = SockAddrInet 0 . toHostAddress
167 fromSockAddr (SockAddrInet _ h) = Just (fromHostAddress h)
168 fromSockAddr _ = Nothing
169
170-- | Note that port is zeroed.
171instance Address IPv6 where
172 toSockAddr h = SockAddrInet6 0 0 (toHostAddress6 h) 0
173 fromSockAddr (SockAddrInet6 _ _ h _) = Just (fromHostAddress6 h)
174 fromSockAddr _ = Nothing
175
176-- | Note that port is zeroed.
177instance Address IP where
178 toSockAddr (IPv4 h) = toSockAddr h
179 toSockAddr (IPv6 h) = toSockAddr h
180 fromSockAddr sa =
181 IPv4 <$> fromSockAddr sa
182 <|> IPv6 <$> fromSockAddr sa
183
184data NodeAddr a = NodeAddr
185 { nodeHost :: !a
186 , nodePort :: {-# UNPACK #-} !PortNumber
187 } deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
188
189instance Show a => Show (NodeAddr a) where
190 showsPrec i NodeAddr {..}
191 = showsPrec i nodeHost <> showString ":" <> showsPrec i nodePort
192
193instance Read (NodeAddr IPv4) where
194 readsPrec i = RP.readP_to_S $ do
195 ipv4 <- RP.readS_to_P (readsPrec i)
196 _ <- RP.char ':'
197 port <- toEnum <$> RP.readS_to_P (readsPrec i)
198 return $ NodeAddr ipv4 port
199
200-- | @127.0.0.1:6882@
201instance Default (NodeAddr IPv4) where
202 def = "127.0.0.1:6882"
203
204-- | KRPC compatible encoding.
205instance Serialize a => Serialize (NodeAddr a) where
206 get = NodeAddr <$> get <*> get
207 {-# INLINE get #-}
208 put NodeAddr {..} = put nodeHost >> put nodePort
209 {-# INLINE put #-}
210
211-- | Example:
212--
213-- @nodePort \"127.0.0.1:6881\" == 6881@
214--
215instance IsString (NodeAddr IPv4) where
216 fromString str
217 | (hostAddrStr, portStr0) <- L.break (== ':') str
218 , let portStr = L.drop 1 portStr0
219 , Just hostAddr <- readMaybe hostAddrStr
220 , Just portNum <- toEnum <$> readMaybe portStr
221 = NodeAddr hostAddr portNum
222 | otherwise = error $ "fromString: unable to parse (NodeAddr IPv4): " ++ str
223
224
225instance Hashable a => Hashable (NodeAddr a) where
226 hashWithSalt s NodeAddr {..} = hashWithSalt s (nodeHost, nodePort)
227 {-# INLINE hashWithSalt #-}
228
229instance Pretty ip => Pretty (NodeAddr ip) where
230 pPrint NodeAddr {..} = pPrint nodeHost <> ":" <> pPrint nodePort
231
232
233
234instance Address PeerAddr where
235 toSockAddr PeerAddr {..} = setPort peerPort $ toSockAddr peerHost
236 fromSockAddr sa = PeerAddr Nothing <$> fromSockAddr sa <*> sockAddrPort sa
237
238{-----------------------------------------------------------------------
239-- Peer id
240-----------------------------------------------------------------------}
241-- $peer-id
242--
243-- 'PeerID' represent self assigned peer identificator. Ideally each
244-- host in the network should have unique peer id to avoid
245-- collisions, therefore for peer ID generation we use good entropy
246-- source. Peer ID is sent in /tracker request/, sent and received in
247-- /peer handshakes/ and used in DHT queries.
248--
249
250-- TODO use unpacked Word160 form (length is known statically)
251
252-- | Peer identifier is exactly 20 bytes long bytestring.
253newtype PeerId = PeerId { getPeerId :: ByteString }
254 deriving ( Show, Eq, Ord, Typeable
255#ifdef VERSION_bencoding
256 , BEncode
257#endif
258 )
259
260peerIdLen :: Int
261peerIdLen = 20
262
263-- | For testing purposes only.
264instance Default PeerId where
265 def = azureusStyle defaultClientId defaultVersionNumber ""
266
267instance Hashable PeerId where
268 hashWithSalt = hashUsing getPeerId
269 {-# INLINE hashWithSalt #-}
270
271instance Serialize PeerId where
272 put = putByteString . getPeerId
273 get = PeerId <$> getBytes peerIdLen
274
275instance QueryValueLike PeerId where
276 toQueryValue (PeerId pid) = Just pid
277 {-# INLINE toQueryValue #-}
278
279instance IsString PeerId where
280 fromString str
281 | BS.length bs == peerIdLen = PeerId bs
282 | otherwise = error $ "Peer id should be 20 bytes long: " ++ show str
283 where
284 bs = fromString str
285
286instance Pretty PeerId where
287 pPrint = text . BC.unpack . getPeerId
288
289instance Convertible BS.ByteString PeerId where
290 safeConvert bs
291 | BS.length bs == peerIdLen = pure (PeerId bs)
292 | otherwise = convError "invalid length" bs
293
294------------------------------------------------------------------------
295
296-- | Pad bytestring so it's becomes exactly request length. Conversion
297-- is done like so:
298--
299-- * length < size: Complete bytestring by given charaters.
300--
301-- * length = size: Output bytestring as is.
302--
303-- * length > size: Drop last (length - size) charaters from a
304-- given bytestring.
305--
306byteStringPadded :: ByteString -- ^ bytestring to be padded.
307 -> Int -- ^ size of result builder.
308 -> Char -- ^ character used for padding.
309 -> BS.Builder
310byteStringPadded bs s c =
311 BS.byteString (BS.take s bs) <>
312 BS.byteString (BC.replicate padLen c)
313 where
314 padLen = s - min (BS.length bs) s
315
316-- | Azureus-style encoding have the following layout:
317--
318-- * 1 byte : '-'
319--
320-- * 2 bytes: client id
321--
322-- * 4 bytes: version number
323--
324-- * 1 byte : '-'
325--
326-- * 12 bytes: random number
327--
328azureusStyle :: ByteString -- ^ 2 character client ID, padded with 'H'.
329 -> ByteString -- ^ Version number, padded with 'X'.
330 -> ByteString -- ^ Random number, padded with '0'.
331 -> PeerId -- ^ Azureus-style encoded peer ID.
332azureusStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
333 BS.char8 '-' <>
334 byteStringPadded cid 2 'H' <>
335 byteStringPadded ver 4 'X' <>
336 BS.char8 '-' <>
337 byteStringPadded rnd 12 '0'
338
339-- | Shadow-style encoding have the following layout:
340--
341-- * 1 byte : client id.
342--
343-- * 0-4 bytes: version number. If less than 4 then padded with
344-- '-' char.
345--
346-- * 15 bytes : random number. If length is less than 15 then
347-- padded with '0' char.
348--
349shadowStyle :: Char -- ^ Client ID.
350 -> ByteString -- ^ Version number.
351 -> ByteString -- ^ Random number.
352 -> PeerId -- ^ Shadow style encoded peer ID.
353shadowStyle cid ver rnd = PeerId $ BL.toStrict $ BS.toLazyByteString $
354 BS.char8 cid <>
355 byteStringPadded ver 4 '-' <>
356 byteStringPadded rnd 15 '0'
357
358
359-- | 'HS'- 2 bytes long client identifier.
360defaultClientId :: ByteString
361defaultClientId = "HS"
362
363-- | Gives exactly 4 bytes long version number for any version of the
364-- package. Version is taken from .cabal file.
365defaultVersionNumber :: ByteString
366defaultVersionNumber = BS.take 4 $ BC.pack $ foldMap show $
367 versionBranch myVersion
368 where
369 Fingerprint _ myVersion = libFingerprint
370
371------------------------------------------------------------------------
372
373-- | Gives 15 characters long decimal timestamp such that:
374--
375-- * 6 bytes : first 6 characters from picoseconds obtained with %q.
376--
377-- * 1 byte : character \'.\' for readability.
378--
379-- * 9..* bytes: number of whole seconds since the Unix epoch
380-- (!)REVERSED.
381--
382-- Can be used both with shadow and azureus style encoding. This
383-- format is used to make the ID's readable for debugging purposes.
384--
385timestamp :: IO ByteString
386timestamp = (BC.pack . format) <$> getCurrentTime
387 where
388 format t = L.take 6 (formatTime defaultTimeLocale "%q" t) ++ "." ++
389 L.take 9 (L.reverse (formatTime defaultTimeLocale "%s" t))
390
391-- | Gives 15 character long random bytestring. This is more robust
392-- method for generation of random part of peer ID than 'timestamp'.
393entropy :: IO ByteString
394entropy = getEntropy 15
395
396-- NOTE: entropy generates incorrrect peer id
397
398-- | Here we use 'azureusStyle' encoding with the following args:
399--
400-- * 'HS' for the client id; ('defaultClientId')
401--
402-- * Version of the package for the version number;
403-- ('defaultVersionNumber')
404--
405-- * UTC time day ++ day time for the random number. ('timestamp')
406--
407genPeerId :: IO PeerId
408genPeerId = azureusStyle defaultClientId defaultVersionNumber <$> timestamp
409
410{-----------------------------------------------------------------------
411-- Peer Addr
412-----------------------------------------------------------------------}
413-- $peer-addr
414--
415-- 'PeerAddr' is used to represent peer address. Currently it's
416-- just peer IP and peer port but this might change in future.
417--
418
419{-----------------------------------------------------------------------
420-- Port number
421-----------------------------------------------------------------------}
422
423#ifdef VERSION_bencoding
424instance BEncode PortNumber where
425 toBEncode = toBEncode . fromEnum
426 fromBEncode = fromBEncode >=> portNumber
427 where
428 portNumber :: Integer -> BE.Result PortNumber
429 portNumber n
430 | 0 <= n && n <= fromIntegral (maxBound :: Word16)
431 = pure $ fromIntegral n
432 | otherwise = decodingError $ "PortNumber: " ++ show n
433#endif
434{-----------------------------------------------------------------------
435-- IP addr
436-----------------------------------------------------------------------}
437
438class IPAddress i where
439 toHostAddr :: i -> Either HostAddress HostAddress6
440
441instance IPAddress IPv4 where
442 toHostAddr = Left . toHostAddress
443 {-# INLINE toHostAddr #-}
444
445instance IPAddress IPv6 where
446 toHostAddr = Right . toHostAddress6
447 {-# INLINE toHostAddr #-}
448
449instance IPAddress IP where
450 toHostAddr (IPv4 ip) = toHostAddr ip
451 toHostAddr (IPv6 ip) = toHostAddr ip
452 {-# INLINE toHostAddr #-}
453
454deriving instance Typeable IP
455deriving instance Typeable IPv4
456deriving instance Typeable IPv6
457
458#ifdef VERSION_bencoding
459ipToBEncode :: Show i => i -> BValue
460ipToBEncode ip = BString $ BS8.pack $ show ip
461{-# INLINE ipToBEncode #-}
462
463ipFromBEncode :: Read a => BValue -> BE.Result a
464ipFromBEncode (BString (BS8.unpack -> ipStr))
465 | Just ip <- readMaybe (ipStr) = pure ip
466 | otherwise = decodingError $ "IP: " ++ ipStr
467ipFromBEncode _ = decodingError $ "IP: addr should be a bstring"
468
469instance BEncode IP where
470 toBEncode = ipToBEncode
471 {-# INLINE toBEncode #-}
472 fromBEncode = ipFromBEncode
473 {-# INLINE fromBEncode #-}
474
475instance BEncode IPv4 where
476 toBEncode = ipToBEncode
477 {-# INLINE toBEncode #-}
478 fromBEncode = ipFromBEncode
479 {-# INLINE fromBEncode #-}
480
481instance BEncode IPv6 where
482 toBEncode = ipToBEncode
483 {-# INLINE toBEncode #-}
484 fromBEncode = ipFromBEncode
485 {-# INLINE fromBEncode #-}
486#endif
487
488-- | Peer address info normally extracted from peer list or peer
489-- compact list encoding.
490data PeerAddr = PeerAddr
491 { peerId :: !(Maybe PeerId)
492
493 -- | This is usually 'IPv4', 'IPv6', 'IP' or unresolved
494 -- 'HostName'.
495 , peerHost :: !IP
496
497 -- | The port the peer listenning for incoming P2P sessions.
498 , peerPort :: {-# UNPACK #-} !PortNumber
499 } deriving (Show, Eq, Ord, Typeable)
500
501#ifdef VERSION_bencoding
502peer_ip_key, peer_id_key, peer_port_key :: BKey
503peer_ip_key = "ip"
504peer_id_key = "peer id"
505peer_port_key = "port"
506
507-- | The tracker's 'announce response' compatible encoding.
508instance BEncode PeerAddr where
509 toBEncode PeerAddr {..} = toDict $
510 peer_ip_key .=! peerHost
511 .: peer_id_key .=? peerId
512 .: peer_port_key .=! peerPort
513 .: endDict
514
515 fromBEncode = fromDict $ do
516 peerAddr <$>! peer_ip_key
517 <*>? peer_id_key
518 <*>! peer_port_key
519 where
520 peerAddr = flip PeerAddr
521#endif
522
523-- | The tracker's 'compact peer list' compatible encoding. The
524-- 'peerId' is always 'Nothing'.
525--
526-- For more info see: <http://www.bittorrent.org/beps/bep_0023.html>
527--
528-- WARNING: Input must be exactly 6 or 18 bytes so that we can identify IP version.
529--
530instance Serialize PeerAddr where
531 put PeerAddr {..} = put peerHost >> put peerPort
532 get = do
533 cnt <- remaining
534 PeerAddr Nothing <$> isolate (cnt - 2) get <*> get
535
536-- | @127.0.0.1:6881@
537instance Default PeerAddr where
538 def = "127.0.0.1:6881"
539
540-- | Example:
541--
542-- @peerPort \"127.0.0.1:6881\" == 6881@
543--
544instance IsString PeerAddr where
545 fromString str
546 | (hostAddrStr, portStr0) <- L.break (== ':') str
547 , let portStr = L.drop 1 portStr0
548 , Just hostAddr <- readMaybe hostAddrStr
549 , Just portNum <- toEnum <$> readMaybe portStr
550 = PeerAddr Nothing (IPv4 hostAddr) portNum
551 | [((ip,port),"")] <- readsIPv6_port str =
552 PeerAddr Nothing (IPv6 ip) port
553 | otherwise = error $ "fromString: unable to parse IP: " ++ str
554
555instance Read PeerAddr where
556 readsPrec i = RP.readP_to_S $ do
557 ip <- IPv4 <$> ( RP.readS_to_P (readsPrec i) )
558 <|> IPv6 <$> ( RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']' )
559 _ <- RP.char ':'
560 port <- toEnum <$> RP.readS_to_P (readsPrec i)
561 return $ PeerAddr Nothing ip port
562
563readsIPv6_port :: String -> [((IPv6, PortNumber), String)]
564readsIPv6_port = RP.readP_to_S $ do
565 ip <- RP.char '[' *> (RP.readS_to_P reads) <* RP.char ']'
566 _ <- RP.char ':'
567 port <- toEnum <$> read <$> (RP.many1 $ RP.satisfy isDigit) <* RP.eof
568 return (ip,port)
569
570
571-- | fingerprint + "at" + dotted.host.inet.addr:port
572instance Pretty PeerAddr where
573 pPrint PeerAddr {..}
574 | Just pid <- peerId = pPrint (fingerprint pid) <+> "at" <+> paddr
575 | otherwise = paddr
576 where
577 paddr = pPrint peerHost <> ":" <> text (show peerPort)
578
579instance Hashable PeerAddr where
580 hashWithSalt s PeerAddr {..} =
581 s `hashWithSalt` peerId `hashWithSalt` peerHost `hashWithSalt` peerPort
582
583-- | Ports typically reserved for bittorrent P2P listener.
584defaultPorts :: [PortNumber]
585defaultPorts = [6881..6889]
586
587_peerSockAddr :: PeerAddr -> (Family, SockAddr)
588_peerSockAddr PeerAddr {..} =
589 case peerHost of
590 IPv4 ipv4 ->
591 (AF_INET, SockAddrInet peerPort (toHostAddress ipv4))
592 IPv6 ipv6 ->
593 (AF_INET6, SockAddrInet6 peerPort 0 (toHostAddress6 ipv6) 0)
594
595peerSockAddr :: PeerAddr -> SockAddr
596peerSockAddr = snd . _peerSockAddr
597
598-- | Create a socket connected to the address specified in a peerAddr
599peerSocket :: SocketType -> PeerAddr -> IO Socket
600peerSocket socketType pa = do
601 let (family, addr) = _peerSockAddr pa
602 sock <- socket family socketType defaultProtocol
603 connect sock addr
604 return sock
605
606{-----------------------------------------------------------------------
607-- Node info
608-----------------------------------------------------------------------}
609-- $node-info
610--
611-- A \"node\" is a client\/server listening on a UDP port
612-- implementing the distributed hash table protocol. The DHT is
613-- composed of nodes and stores the location of peers. BitTorrent
614-- clients include a DHT node, which is used to contact other nodes
615-- in the DHT to get the location of peers to download from using
616-- the BitTorrent protocol.
617
618-- asNodeId :: ByteString -> NodeId
619-- asNodeId bs = NodeId $ BS.take nodeIdSize bs
620
621{-
622
623-- | Test if the nth bit is set.
624testIdBit :: NodeId -> Word -> Bool
625testIdBit (NodeId bs) i
626 | fromIntegral i < nodeIdSize * 8
627 , (q, r) <- quotRem (fromIntegral i) 8
628 = testBit (BS.index bs q) (7 - r)
629 | otherwise = False
630-}
631
632testIdBit :: FiniteBits bs => bs -> Word -> Bool
633testIdBit bs i = testBit bs (fromIntegral (finiteBitSize bs - 1 - fromIntegral i))
634{-# INLINE testIdBit #-}
635
636-- | Generate a random 'NodeId' within a range suitable for a bucket. To
637-- obtain a sample for bucket number /index/ where /is_last/ indicates if this
638-- is for the current deepest bucket in our routing table:
639--
640-- > sample <- genBucketSample nid (bucketRange index is_last)
641genBucketSample :: ( FiniteBits nid
642 , Serialize nid
643 ) => nid -> (Int,Word8,Word8) -> IO nid
644genBucketSample n qmb = genBucketSample' getEntropy n qmb
645
646-- | Generalizion of 'genBucketSample' that accepts a byte generator
647-- function to use instead of the system entropy.
648genBucketSample' :: forall m dht nid.
649 ( Applicative m
650 , FiniteBits nid
651 , Serialize nid
652 ) =>
653 (Int -> m ByteString) -> nid -> (Int,Word8,Word8) -> m nid
654genBucketSample' gen self (q,m,b)
655 | q <= 0 = either error id . S.decode <$> gen nodeIdSize
656 | q >= nodeIdSize = pure self
657 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
658 where
659 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
660
661 -- Prepends q bytes to modified input:
662 -- applies mask m
663 -- toggles bit b
664 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
665 where
666 hd = BS.take q $ S.encode self
667 h = xor b (complement m .&. BS.last hd)
668 t = m .&. BS.head tl
669
670
671------------------------------------------------------------------------
672
673-- | Accepts a depth/index of a bucket and whether or not it is the last one,
674-- yields:
675--
676-- count of leading bytes to be copied from your node id.
677--
678-- mask to clear the extra bits of the last copied byte
679--
680-- mask to toggle the last copied bit if it is not the last bucket
681--
682-- Normally this is used with 'genBucketSample' to obtain a random id suitable
683-- for refreshing a particular bucket.
684bucketRange :: Int -> Bool -> (Int, Word8, Word8)
685bucketRange depth is_last = (q,m,b)
686 where
687 (q,r) = divMod ((if is_last then (+7) else (+8)) depth) 8
688 m = 2^(7-r) - 1
689 b = if is_last then 0 else 2^(7-r)
690
691------------------------------------------------------------------------
692
693#ifdef VERSION_bencoding
694-- | Torrent file compatible encoding.
695instance BEncode a => BEncode (NodeAddr a) where
696 toBEncode NodeAddr {..} = toBEncode (nodeHost, nodePort)
697 {-# INLINE toBEncode #-}
698 fromBEncode b = uncurry NodeAddr <$> fromBEncode b
699 {-# INLINE fromBEncode #-}
700#endif
701
702
703instance Hashable PortNumber where
704 hashWithSalt s = hashWithSalt s . fromEnum
705 {-# INLINE hashWithSalt #-}
706
707instance Pretty PortNumber where
708 pPrint = PP.int . fromEnum
709 {-# INLINE pPrint #-}
710
711instance Serialize PortNumber where
712 get = fromIntegral <$> getWord16be
713 {-# INLINE get #-}
714 put = putWord16be . fromIntegral
715 {-# INLINE put #-}
716
717instance Pretty IPv4 where
718 pPrint = PP.text . show
719 {-# INLINE pPrint #-}
720
721instance Pretty IPv6 where
722 pPrint = PP.text . show
723 {-# INLINE pPrint #-}
724
725instance Pretty IP where
726 pPrint = PP.text . show
727 {-# INLINE pPrint #-}
728
729
730-- | When 'get'ing an IP it must be 'isolate'd to the appropriate
731-- number of bytes since we have no other way of telling which
732-- address type we are trying to parse
733instance Serialize IP where
734 put (IPv4 ip) = put ip
735 put (IPv6 ip) = put ip
736
737 get = do
738 n <- remaining
739 case n of
740 4 -> IPv4 <$> get
741 16 -> IPv6 <$> get
742 _ -> fail (show n ++ " is the wrong number of remaining bytes to parse IP")
743
744instance Serialize IPv4 where
745 put = putWord32host . toHostAddress
746 get = fromHostAddress <$> getWord32host
747
748instance Serialize IPv6 where
749 put ip = put $ toHostAddress6 ip
750 get = fromHostAddress6 <$> get
751
752
753instance Hashable IPv4 where
754 hashWithSalt = hashUsing toHostAddress
755 {-# INLINE hashWithSalt #-}
756
757instance Hashable IPv6 where
758 hashWithSalt s a = hashWithSalt s (toHostAddress6 a)
759
760instance Hashable IP where
761 hashWithSalt s (IPv4 h) = hashWithSalt s h
762 hashWithSalt s (IPv6 h) = hashWithSalt s h
763
764
765
766------------------------------------------------------------------------
767
768{-----------------------------------------------------------------------
769-- Fingerprint
770-----------------------------------------------------------------------}
771-- $fingerprint
772--
773-- 'Fingerprint' is used to identify the client implementation and
774-- version which also contained in 'Peer'. For exsample first 6
775-- bytes of peer id of this this library are @-HS0100-@ while for
776-- mainline we have @M4-3-6--@. We could extract this info and
777-- print in human-friendly form: this is useful for debugging and
778-- logging.
779--
780-- For more information see:
781-- <http://bittorrent.org/beps/bep_0020.html>
782--
783--
784-- NOTE: Do /not/ use this information to control client
785-- capabilities (such as supported enchancements), this should be
786-- done using 'Network.BitTorrent.Extension'!
787--
788
789-- TODO FIXME
790version :: Version
791version = Version [0, 0, 0, 3] []
792
793-- | List of registered client versions + 'IlibHSbittorrent' (this
794-- package) + 'IUnknown' (for not recognized software). All names are
795-- prefixed by \"I\" because some of them starts from lowercase letter
796-- but that is not a valid Haskell constructor name.
797--
798data Software =
799 IUnknown
800
801 | IMainline
802
803 | IABC
804 | IOspreyPermaseed
805 | IBTQueue
806 | ITribler
807 | IShadow
808 | IBitTornado
809
810-- UPnP(!) Bit Torrent !???
811-- 'U' - UPnP NAT Bit Torrent
812 | IBitLord
813 | IOpera
814 | IMLdonkey
815
816 | IAres
817 | IArctic
818 | IAvicora
819 | IBitPump
820 | IAzureus
821 | IBitBuddy
822 | IBitComet
823 | IBitflu
824 | IBTG
825 | IBitRocket
826 | IBTSlave
827 | IBittorrentX
828 | IEnhancedCTorrent
829 | ICTorrent
830 | IDelugeTorrent
831 | IPropagateDataClient
832 | IEBit
833 | IElectricSheep
834 | IFoxTorrent
835 | IGSTorrent
836 | IHalite
837 | IlibHSbittorrent
838 | IHydranode
839 | IKGet
840 | IKTorrent
841 | ILH_ABC
842 | ILphant
843 | ILibtorrent
844 | ILibTorrent
845 | ILimeWire
846 | IMonoTorrent
847 | IMooPolice
848 | IMiro
849 | IMoonlightTorrent
850 | INetTransport
851 | IPando
852 | IqBittorrent
853 | IQQDownload
854 | IQt4TorrentExample
855 | IRetriever
856 | IShareaza
857 | ISwiftbit
858 | ISwarmScope
859 | ISymTorrent
860 | Isharktorrent
861 | ITorrentDotNET
862 | ITransmission
863 | ITorrentstorm
864 | ITuoTu
865 | IuLeecher
866 | IuTorrent
867 | IVagaa
868 | IBitLet
869 | IFireTorrent
870 | IXunlei
871 | IXanTorrent
872 | IXtorrent
873 | IZipTorrent
874 deriving (Show, Eq, Ord, Enum, Bounded)
875
876parseSoftware :: ByteString -> Software
877parseSoftware = f . BC.unpack
878 where
879 f "AG" = IAres
880 f "A~" = IAres
881 f "AR" = IArctic
882 f "AV" = IAvicora
883 f "AX" = IBitPump
884 f "AZ" = IAzureus
885 f "BB" = IBitBuddy
886 f "BC" = IBitComet
887 f "BF" = IBitflu
888 f "BG" = IBTG
889 f "BR" = IBitRocket
890 f "BS" = IBTSlave
891 f "BX" = IBittorrentX
892 f "CD" = IEnhancedCTorrent
893 f "CT" = ICTorrent
894 f "DE" = IDelugeTorrent
895 f "DP" = IPropagateDataClient
896 f "EB" = IEBit
897 f "ES" = IElectricSheep
898 f "FT" = IFoxTorrent
899 f "GS" = IGSTorrent
900 f "HL" = IHalite
901 f "HS" = IlibHSbittorrent
902 f "HN" = IHydranode
903 f "KG" = IKGet
904 f "KT" = IKTorrent
905 f "LH" = ILH_ABC
906 f "LP" = ILphant
907 f "LT" = ILibtorrent
908 f "lt" = ILibTorrent
909 f "LW" = ILimeWire
910 f "MO" = IMonoTorrent
911 f "MP" = IMooPolice
912 f "MR" = IMiro
913 f "ML" = IMLdonkey
914 f "MT" = IMoonlightTorrent
915 f "NX" = INetTransport
916 f "PD" = IPando
917 f "qB" = IqBittorrent
918 f "QD" = IQQDownload
919 f "QT" = IQt4TorrentExample
920 f "RT" = IRetriever
921 f "S~" = IShareaza
922 f "SB" = ISwiftbit
923 f "SS" = ISwarmScope
924 f "ST" = ISymTorrent
925 f "st" = Isharktorrent
926 f "SZ" = IShareaza
927 f "TN" = ITorrentDotNET
928 f "TR" = ITransmission
929 f "TS" = ITorrentstorm
930 f "TT" = ITuoTu
931 f "UL" = IuLeecher
932 f "UT" = IuTorrent
933 f "VG" = IVagaa
934 f "WT" = IBitLet
935 f "WY" = IFireTorrent
936 f "XL" = IXunlei
937 f "XT" = IXanTorrent
938 f "XX" = IXtorrent
939 f "ZT" = IZipTorrent
940 f _ = IUnknown
941
942-- | Used to represent a not recognized implementation
943instance Default Software where
944 def = IUnknown
945 {-# INLINE def #-}
946
947-- | Example: @\"BitLet\" == 'IBitLet'@
948instance IsString Software where
949 fromString str
950 | Just impl <- L.lookup str alist = impl
951 | otherwise = error $ "fromString: not recognized " ++ str
952 where
953 alist = L.map mk [minBound..maxBound]
954 mk x = (L.tail $ show x, x)
955
956-- | Example: @pPrint 'IBitLet' == \"IBitLet\"@
957instance Pretty Software where
958 pPrint = text . L.tail . show
959
960-- | Just the '0' version.
961instance Default Version where
962 def = Version [0] []
963 {-# INLINE def #-}
964
965dropLastIf :: (a -> Bool) -> [a] -> [a]
966dropLastIf pred [] = []
967dropLastIf pred (x:xs) = init' x xs
968 where init' y [] | pred y = []
969 init' y [] = [y]
970 init' y (z:zs) = y : init' z zs
971
972linesBy :: (a -> Bool) -> [a] -> [[a]]
973linesBy pred ys = dropLastIf L.null $ L.map dropDelim $ L.groupBy (\_ x -> not $ pred x) ys
974 where
975 dropDelim [] = []
976 dropDelim (x:xs) | pred x = xs
977 | otherwise = x:xs
978
979-- | For dot delimited version strings.
980-- Example: @fromString \"0.1.0.2\" == Version [0, 1, 0, 2]@
981--
982instance IsString Version where
983 fromString str
984 | Just nums <- chunkNums str = Version nums []
985 | otherwise = error $ "fromString: invalid version string " ++ str
986 where
987 chunkNums = sequence . L.map readMaybe . linesBy ('.' ==)
988
989instance Pretty Version where
990 pPrint = text . showVersion
991
992-- | The all sensible infomation that can be obtained from a peer
993-- identifier or torrent /createdBy/ field.
994data Fingerprint = Fingerprint Software Version
995 deriving (Show, Eq, Ord)
996
997-- | Unrecognized client implementation.
998instance Default Fingerprint where
999 def = Fingerprint def def
1000 {-# INLINE def #-}
1001
1002-- | Example: @\"BitComet-1.2\" == ClientInfo IBitComet (Version [1, 2] [])@
1003instance IsString Fingerprint where
1004 fromString str
1005 | _ : ver <- _ver = Fingerprint (fromString impl) (fromString ver)
1006 | otherwise = error $ "fromString: invalid client info string" ++ str
1007 where
1008 (impl, _ver) = L.span ((/=) '-') str
1009
1010instance Pretty Fingerprint where
1011 pPrint (Fingerprint s v) = pPrint s <+> "version" <+> pPrint v
1012
1013-- | Fingerprint of this (the bittorrent library) package. Normally,
1014-- applications should introduce its own fingerprints, otherwise they
1015-- can use 'libFingerprint' value.
1016--
1017libFingerprint :: Fingerprint
1018libFingerprint = Fingerprint IlibHSbittorrent version
1019
1020-- | HTTP user agent of this (the bittorrent library) package. Can be
1021-- used in HTTP tracker requests.
1022libUserAgent :: String
1023libUserAgent = render (pPrint IlibHSbittorrent <> "/" <> pPrint version)
1024
1025{-----------------------------------------------------------------------
1026-- For torrent file
1027-----------------------------------------------------------------------}
1028-- TODO collect information about createdBy torrent field
1029-- renderImpl :: ClientImpl -> Text
1030-- renderImpl = T.pack . L.tail . show
1031--
1032-- renderVersion :: Version -> Text
1033-- renderVersion = undefined
1034--
1035-- renderClientInfo :: ClientInfo -> Text
1036-- renderClientInfo ClientInfo {..} = renderImpl ciImpl <> "/" <> renderVersion ciVersion
1037--
1038-- parseClientInfo :: Text -> ClientImpl
1039-- parseClientInfo t = undefined
1040
1041
1042-- code used for generation; remove it later on
1043--
1044-- mkEnumTyDef :: NM -> String
1045-- mkEnumTyDef = unlines . map (" | I" ++) . nub . map snd
1046--
1047-- mkPars :: NM -> String
1048-- mkPars = unlines . map (\(code, impl) -> " f \"" ++ code ++ "\" = " ++ "I" ++ impl)
1049--
1050-- type NM = [(String, String)]
1051-- nameMap :: NM
1052-- nameMap =
1053-- [ ("AG", "Ares")
1054-- , ("A~", "Ares")
1055-- , ("AR", "Arctic")
1056-- , ("AV", "Avicora")
1057-- , ("AX", "BitPump")
1058-- , ("AZ", "Azureus")
1059-- , ("BB", "BitBuddy")
1060-- , ("BC", "BitComet")
1061-- , ("BF", "Bitflu")
1062-- , ("BG", "BTG")
1063-- , ("BR", "BitRocket")
1064-- , ("BS", "BTSlave")
1065-- , ("BX", "BittorrentX")
1066-- , ("CD", "EnhancedCTorrent")
1067-- , ("CT", "CTorrent")
1068-- , ("DE", "DelugeTorrent")
1069-- , ("DP", "PropagateDataClient")
1070-- , ("EB", "EBit")
1071-- , ("ES", "ElectricSheep")
1072-- , ("FT", "FoxTorrent")
1073-- , ("GS", "GSTorrent")
1074-- , ("HL", "Halite")
1075-- , ("HS", "libHSnetwork_bittorrent")
1076-- , ("HN", "Hydranode")
1077-- , ("KG", "KGet")
1078-- , ("KT", "KTorrent")
1079-- , ("LH", "LH_ABC")
1080-- , ("LP", "Lphant")
1081-- , ("LT", "Libtorrent")
1082-- , ("lt", "LibTorrent")
1083-- , ("LW", "LimeWire")
1084-- , ("MO", "MonoTorrent")
1085-- , ("MP", "MooPolice")
1086-- , ("MR", "Miro")
1087-- , ("MT", "MoonlightTorrent")
1088-- , ("NX", "NetTransport")
1089-- , ("PD", "Pando")
1090-- , ("qB", "qBittorrent")
1091-- , ("QD", "QQDownload")
1092-- , ("QT", "Qt4TorrentExample")
1093-- , ("RT", "Retriever")
1094-- , ("S~", "Shareaza")
1095-- , ("SB", "Swiftbit")
1096-- , ("SS", "SwarmScope")
1097-- , ("ST", "SymTorrent")
1098-- , ("st", "sharktorrent")
1099-- , ("SZ", "Shareaza")
1100-- , ("TN", "TorrentDotNET")
1101-- , ("TR", "Transmission")
1102-- , ("TS", "Torrentstorm")
1103-- , ("TT", "TuoTu")
1104-- , ("UL", "uLeecher")
1105-- , ("UT", "uTorrent")
1106-- , ("VG", "Vagaa")
1107-- , ("WT", "BitLet")
1108-- , ("WY", "FireTorrent")
1109-- , ("XL", "Xunlei")
1110-- , ("XT", "XanTorrent")
1111-- , ("XX", "Xtorrent")
1112-- , ("ZT", "ZipTorrent")
1113-- ]
1114
1115-- TODO use regexps
1116
1117-- | Tries to extract meaningful information from peer ID bytes. If
1118-- peer id uses unknown coding style then client info returned is
1119-- 'def'.
1120--
1121fingerprint :: PeerId -> Fingerprint
1122fingerprint pid = either (const def) id $ runGet getCI (getPeerId pid)
1123 where
1124 getCI = do
1125 leading <- BS.w2c <$> getWord8
1126 case leading of
1127 '-' -> Fingerprint <$> getAzureusImpl <*> getAzureusVersion
1128 'M' -> Fingerprint <$> pure IMainline <*> getMainlineVersion
1129 'e' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
1130 'F' -> Fingerprint <$> getBitCometImpl <*> getBitCometVersion
1131 c -> do
1132 c1 <- BS.w2c <$> S.lookAhead getWord8
1133 if c1 == 'P'
1134 then do
1135 _ <- getWord8
1136 Fingerprint <$> pure IOpera <*> getOperaVersion
1137 else Fingerprint <$> pure (getShadowImpl c) <*> getShadowVersion
1138
1139 getMainlineVersion = do
1140 str <- BC.unpack <$> getByteString 7
1141 let mnums = L.filter (not . L.null) $ linesBy ('-' ==) str
1142 return $ Version (fromMaybe [] $ sequence $ L.map readMaybe mnums) []
1143
1144 getAzureusImpl = parseSoftware <$> getByteString 2
1145 getAzureusVersion = mkVer <$> getByteString 4
1146 where
1147 mkVer bs = Version [fromMaybe 0 $ readMaybe $ BC.unpack bs] []
1148
1149 getBitCometImpl = do
1150 bs <- getByteString 3
1151 S.lookAhead $ do
1152 _ <- getByteString 2
1153 lr <- getByteString 4
1154 return $
1155 if lr == "LORD" then IBitLord else
1156 if bs == "UTB" then IBitComet else
1157 if bs == "xbc" then IBitComet else def
1158
1159 getBitCometVersion = do
1160 x <- getWord8
1161 y <- getWord8
1162 return $ Version [fromIntegral x, fromIntegral y] []
1163
1164 getOperaVersion = do
1165 str <- BC.unpack <$> getByteString 4
1166 return $ Version [fromMaybe 0 $ readMaybe str] []
1167
1168 getShadowImpl 'A' = IABC
1169 getShadowImpl 'O' = IOspreyPermaseed
1170 getShadowImpl 'Q' = IBTQueue
1171 getShadowImpl 'R' = ITribler
1172 getShadowImpl 'S' = IShadow
1173 getShadowImpl 'T' = IBitTornado
1174 getShadowImpl _ = IUnknown
1175
1176 decodeShadowVerNr :: Char -> Maybe Int
1177 decodeShadowVerNr c
1178 | '0' < c && c <= '9' = Just (fromEnum c - fromEnum '0')
1179 | 'A' < c && c <= 'Z' = Just ((fromEnum c - fromEnum 'A') + 10)
1180 | 'a' < c && c <= 'z' = Just ((fromEnum c - fromEnum 'a') + 36)
1181 | otherwise = Nothing
1182
1183 getShadowVersion = do
1184 str <- BC.unpack <$> getByteString 5
1185 return $ Version (catMaybes $ L.map decodeShadowVerNr str) []
1186
1187
1188
1189-- | Given a string specifying a port (numeric or service name)
1190-- and a flag indicating whether you want to support IPv6, this
1191-- function will return a SockAddr to bind to. If the input
1192-- is not understood as a port number, zero will be set in order
1193-- to ask the system for an unused port.
1194getBindAddress :: String -> Bool -> IO SockAddr
1195getBindAddress bindspec enabled6 = do
1196 let (host,listenPortString) = case L.break (==':') (L.reverse bindspec) of
1197 (rport,':':rhost) -> (Just $ L.reverse rhost, L.reverse rport)
1198 _ -> (Nothing, bindspec)
1199 -- Bind addresses for localhost
1200 xs <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE] }))
1201 host
1202 (Just listenPortString)
1203 `onException` return []
1204 -- We prefer IPv6 because that can also handle connections from IPv4
1205 -- clients...
1206 let (x6s,x4s) = partition (\s -> addrFamily s == AF_INET6) xs
1207 listenAddr =
1208 case if enabled6 then x6s++x4s else x4s of
1209 AddrInfo { addrAddress = addr } : _ -> addr
1210 _ -> if enabled6
1211 then SockAddrInet6 (parsePort listenPortString) 0 iN6ADDR_ANY 0
1212 else SockAddrInet (parsePort listenPortString) iNADDR_ANY
1213 where parsePort s = fromMaybe 0 $ readMaybe s
1214 dput XMisc $ "Listening on " ++ show listenAddr
1215 return listenAddr
1216
1217-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96
1218-- as defined in RFC 4291.
1219is4mapped :: IPv6 -> Bool
1220is4mapped ip
1221 | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip
1222 = True
1223 | otherwise = False
1224
1225un4map :: IPv6 -> Maybe IPv4
1226un4map ip
1227 | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip
1228 = Just $ toIPv4
1229 $ L.map (.&. 0xFF)
1230 [x `shiftR` 8, x, y `shiftR` 8, y ]
1231 | otherwise = Nothing
1232
1233ipFamily :: IP -> WantIP
1234ipFamily ip = case ip of
1235 IPv4 _ -> Want_IP4
1236 IPv6 a | is4mapped a -> Want_IP4
1237 | otherwise -> Want_IP6
1238
1239either4or6 :: SockAddr -> Either SockAddr SockAddr
1240either4or6 a4@(SockAddrInet port addr) = Left a4
1241either4or6 a6@(SockAddrInet6 port _ addr _)
1242 | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4)
1243 | otherwise = Right a6
1244
1245data WantIP = Want_IP4 | Want_IP6 | Want_Both
1246 deriving (Eq, Enum, Ord, Show)
1247
1248localhost6 :: SockAddr
1249localhost6 = SockAddrInet6 0 0 (0,0,0,1) 0 -- [::1]:0
1250
1251localhost4 :: SockAddr
1252localhost4 = SockAddrInet 0 16777343 -- 127.0.0.1:0
1253
diff --git a/src/Network/BitTorrent/DHT/ContactInfo.hs b/src/Network/BitTorrent/DHT/ContactInfo.hs
deleted file mode 100644
index ec7e6658..00000000
--- a/src/Network/BitTorrent/DHT/ContactInfo.hs
+++ /dev/null
@@ -1,254 +0,0 @@
1{-# LANGUAGE BangPatterns #-}
2module Network.BitTorrent.DHT.ContactInfo
3 ( PeerStore
4 , PeerAddr(..)
5 , Network.BitTorrent.DHT.ContactInfo.lookup
6 , Network.BitTorrent.DHT.ContactInfo.freshPeers
7 , Network.BitTorrent.DHT.ContactInfo.insertPeer
8 , deleteOlderThan
9 , knownSwarms
10 ) where
11
12import Control.Applicative
13import Data.Default
14import Data.List as L
15import Data.Maybe
16import Data.HashMap.Strict as HM
17import Data.Serialize
18import Data.Semigroup
19import Data.Wrapper.PSQ as PSQ
20import Data.Time.Clock.POSIX
21import Data.ByteString (ByteString)
22import Data.Word
23
24import Data.Torrent
25import Network.Address
26
27-- {-
28-- import Data.HashMap.Strict as HM
29--
30-- import Data.Torrent.InfoHash
31-- import Network.Address
32--
33-- -- increase prefix when table is too large
34-- -- decrease prefix when table is too small
35-- -- filter outdated peers
36--
37-- {-----------------------------------------------------------------------
38-- -- PeerSet
39-- -----------------------------------------------------------------------}
40--
41-- type PeerSet a = [(PeerAddr, NodeInfo a, Timestamp)]
42--
43-- -- compare PSQueue vs Ordered list
44--
45-- takeNewest :: PeerSet a -> [PeerAddr]
46-- takeNewest = undefined
47--
48-- dropOld :: Timestamp -> PeerSet a -> PeerSet a
49-- dropOld = undefined
50--
51-- insert :: PeerAddr -> Timestamp -> PeerSet a -> PeerSet a
52-- insert = undefined
53--
54-- type Mask = Int
55-- type Size = Int
56-- type Timestamp = Int
57--
58-- {-----------------------------------------------------------------------
59-- -- InfoHashMap
60-- -----------------------------------------------------------------------}
61--
62-- -- compare handwritten prefix tree versus IntMap
63--
64-- data Tree a
65-- = Nil
66-- | Tip !InfoHash !(PeerSet a)
67-- | Bin !InfoHash !Mask !Size !Timestamp (Tree a) (Tree a)
68--
69-- insertTree :: InfoHash -> a -> Tree a -> Tree a
70-- insertTree = undefined
71--
72-- type Prio = Int
73--
74-- --shrink :: ContactInfo ip -> Int
75-- shrink Nil = Nil
76-- shrink (Tip _ _) = undefined
77-- shrink (Bin _ _) = undefined
78--
79-- {-----------------------------------------------------------------------
80-- -- InfoHashMap
81-- -----------------------------------------------------------------------}
82--
83-- -- compare new design versus HashMap
84--
85-- data IntMap k p a
86-- type ContactInfo = Map InfoHash Timestamp (Set (PeerAddr IP) Timestamp)
87--
88-- data ContactInfo ip = PeerStore
89-- { maxSize :: Int
90-- , prefixSize :: Int
91-- , thisNodeId :: NodeId
92--
93-- , count :: Int -- ^ Cached size of the 'peerSet'
94-- , peerSet :: HashMap InfoHash [PeerAddr ip]
95-- }
96--
97-- size :: ContactInfo ip -> Int
98-- size = undefined
99--
100-- prefixSize :: ContactInfo ip -> Int
101-- prefixSize = undefined
102--
103-- lookup :: InfoHash -> ContactInfo ip -> [PeerAddr ip]
104-- lookup = undefined
105--
106-- insert :: InfoHash -> PeerAddr ip -> ContactInfo ip -> ContactInfo ip
107-- insert = undefined
108--
109-- -- | Limit in size.
110-- prune :: NodeId -> Int -> ContactInfo ip -> ContactInfo ip
111-- prune pref targetSize Nil = Nil
112-- prune pref targetSize (Tip _ _) = undefined
113--
114-- -- | Remove expired entries.
115-- splitGT :: Timestamp -> ContactInfo ip -> ContactInfo ip
116-- splitGT = undefined
117-- -}
118
119-- | Storage used to keep track a set of known peers in client,
120-- tracker or DHT sessions.
121newtype PeerStore = PeerStore (HashMap InfoHash SwarmData)
122
123type Timestamp = POSIXTime
124
125data SwarmData = SwarmData
126 { peers :: !(PSQ PeerAddr Timestamp)
127 , name :: !(Maybe ByteString)
128 }
129
130-- | This wrapper will serialize an ip address with a '4' or '6' prefix byte
131-- to indicate whether it is IPv4 or IPv6.
132--
133-- Note: it does not serialize port numbers.
134newtype SerializeAddress a = SerializeAddress { unserializeAddress :: a }
135
136instance Address a => Serialize (SerializeAddress a) where
137 get = SerializeAddress <$> do
138 c <- get
139 case (c::Word8) of
140 0x34 -> do ip4 <- get
141 return $ fromJust $ fromAddr (ip4::IPv4)
142 0x36 -> do ip6 <- get
143 return $ fromJust $ fromAddr (ip6::IPv6)
144 _ -> return $ error "cannot deserialize non-IP SerializeAddress"
145 put (SerializeAddress a)
146 | Just ip4 <- fromAddr a
147 = put (0x34::Word8) >> put (ip4::IPv4)
148 | Just ip6 <- fromAddr a
149 = put (0x36::Word8) >> put (ip6::IPv6)
150 | otherwise = return $ error "cannot serialize non-IP SerializeAddress"
151
152
153instance Serialize SwarmData where
154 get = flip SwarmData <$> get
155 <*> ( PSQ.fromList . L.map parseAddr <$> get )
156 where
157 parseAddr (pid,addr,port) = PeerAddr { peerId = pid
158 , peerHost = unserializeAddress addr
159 , peerPort = port
160 }
161 :-> 0
162
163 put SwarmData{..} = do
164 put name
165 put $ L.map (\(addr :-> _) -> (peerId addr, SerializeAddress addr, peerPort addr))
166 -- XXX: should we serialize the timestamp?
167 $ PSQ.toList peers
168
169knownSwarms :: PeerStore -> [ (InfoHash, Int, Maybe ByteString) ]
170knownSwarms (PeerStore m) = L.map (\(ih,SwarmData q n) -> (ih,PSQ.size q,n)) $ HM.toList m
171
172swarmSingleton :: PeerAddr -> SwarmData
173swarmSingleton a = SwarmData
174 { peers = PSQ.singleton a 0
175 , name = Nothing }
176
177swarmInsert :: SwarmData -> SwarmData -> SwarmData
178swarmInsert new old = SwarmData
179 { peers = L.foldl' (\q (a :-> t) -> PSQ.insertWith newerTimeStamp a t q) (peers old) (PSQ.toList $ peers new)
180 , name = name new <|> name old -- TODO: decodeUtf8' check
181 }
182 where
183 newerTimeStamp newtime oldtime = if newtime > oldtime then newtime else oldtime
184
185isSwarmOccupied :: SwarmData -> Bool
186isSwarmOccupied SwarmData{..} = not $ PSQ.null peers
187
188-- | Empty store.
189instance Default (PeerStore) where
190 def = PeerStore HM.empty
191 {-# INLINE def #-}
192
193instance Semigroup PeerStore where
194 PeerStore a <> PeerStore b =
195 PeerStore (HM.unionWith swarmInsert a b)
196 {-# INLINE (<>) #-}
197
198-- | Monoid under union operation.
199instance Monoid PeerStore where
200 mempty = def
201 {-# INLINE mempty #-}
202
203 mappend (PeerStore a) (PeerStore b) =
204 PeerStore (HM.unionWith swarmInsert a b)
205 {-# INLINE mappend #-}
206
207-- | Can be used to store peers between invocations of the client
208-- software.
209instance Serialize PeerStore where
210 get = PeerStore . HM.fromList <$> get
211 put (PeerStore m) = put (L.filter (isSwarmOccupied . snd) $ HM.toList m)
212
213-- | Returns all peers associated with a given info hash.
214lookup :: InfoHash -> PeerStore -> [PeerAddr]
215lookup ih (PeerStore m) = maybe [] (PSQ.keys . peers) $ HM.lookup ih m
216
217batchSize :: Int
218batchSize = 64
219
220-- | Used in 'get_peers' DHT queries.
221freshPeers :: InfoHash -> Timestamp -> PeerStore -> ([PeerAddr], PeerStore)
222freshPeers ih tm (PeerStore m) = fromMaybe ([],PeerStore m) $ do
223 swarm <- HM.lookup ih m
224 let ps0 = take batchSize $ unfoldr (incomp minView) (peers swarm)
225 peers' = case reverse ps0 of
226 (_,psq):_ -> psq
227 _ -> peers swarm
228 ps = L.map (key . fst) ps0
229 m' = HM.insert ih swarm { peers = L.foldl' (\q p -> PSQ.insert p tm q) peers' ps } m
230 return $! m' `seq` (ps,PeerStore m')
231
232incomp :: (x -> Maybe (r,x)) -> x -> Maybe ((r,x),x)
233incomp !f !x = do
234 (result,x') <- f x
235 pure $! ( (result,x'), x' )
236
237-- | Used in 'announce_peer' DHT queries.
238insertPeer :: InfoHash -> Maybe ByteString -> PeerAddr -> PeerStore -> PeerStore
239insertPeer !ih !name !a !(PeerStore m) = seq a' $ PeerStore (HM.insertWith swarmInsert ih a' m)
240 where
241 a' = SwarmData { peers = PSQ.singleton a 0
242 , name = name }
243
244deleteOlderThan :: POSIXTime -> PeerStore -> PeerStore
245deleteOlderThan cutoff (PeerStore m) = PeerStore $ HM.mapMaybe gc m
246 where
247 gc :: SwarmData -> Maybe SwarmData
248 gc swarms = fmap (\ps -> swarms { peers = ps }) $ gcPSQ (peers swarms)
249
250 gcPSQ :: PSQKey a => PSQ a Timestamp -> Maybe (PSQ a Timestamp)
251 gcPSQ ps = case minView ps of
252 Nothing -> Nothing
253 Just (_ :-> tm, ps') | tm < cutoff -> gcPSQ ps'
254 Just _ -> Just ps
diff --git a/src/Network/BitTorrent/DHT/Readme.md b/src/Network/BitTorrent/DHT/Readme.md
deleted file mode 100644
index e2352f10..00000000
--- a/src/Network/BitTorrent/DHT/Readme.md
+++ /dev/null
@@ -1,13 +0,0 @@
1References
2==========
3
4Some good references excluding BEPs:
5
6* [Kademlia wiki page][kademlia-wiki]
7* [Kademlia: A Peer-to-peer Information System Based on the XOR Metric][kademlia-paper]
8* [BitTorrent Mainline DHT Measurement][mldht]
9* Profiling a Million User DHT. (paper)
10
11[kademlia-wiki]: http://en.wikipedia.org/wiki/Kademlia
12[kademlia-paper]: http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf
13[mldht]: http://www.cs.helsinki.fi/u/jakangas/MLDHT/
diff --git a/src/Network/BitTorrent/DHT/Token.hs b/src/Network/BitTorrent/DHT/Token.hs
deleted file mode 100644
index 171cc8be..00000000
--- a/src/Network/BitTorrent/DHT/Token.hs
+++ /dev/null
@@ -1,201 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- License : BSD3
4-- Maintainer : pxqr.sta@gmail.com
5-- Stability : experimental
6-- Portability : portable
7--
8-- The return value for a query for peers includes an opaque value
9-- known as the 'Token'. For a node to announce that its controlling
10-- peer is downloading a torrent, it must present the token received
11-- from the same queried node in a recent query for peers. When a node
12-- attempts to \"announce\" a torrent, the queried node checks the
13-- token against the querying node's 'IP' address. This is to prevent
14-- malicious hosts from signing up other hosts for torrents. Since the
15-- token is merely returned by the querying node to the same node it
16-- received the token from, the implementation is not defined. Tokens
17-- must be accepted for a reasonable amount of time after they have
18-- been distributed.
19--
20{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}
21module Network.BitTorrent.DHT.Token
22 ( -- * Token
23 Token
24 , maxInterval
25 , toPaddedByteString
26 , fromPaddedByteString
27
28 -- * Session tokens
29 , TokenMap
30 , SessionTokens
31 , nullSessionTokens
32 , checkToken
33 , grantToken
34
35 -- ** Construction
36 , Network.BitTorrent.DHT.Token.tokens
37
38 -- ** Query
39 , Network.BitTorrent.DHT.Token.lookup
40 , Network.BitTorrent.DHT.Token.member
41
42 -- ** Modification
43 , Network.BitTorrent.DHT.Token.defaultUpdateInterval
44 , Network.BitTorrent.DHT.Token.update
45 ) where
46
47import Control.Arrow
48import Control.Monad.State
49#ifdef VERSION_bencoding
50import Data.BEncode (BEncode)
51#endif
52import Data.ByteString as BS
53import Data.ByteString.Char8 as B8
54import Data.ByteString.Lazy as BL
55import Data.ByteString.Lazy.Builder as BS
56import qualified Data.ByteString.Base16 as Base16
57import Data.Default
58import Data.List as L
59import Data.Hashable
60import Data.String
61import Data.Time
62import System.Random
63import Control.Concurrent.STM
64
65-- TODO use ShortByteString
66
67-- | An opaque value.
68newtype Token = Token BS.ByteString
69 deriving ( Eq, IsString
70#ifdef VERSION_bencoding
71 , BEncode
72#endif
73 )
74
75instance Show Token where
76 show (Token bs) = B8.unpack $ Base16.encode bs
77
78instance Read Token where
79 readsPrec i s = pure $ (Token *** B8.unpack) $ Base16.decode (B8.pack s)
80
81-- | Meaningless token, for testing purposes only.
82instance Default Token where
83 def = makeToken (0::Int) 0
84
85-- | Prepend token with 0x20 bytes to fill the available width.
86--
87-- If n > 8, then this will also guarantee a nonzero token, which is useful for
88-- Tox ping-id values for announce responses.
89toPaddedByteString :: Int -> Token -> BS.ByteString
90toPaddedByteString n (Token bs) = BS.append (BS.replicate (n - BS.length bs) 0x20) bs
91
92fromPaddedByteString :: Int -> BS.ByteString -> Token
93fromPaddedByteString n bs = Token $ BS.drop (n - len) bs
94 where
95 len = BS.length tok where Token tok = def
96
97-- | The secret value used as salt.
98type Secret = Int
99
100-- The BitTorrent implementation uses the SHA1 hash of the IP address
101-- concatenated onto a secret, we use hashable instead.
102makeToken :: Hashable a => a -> Secret -> Token
103makeToken n s = Token $ toBS $ hashWithSalt s n
104 where
105 toBS = toStrict . toLazyByteString . int64BE . fromIntegral
106{-# INLINE makeToken #-}
107
108-- | Constant space 'Node' to 'Token' map based on the secret value.
109data TokenMap = TokenMap
110 { prevSecret :: {-# UNPACK #-} !Secret
111 , curSecret :: {-# UNPACK #-} !Secret
112 , generator :: {-# UNPACK #-} !StdGen
113 } deriving Show
114
115-- | A new token map based on the specified seed value. Returned token
116-- map should be periodicatically 'update'd.
117--
118-- Normally, the seed value should vary between invocations of the
119-- client software.
120tokens :: Int -> TokenMap
121tokens seed = (`evalState` mkStdGen seed) $
122 TokenMap <$> state next
123 <*> state next
124 <*> get
125
126-- | Get token for the given node. A token becomes invalid after 2
127-- 'update's.
128--
129-- Typically used to handle find_peers query.
130lookup :: Hashable a => a -> TokenMap -> Token
131lookup addr TokenMap {..} = makeToken addr curSecret
132
133-- | Check if token is valid.
134--
135-- Typically used to handle 'Network.DHT.Mainline.Announce'
136-- query. If token is invalid the 'Network.KRPC.ProtocolError' should
137-- be sent back to the malicious node.
138member :: Hashable a => a -> Token -> TokenMap -> Bool
139member addr token TokenMap {..} = token `L.elem` valid
140 where valid = makeToken addr <$> [curSecret, prevSecret]
141
142-- | Secret changes every five minutes and tokens up to ten minutes old
143-- are accepted.
144defaultUpdateInterval :: NominalDiffTime
145defaultUpdateInterval = 5 * 60
146
147-- | Update current tokens.
148update :: TokenMap -> TokenMap
149update TokenMap {..} = TokenMap
150 { prevSecret = curSecret
151 , curSecret = newSecret
152 , generator = newGen
153 }
154 where
155 (newSecret, newGen) = next generator
156
157data SessionTokens = SessionTokens
158 { tokenMap :: !TokenMap
159 , lastUpdate :: !UTCTime
160 , maxInterval :: !NominalDiffTime
161 }
162
163nullSessionTokens :: IO SessionTokens
164nullSessionTokens = SessionTokens
165 <$> (tokens <$> randomIO)
166 <*> getCurrentTime
167 <*> pure defaultUpdateInterval
168
169-- TODO invalidate *twice* if needed
170invalidateTokens :: UTCTime -> SessionTokens -> SessionTokens
171invalidateTokens curTime ts @ SessionTokens {..}
172 | curTime `diffUTCTime` lastUpdate > maxInterval = SessionTokens
173 { tokenMap = update tokenMap
174 , lastUpdate = curTime
175 , maxInterval = maxInterval
176 }
177 | otherwise = ts
178
179{-----------------------------------------------------------------------
180-- Tokens
181-----------------------------------------------------------------------}
182
183tryUpdateSecret :: TVar SessionTokens -> IO ()
184tryUpdateSecret toks = do
185 curTime <- getCurrentTime
186 atomically $ modifyTVar' toks (invalidateTokens curTime)
187
188grantToken :: Hashable addr => TVar SessionTokens -> addr -> IO Token
189grantToken sessionTokens addr = do
190 tryUpdateSecret sessionTokens
191 toks <- readTVarIO sessionTokens
192 return $ Network.BitTorrent.DHT.Token.lookup addr $ tokenMap toks
193
194-- | Throws 'HandlerError' if the token is invalid or already
195-- expired. See 'TokenMap' for details.
196checkToken :: Hashable addr => TVar SessionTokens -> addr -> Token -> IO Bool
197checkToken sessionTokens addr questionableToken = do
198 tryUpdateSecret sessionTokens
199 toks <- readTVarIO sessionTokens
200 return $ member addr questionableToken (tokenMap toks)
201
diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
deleted file mode 100644
index 89851e88..00000000
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ /dev/null
@@ -1,1169 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveFoldable #-}
4{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE NamedFieldPuns #-}
10{-# LANGUAGE PatternSynonyms #-}
11{-# LANGUAGE StandaloneDeriving #-}
12{-# LANGUAGE TupleSections #-}
13module Network.BitTorrent.MainlineDHT where
14
15import Control.Applicative
16import Control.Arrow
17import Control.Concurrent.STM
18import Control.Monad
19import Crypto.Random
20import Data.BEncode as BE
21import qualified Data.BEncode.BDict as BE
22 ;import Data.BEncode.BDict (BKey)
23import Data.BEncode.Pretty
24import Data.BEncode.Types (BDict)
25import Data.Bits
26import Data.Bits.ByteString ()
27import Data.Bool
28import Data.ByteArray (ByteArrayAccess)
29import qualified Data.ByteString as B
30 ;import Data.ByteString (ByteString)
31import qualified Data.ByteString.Base16 as Base16
32import qualified Data.ByteString.Char8 as C8
33import Data.ByteString.Lazy (toStrict)
34import qualified Data.ByteString.Lazy.Char8 as L8
35import Data.Char
36import Data.Coerce
37import Data.Data
38import Data.Default
39import Data.Digest.CRC32C
40import Data.Function (fix)
41import Data.Hashable
42#if MIN_VERSION_iproute(1,7,4)
43import Data.IP hiding (fromSockAddr)
44#else
45import Data.IP
46#endif
47import Data.Maybe
48import Data.Monoid
49import Data.Ord
50import qualified Data.Serialize as S
51import Data.Set (Set)
52import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
53import Data.Torrent
54import Data.Word
55import qualified Data.Wrapper.PSQInt as Int
56import Debug.Trace
57import Network.BitTorrent.MainlineDHT.Symbols
58import Network.Kademlia
59import Network.Kademlia.Bootstrap
60import Network.Address (fromSockAddr,
61 setPort, sockAddrPort, testIdBit,
62 toSockAddr, genBucketSample', WantIP(..),
63 un4map,either4or6,ipFamily)
64import Network.BitTorrent.DHT.ContactInfo as Peers
65import Network.Kademlia.Search (Search (..))
66import Network.BitTorrent.DHT.Token as Token
67import qualified Network.Kademlia.Routing as R
68 ;import Network.Kademlia.Routing (getTimestamp)
69import Network.QueryResponse
70import Network.Socket
71import System.IO.Error
72import System.IO.Unsafe (unsafeInterleaveIO)
73import qualified Text.ParserCombinators.ReadP as RP
74#ifdef THREAD_DEBUG
75import Control.Concurrent.Lifted.Instrument
76#else
77import Control.Concurrent.Lifted
78import GHC.Conc (labelThread)
79#endif
80import qualified Data.Aeson as JSON
81 ;import Data.Aeson (FromJSON, ToJSON, (.=))
82import Text.Read
83import System.Global6
84import Control.TriadCommittee
85import Data.TableMethods
86import DPut
87import DebugTag
88
89newtype NodeId = NodeId ByteString
90 deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable)
91
92instance BEncode NodeId where
93 fromBEncode bval = do
94 bs <- fromBEncode bval
95 if B.length bs /= 20
96 then Left "Invalid length node id."
97 else Right $ NodeId bs
98
99 toBEncode (NodeId bs) = toBEncode bs
100
101instance Show NodeId where
102 show (NodeId bs) = C8.unpack $ Base16.encode bs
103
104instance S.Serialize NodeId where
105 get = NodeId <$> S.getBytes 20
106 put (NodeId bs) = S.putByteString bs
107
108instance FiniteBits NodeId where
109 finiteBitSize _ = 160
110
111instance Read NodeId where
112 readsPrec _ str
113 | (bs, xs) <- Base16.decode $ C8.pack str
114 , B.length bs == 20
115 = [ (NodeId bs, drop 40 str) ]
116 | otherwise = []
117
118zeroID :: NodeId
119zeroID = NodeId $ B.replicate 20 0
120
121data NodeInfo = NodeInfo
122 { nodeId :: NodeId
123 , nodeIP :: IP
124 , nodePort :: PortNumber
125 }
126 deriving (Eq,Ord)
127
128instance ToJSON NodeInfo where
129 toJSON (NodeInfo nid (IPv4 ip) port)
130 = JSON.object [ "node-id" .= show nid
131 , "ipv4" .= show ip
132 , "port" .= (fromIntegral port :: Int)
133 ]
134 toJSON (NodeInfo nid (IPv6 ip6) port)
135 | Just ip <- un4map ip6
136 = JSON.object [ "node-id" .= show nid
137 , "ipv4" .= show ip
138 , "port" .= (fromIntegral port :: Int)
139 ]
140 | otherwise
141 = JSON.object [ "node-id" .= show nid
142 , "ipv6" .= show ip6
143 , "port" .= (fromIntegral port :: Int)
144 ]
145instance FromJSON NodeInfo where
146 parseJSON (JSON.Object v) = do
147 nidstr <- v JSON..: "node-id"
148 ip6str <- v JSON..:? "ipv6"
149 ip4str <- v JSON..:? "ipv4"
150 portnum <- v JSON..: "port"
151 ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
152 <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
153 let (bs,_) = Base16.decode (C8.pack nidstr)
154 guard (B.length bs == 20)
155 return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))
156
157hexdigit :: Char -> Bool
158hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
159
160instance Read NodeInfo where
161 readsPrec i = RP.readP_to_S $ do
162 RP.skipSpaces
163 let n = 40 -- characters in node id.
164 parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
165 RP.+++ RP.munch (not . isSpace)
166 nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
167 RP.char '@' RP.+++ RP.satisfy isSpace
168 addrstr <- parseAddr
169 nid <- case Base16.decode $ C8.pack hexhash of
170 (bs,_) | B.length bs==20 -> return (NodeId bs)
171 _ -> fail "Bad node id."
172 return (nid,addrstr)
173 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
174 let raddr = do
175 ip <- RP.between (RP.char '[') (RP.char ']')
176 (IPv6 <$> RP.readS_to_P (readsPrec i))
177 RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
178 _ <- RP.char ':'
179 port <- toEnum <$> RP.readS_to_P (readsPrec i)
180 return (ip, port)
181
182 (ip,port) <- case RP.readP_to_S raddr addrstr of
183 [] -> fail "Bad address."
184 ((ip,port),_):_ -> return (ip,port)
185 return $ NodeInfo nid ip port
186
187
188
189-- The Hashable instance depends only on the IP address and port number. It is
190-- used to compute the announce token.
191instance Hashable NodeInfo where
192 hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
193 {-# INLINE hashWithSalt #-}
194
195
196instance Show NodeInfo where
197 showsPrec _ (NodeInfo nid ip port) =
198 shows nid . ('@' :) . showsip . (':' :) . shows port
199 where
200 showsip
201 | IPv4 ip4 <- ip = shows ip4
202 | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
203 | otherwise = ('[' :) . shows ip . (']' :)
204
205{-
206
207-- | KRPC 'compact list' compatible encoding: contact information for
208-- nodes is encoded as a 26-byte string. Also known as "Compact node
209-- info" the 20-byte Node ID in network byte order has the compact
210-- IP-address/port info concatenated to the end.
211 get = NodeInfo <$> (NodeId <$> S.getBytes 20 ) <*> S.get <*> S.get
212-}
213
214getNodeInfo4 :: S.Get NodeInfo
215getNodeInfo4 = NodeInfo <$> (NodeId <$> S.getBytes 20)
216 <*> (IPv4 <$> S.get)
217 <*> S.get
218
219putNodeInfo4 :: NodeInfo -> S.Put
220putNodeInfo4 (NodeInfo (NodeId nid) ip port)
221 | IPv4 ip4 <- ip = put4 ip4
222 | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = put4 ip4
223 | otherwise = return ()
224 where
225 put4 ip4 = S.putByteString nid >> S.put ip4 >> S.put port
226
227getNodeInfo6 :: S.Get NodeInfo
228getNodeInfo6 = NodeInfo <$> (NodeId <$> S.getBytes 20)
229 <*> (IPv6 <$> S.get)
230 <*> S.get
231
232putNodeInfo6 :: NodeInfo -> S.Put
233putNodeInfo6 (NodeInfo (NodeId nid) (IPv6 ip) port)
234 = S.putByteString nid >> S.put ip >> S.put port
235putNodeInfo6 _ = return ()
236
237
238-- | TODO: This should depend on the bind address to support IPv4-only. For
239-- now, in order to support dual-stack listen, we're going to assume IPv6 is
240-- wanted and map IPv4 addresses accordingly.
241nodeAddr :: NodeInfo -> SockAddr
242nodeAddr (NodeInfo _ ip port) =
243 case ip of
244 IPv4 ip4 -> setPort port $ toSockAddr (ipv4ToIPv6 ip4)
245 IPv6 ip6 -> setPort port $ toSockAddr ip6
246
247nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
248nodeInfo nid saddr
249 | Just ip <- fromSockAddr saddr
250 , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
251 | otherwise = Left "Address family not supported."
252
253-- | Types of RPC errors.
254data ErrorCode
255 -- | Some error doesn't fit in any other category.
256 = GenericError
257
258 -- | Occurs when server fail to process procedure call.
259 | ServerError
260
261 -- | Malformed packet, invalid arguments or bad token.
262 | ProtocolError
263
264 -- | Occurs when client trying to call method server don't know.
265 | MethodUnknown
266 deriving (Show, Read, Eq, Ord, Bounded, Typeable, Data)
267
268-- | According to the table:
269-- <http://bittorrent.org/beps/bep_0005.html#errors>
270instance Enum ErrorCode where
271 fromEnum GenericError = 201
272 fromEnum ServerError = 202
273 fromEnum ProtocolError = 203
274 fromEnum MethodUnknown = 204
275 {-# INLINE fromEnum #-}
276 toEnum 201 = GenericError
277 toEnum 202 = ServerError
278 toEnum 203 = ProtocolError
279 toEnum 204 = MethodUnknown
280 toEnum _ = GenericError
281 {-# INLINE toEnum #-}
282
283instance BEncode ErrorCode where
284 toBEncode = toBEncode . fromEnum
285 {-# INLINE toBEncode #-}
286 fromBEncode b = toEnum <$> fromBEncode b
287 {-# INLINE fromBEncode #-}
288
289data Error = Error
290 { errorCode :: !ErrorCode -- ^ The type of error.
291 , errorMessage :: !ByteString -- ^ Human-readable text message.
292 } deriving ( Show, Eq, Ord, Typeable, Data, Read )
293
294newtype TransactionId = TransactionId ByteString
295 deriving (Eq, Ord, Show, BEncode)
296
297newtype Method = Method ByteString
298 deriving (Eq, Ord, Show, BEncode)
299
300data Message a = Q { msgOrigin :: NodeId
301 , msgID :: TransactionId
302 , qryPayload :: a
303 , qryMethod :: Method
304 , qryReadOnly :: Bool }
305
306 | R { msgOrigin :: NodeId
307 , msgID :: TransactionId
308 , rspPayload :: Either Error a
309 , rspReflectedIP :: Maybe SockAddr }
310
311showBE :: BValue -> String
312showBE bval = L8.unpack (showBEncode bval)
313
314instance BE.BEncode (Message BValue) where
315 toBEncode m = encodeMessage m
316 {-
317 in case m of
318 Q {} -> trace ("encoded(query): "++showBE r) r
319 R {} -> trace ("encoded(response): "++showBE r) r -}
320 fromBEncode bval = decodeMessage bval
321 {-
322 in case r of
323 Left e -> trace (show e) r
324 Right (Q {}) -> trace ("decoded(query): "++showBE bval) r
325 Right (R {}) -> trace ("decoded(response): "++showBE bval) r -}
326
327decodeMessage :: BValue -> Either String (Message BValue)
328decodeMessage = fromDict $ do
329 key <- lookAhead (field (req "y"))
330 let _ = key :: BKey
331 f <- case key of
332 "q" -> do a <- field (req "a")
333 g <- either fail return $ flip fromDict a $ do
334 who <- field (req "id")
335 ro <- fromMaybe False <$> optional (field (req "ro"))
336 return $ \meth tid -> Q who tid a meth ro
337 meth <- field (req "q")
338 return $ g meth
339 "r" -> do ip <- do
340 ipstr <- optional (field (req "ip"))
341 mapM (either fail return . decodeAddr) ipstr
342 vals <- field (req "r")
343 either fail return $ flip fromDict vals $ do
344 who <- field (req "id")
345 return $ \tid -> R who tid (Right vals) ip
346 "e" -> do (ecode,emsg) <- field (req "e")
347 ip <- do
348 ipstr <- optional (field (req "ip"))
349 mapM (either fail return . decodeAddr) ipstr
350 -- FIXME:Spec does not give us the NodeId of the sender.
351 -- Using 'zeroID' as place holder.
352 -- We should ignore the msgOrigin for errors in 'updateRouting'.
353 -- We should consider making msgOrigin a Maybe value.
354 return $ \tid -> R zeroID tid (Left (Error ecode emsg)) ip
355 _ -> fail $ "Mainline message is not a query, response, or an error: "
356 ++ show key
357 tid <- field (req "t")
358 return $ f (tid :: TransactionId)
359
360
361encodeMessage :: Message BValue -> BValue
362encodeMessage (Q origin tid a meth ro)
363 = case a of
364 BDict args -> encodeQuery tid meth (BDict $ genericArgs origin ro `BE.union` args)
365 _ -> encodeQuery tid meth a -- XXX: Not really a valid query.
366encodeMessage (R origin tid v ip)
367 = case v of
368 Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip
369 Left err -> encodeError tid err
370
371
372encodeAddr :: SockAddr -> ByteString
373encodeAddr = either encode4 encode6 . either4or6
374 where
375 encode4 (SockAddrInet port addr)
376 = S.runPut (S.putWord32host addr >> S.putWord16be (fromIntegral port))
377
378 encode6 (SockAddrInet6 port _ addr _)
379 = S.runPut (S.put addr >> S.putWord16be (fromIntegral port))
380 encode6 _ = B.empty
381
382decodeAddr :: ByteString -> Either String SockAddr
383decodeAddr bs = S.runGet g bs
384 where
385 g | (B.length bs == 6) = flip SockAddrInet <$> S.getWord32host <*> (fromIntegral <$> S.getWord16be)
386 | otherwise = do host <- S.get -- TODO: Is this right?
387 port <- fromIntegral <$> S.getWord16be
388 return $ SockAddrInet6 port 0 host 0
389
390genericArgs :: BEncode a => a -> Bool -> BDict
391genericArgs nodeid ro =
392 "id" .=! nodeid
393 .: "ro" .=? bool Nothing (Just (1 :: Int)) ro
394 .: endDict
395
396encodeError :: BEncode a => a -> Error -> BValue
397encodeError tid (Error ecode emsg) = encodeAny tid "e" (ecode,emsg) id
398
399encodeResponse :: (BEncode tid, BEncode vals) =>
400 tid -> vals -> Maybe SockAddr -> BValue
401encodeResponse tid rvals rip =
402 encodeAny tid "r" rvals ("ip" .=? (BString . encodeAddr <$> rip) .:)
403
404encodeQuery :: (BEncode args, BEncode tid, BEncode method) =>
405 tid -> method -> args -> BValue
406encodeQuery tid qmeth qargs = encodeAny tid "q" qmeth ("a" .=! qargs .:)
407
408encodeAny ::
409 (BEncode tid, BEncode a) =>
410 tid -> BKey -> a -> (BDict -> BDict) -> BValue
411encodeAny tid key val aux = toDict $
412 aux $ key .=! val
413 .: "t" .=! tid
414 .: "y" .=! key
415 .: endDict
416
417
418showPacket :: ([L8.ByteString] -> [L8.ByteString]) -> SockAddr -> L8.ByteString -> ByteString -> String
419showPacket f addr flow bs = L8.unpack $ L8.unlines es
420 where
421 es = map (L8.append prefix) (f $ L8.lines pp)
422
423 prefix = L8.pack (either show show $ either4or6 addr) <> flow
424
425 pp = either L8.pack showBEncode $ BE.decode bs
426
427-- Add detailed printouts for every packet.
428addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
429addVerbosity tr =
430 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
431 forM_ m $ mapM_ $ \(msg,addr) -> do
432 dput XBitTorrent (showPacket id addr " --> " msg)
433 kont m
434 , sendMessage = \addr msg -> do
435 dput XBitTorrent (showPacket id addr " <-- " msg)
436 sendMessage tr addr msg
437 }
438
439
440showParseError :: ByteString -> SockAddr -> String -> String
441showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs
442
443parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo)
444parsePacket bs addr = left (showParseError bs addr) $ do
445 pkt <- BE.decode bs
446 -- TODO: Error packets do not include a valid msgOrigin.
447 -- The BE.decode method is using 'zeroID' as a placeholder.
448 ni <- nodeInfo (msgOrigin pkt) addr
449 return (pkt, ni)
450
451encodePacket :: Message BValue -> NodeInfo -> (ByteString, SockAddr)
452encodePacket msg ni = ( toStrict $ BE.encode msg
453 , nodeAddr ni )
454
455classify :: Message BValue -> MessageClass String Method TransactionId NodeInfo (Message BValue)
456classify (Q { msgID = tid, qryMethod = meth }) = IsQuery meth tid
457classify (R { msgID = tid }) = IsResponse tid
458
459encodeResponsePayload :: BEncode a => TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue
460encodeResponsePayload tid self dest b = R (nodeId self) tid (Right $ BE.toBEncode b) (Just $ nodeAddr dest)
461
462encodeQueryPayload :: BEncode a =>
463 Method -> Bool -> TransactionId -> NodeInfo -> NodeInfo -> a -> Message BValue
464encodeQueryPayload meth isReadonly tid self dest b = Q (nodeId self) tid (BE.toBEncode b) meth isReadonly
465
466errorPayload :: TransactionId -> NodeInfo -> NodeInfo -> Error -> Message a
467errorPayload tid self dest e = R (nodeId self) tid (Left e) (Just $ nodeAddr dest)
468
469decodePayload :: BEncode a => Message BValue -> Either String a
470decodePayload msg = BE.fromBEncode $ qryPayload msg
471
472type Handler = MethodHandler String TransactionId NodeInfo (Message BValue)
473
474handler :: ( BEncode a
475 , BEncode b
476 ) =>
477 (NodeInfo -> a -> IO b) -> Maybe Handler
478handler f = Just $ MethodHandler decodePayload encodeResponsePayload f
479
480
481handlerE :: ( BEncode a
482 , BEncode b
483 ) =>
484 (NodeInfo -> a -> IO (Either Error b)) -> Maybe Handler
485handlerE f = Just $ MethodHandler decodePayload enc f
486 where
487 enc tid self dest (Left e) = errorPayload tid self dest e
488 enc tid self dest (Right b) = encodeResponsePayload tid self dest b
489
490type AnnounceSet = Set (InfoHash, PortNumber)
491
492data SwarmsDatabase = SwarmsDatabase
493 { contactInfo :: !( TVar PeerStore ) -- ^ Published by other nodes.
494 , sessionTokens :: !( TVar SessionTokens ) -- ^ Query session IDs.
495 , announceInfo :: !( TVar AnnounceSet ) -- ^ To publish by this node.
496 }
497
498newSwarmsDatabase :: IO SwarmsDatabase
499newSwarmsDatabase = do
500 toks <- nullSessionTokens
501 atomically
502 $ SwarmsDatabase <$> newTVar def
503 <*> newTVar toks
504 <*> newTVar def
505
506data Routing = Routing
507 { tentativeId :: NodeInfo
508 , committee4 :: TriadCommittee NodeId SockAddr
509 , committee6 :: TriadCommittee NodeId SockAddr
510 , refresher4 :: BucketRefresher NodeId NodeInfo
511 , refresher6 :: BucketRefresher NodeId NodeInfo
512 }
513
514sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
515sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
516
517sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
518sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
519
520routing4 :: Routing -> TVar (R.BucketList NodeInfo)
521routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
522
523routing6 :: Routing -> TVar (R.BucketList NodeInfo)
524routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
525
526traced :: Show tid => TableMethods t tid -> TableMethods t tid
527traced (TableMethods ins del lkup)
528 = TableMethods (\tid mvar t -> trace ("insert "++show tid) $ ins tid mvar t)
529 (\tid t -> trace ("del "++show tid) $ del tid t)
530 (\tid t -> trace ("lookup "++show tid) $ lkup tid t)
531
532
533type MainlineClient = Client String Method TransactionId NodeInfo (Message BValue)
534
535-- | Like 'nodeInfo' but falls back to 'iNADDR_ANY' for nodeIP' and 'nodePort'.
536mkNodeInfo :: NodeId -> SockAddr -> NodeInfo
537mkNodeInfo nid addr = NodeInfo
538 { nodeId = nid
539 , nodeIP = fromMaybe (toEnum 0) $ fromSockAddr addr
540 , nodePort = fromMaybe 0 $ sockAddrPort addr
541 }
542
543newClient :: SwarmsDatabase -> SockAddr
544 -> IO ( MainlineClient
545 , Routing
546 , [NodeInfo] -> [NodeInfo] -> IO ()
547 , [NodeInfo] -> [NodeInfo] -> IO ()
548 )
549newClient swarms addr = do
550 udp <- udpTransport addr
551 nid <- NodeId <$> getRandomBytes 20
552 let tentative_info = mkNodeInfo nid addr
553 tentative_info6 <-
554 maybe tentative_info
555 (\ip6 -> tentative_info { nodeId = fromMaybe (nodeId tentative_info)
556 $ bep42 (toSockAddr ip6) (nodeId tentative_info)
557 , nodeIP = IPv6 ip6
558 })
559 <$> global6
560 addr4 <- atomically $ newTChan
561 addr6 <- atomically $ newTChan
562 mkrouting <- atomically $ do
563 -- We defer initializing the refreshSearch and refreshPing until we
564 -- have a client to send queries with.
565 let nullPing = const $ return False
566 nullSearch = mainlineSearch $ Left $ \_ _ -> return Nothing
567 tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info R.defaultBucketCount
568 refresher4 <- newBucketRefresher tbl4 nullSearch nullPing
569 tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount
570 refresher6 <- newBucketRefresher tbl6 nullSearch nullPing
571 let updateIPVote tblvar addrvar a = do
572 bkts <- readTVar tblvar
573 case bep42 a (nodeId $ R.thisNode bkts) of
574 Just nid -> do
575 let tbl = R.nullTable (comparing nodeId)
576 (\s -> hashWithSalt s . nodeId)
577 (mkNodeInfo nid a)
578 (R.defaultBucketCount)
579 writeTVar tblvar tbl
580 writeTChan addrvar (a,map fst $ concat $ R.toList bkts)
581 Nothing -> return ()
582 committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4
583 committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
584 return $ \client ->
585 -- Now we have a client, so tell the BucketRefresher how to search and ping.
586 let updIO r = updateRefresherIO (nodeSearch client) (ping client) r
587 in Routing tentative_info committee4 committee6 (updIO refresher4) (updIO refresher6)
588 map_var <- atomically $ newTVar (0, mempty)
589
590 let routing = mkrouting outgoingClient
591
592 net = onInbound (updateRouting outgoingClient routing)
593 $ layerTransport parsePacket encodePacket
594 $ udp
595
596 -- Paranoid: It's safe to define /net/ and /client/ to be mutually
597 -- recursive since 'updateRouting' does not invoke 'awaitMessage' which
598 -- which was modified by 'onInbound'. However, I'm going to avoid the
599 -- mutual reference just to be safe.
600 outgoingClient = client { clientNet = net { awaitMessage = ($ Nothing) } }
601
602 dispatch = DispatchMethods
603 { classifyInbound = classify -- :: x -> MessageClass err meth tid addr x
604 , lookupHandler = handlers -- :: meth -> Maybe (MethodHandler err tid addr x)
605 , tableMethods = mapT -- :: TransactionMethods tbl tid x
606 }
607
608 handlers :: Method -> Maybe Handler
609 handlers ( Method "ping" ) = handler pingH
610 handlers ( Method "find_node" ) = handler $ findNodeH routing
611 handlers ( Method "get_peers" ) = handler $ getPeersH routing swarms
612 handlers ( Method "announce_peer" ) = handlerE $ announceH swarms
613 handlers ( Method meth ) = Just $ defaultHandler meth
614
615 mapT = transactionMethods mapMethods gen
616
617 gen :: Word16 -> (TransactionId, Word16)
618 gen cnt = (TransactionId $ S.encode cnt, cnt+1)
619
620 ignoreParseError :: String -> IO ()
621 ignoreParseError _ = return ()
622
623 client = Client
624 { clientNet = addHandler ignoreParseError (handleMessage client) net
625 , clientDispatcher = dispatch
626 , clientErrorReporter = ignoreErrors -- printErrors stderr
627 , clientPending = map_var
628 , clientAddress = \maddr -> atomically $ do
629 let var = case flip prefer4or6 Nothing <$> maddr of
630 Just Want_IP6 -> routing6 routing
631 _ -> routing4 routing
632 R.thisNode <$> readTVar var
633 , clientResponseId = return
634 }
635
636 -- TODO: Provide some means of shutting down these five auxillary threads:
637
638 fork $ fix $ \again -> do
639 myThreadId >>= flip labelThread "addr4"
640 (addr, ns) <- atomically $ readTChan addr4
641 dput XBitTorrent $ "External IPv4: "++show (addr, length ns)
642 forM_ ns $ \n -> do
643 dput XBitTorrent $ "Change IP, ping: "++show n
644 ping outgoingClient n
645 -- TODO: trigger bootstrap ipv4
646 again
647 fork $ fix $ \again -> do
648 myThreadId >>= flip labelThread "addr6"
649 (addr,ns) <- atomically $ readTChan addr6
650 dput XBitTorrent $ "External IPv6: "++show (addr, length ns)
651 forM_ ns $ \n -> do
652 dput XBitTorrent $ "Change IP, ping: "++show n
653 ping outgoingClient n
654 -- TODO: trigger bootstrap ipv6
655 again
656
657
658 refresh_thread4 <- forkPollForRefresh $ refresher4 routing
659 refresh_thread6 <- forkPollForRefresh $ refresher6 routing
660
661 forkAnnouncedInfohashesGC (contactInfo swarms)
662
663 return (client, routing, bootstrap (refresher4 routing), bootstrap (refresher6 routing))
664
665-- Note that you should call .put() every hour for content that you want to
666-- keep alive, since nodes may discard data nodes older than 2 hours. (source:
667-- https://www.npmjs.com/package/bittorrent-dht)
668--
669-- This function will discard records between 3 and 6 hours old.
670forkAnnouncedInfohashesGC :: TVar PeerStore -> IO ThreadId
671forkAnnouncedInfohashesGC vpeers = fork $ do
672 myThreadId >>= flip labelThread "gc:bt-peers"
673 fix $ \loop -> do
674 cutoff <- getPOSIXTime
675 threadDelay 10800000000 -- 3 hours
676 atomically $ modifyTVar' vpeers $ deleteOlderThan cutoff
677 loop
678
679-- | Modifies a purely random 'NodeId' to one that is related to a given
680-- routable address in accordance with BEP 42.
681--
682-- Test vectors from the spec:
683--
684-- IP rand example node ID
685-- ============ ===== ==========================================
686-- 124.31.75.21 1 5fbfbf f10c5d6a4ec8a88e4c6ab4c28b95eee4 01
687-- 21.75.31.124 86 5a3ce9 c14e7a08645677bbd1cfe7d8f956d532 56
688-- 65.23.51.170 22 a5d432 20bc8f112a3d426c84764f8c2a1150e6 16
689-- 84.124.73.14 65 1b0321 dd1bb1fe518101ceef99462b947a01ff 41
690-- 43.213.53.83 90 e56f6c bf5b7c4be0237986d5243b87aa6d5130 5a
691bep42 :: SockAddr -> NodeId -> Maybe NodeId
692bep42 addr0 (NodeId r)
693 | let addr = either id id $ either4or6 addr0 -- unmap 4mapped SockAddrs
694 , Just ip <- fmap S.encode (fromSockAddr addr :: Maybe IPv4)
695 <|> fmap S.encode (fromSockAddr addr :: Maybe IPv6)
696 = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0)
697 | otherwise
698 = Nothing
699 where
700 ip4mask = "\x03\x0f\x3f\xff" :: ByteString
701 ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
702 nbhood_select = B.last r .&. 7
703 retr n = pure $ B.drop (B.length r - n) r
704 crc = S.encode . crc32c . B.pack
705 applyMask ip = case B.zipWith (.&.) msk ip of
706 (b:bs) -> (b .|. shiftL nbhood_select 5) : bs
707 bs -> bs
708 where msk | B.length ip == 4 = ip4mask
709 | otherwise = ip6mask
710
711
712
713defaultHandler :: ByteString -> Handler
714defaultHandler meth = MethodHandler decodePayload errorPayload returnError
715 where
716 returnError :: NodeInfo -> BValue -> IO Error
717 returnError _ _ = return $ Error MethodUnknown ("Unknown method " <> meth)
718
719mainlineKademlia :: MainlineClient
720 -> TriadCommittee NodeId SockAddr
721 -> BucketRefresher NodeId NodeInfo
722 -> Kademlia NodeId NodeInfo
723mainlineKademlia client committee refresher
724 = Kademlia quietInsertions
725 mainlineSpace
726 (vanillaIO (refreshBuckets refresher) $ ping client)
727 { tblTransition = \tr -> do
728 io1 <- transitionCommittee committee tr
729 io2 <- touchBucket refresher tr
730 return $ do
731 io1 >> io2
732 {- noisy (timestamp updates are currently reported as transitions to Accepted)
733 dput XBitTorrent $ unwords
734 [ show (transitionedTo tr)
735 , show (transitioningNode tr)
736 ] -}
737 }
738
739
740mainlineSpace :: R.KademliaSpace NodeId NodeInfo
741mainlineSpace = R.KademliaSpace
742 { R.kademliaLocation = nodeId
743 , R.kademliaTestBit = testIdBit
744 , R.kademliaXor = xor
745 , R.kademliaSample = genBucketSample'
746 }
747
748transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
749transitionCommittee committee (RoutingTransition ni Stranger) = do
750 delVote committee (nodeId ni)
751 return $ do
752 dput XBitTorrent $ "delVote "++show (nodeId ni)
753transitionCommittee committee _ = return $ return ()
754
755updateRouting :: MainlineClient -> Routing -> NodeInfo -> Message BValue -> IO ()
756updateRouting client routing naddr msg = do
757 case prefer4or6 naddr Nothing of
758 Want_IP4 -> go (committee4 routing) (refresher4 routing)
759 Want_IP6 -> go (committee6 routing) (refresher6 routing)
760 where
761 go committee refresher = do
762 self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
763 when (nodeIP self /= nodeIP naddr) $ do
764 case msg of
765 R { rspReflectedIP = Just sockaddr }
766 -> do
767 -- dput XBitTorrent $ "External: "++show (nodeId naddr,sockaddr)
768 atomically $ addVote committee (nodeId naddr) sockaddr
769 _ -> return ()
770 insertNode (mainlineKademlia client committee refresher) naddr
771
772data Ping = Ping deriving Show
773
774-- Pong is the same as Ping.
775type Pong = Ping
776pattern Pong = Ping
777
778instance BEncode Ping where
779 toBEncode Ping = toDict endDict
780 fromBEncode _ = pure Ping
781
782wantList :: WantIP -> [ByteString]
783wantList Want_IP4 = ["ip4"]
784wantList Want_IP6 = ["ip6"]
785wantList Want_Both = ["ip4","ip6"]
786
787instance BEncode WantIP where
788 toBEncode w = toBEncode $ wantList w
789 fromBEncode bval = do
790 wants <- fromBEncode bval
791 let _ = wants :: [ByteString]
792 case (elem "ip4" wants, elem "ip6" wants) of
793 (True,True) -> Right Want_Both
794 (True,False) -> Right Want_IP4
795 (False,True) -> Right Want_IP6
796 _ -> Left "Unrecognized IP type."
797
798data FindNode = FindNode NodeId (Maybe WantIP)
799
800instance BEncode FindNode where
801 toBEncode (FindNode nid iptyp) = toDict $ target_key .=! nid
802 .: want_key .=? iptyp
803 .: endDict
804 fromBEncode = fromDict $ FindNode <$>! target_key
805 <*>? want_key
806
807data NodeFound = NodeFound
808 { nodes4 :: [NodeInfo]
809 , nodes6 :: [NodeInfo]
810 }
811
812instance BEncode NodeFound where
813 toBEncode (NodeFound ns ns6) = toDict $
814 nodes_key .=?
815 (if Prelude.null ns then Nothing
816 else Just (S.runPut (mapM_ putNodeInfo4 ns)))
817 .: nodes6_key .=?
818 (if Prelude.null ns6 then Nothing
819 else Just (S.runPut (mapM_ putNodeInfo6 ns6)))
820 .: endDict
821
822 fromBEncode bval = NodeFound <$> ns4 <*> ns6
823 where
824 opt ns = fromMaybe [] <$> optional ns
825 ns4 = opt $ fromDict (binary getNodeInfo4 nodes_key) bval
826 ns6 = opt $ fromDict (binary getNodeInfo6 nodes6_key) bval
827
828binary :: S.Get a -> BKey -> BE.Get [a]
829binary get k = field (req k) >>= either (fail . format) return .
830 S.runGet (many get)
831 where
832 format str = "fail to deserialize " ++ show k ++ " field: " ++ str
833
834pingH :: NodeInfo -> Ping -> IO Pong
835pingH _ Ping = return Pong
836
837prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
838prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
839
840findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound
841findNodeH routing addr (FindNode node iptyp) = do
842 let preferred = prefer4or6 addr iptyp
843
844 (append4,append6) <- atomically $ do
845 ni4 <- R.thisNode <$> readTVar (routing4 routing)
846 ni6 <- R.thisNode <$> readTVar (routing6 routing)
847 return $ case ipFamily (nodeIP addr) of
848 Want_IP4 -> (id, (++ [ni6]))
849 Want_IP6 -> ((++ [ni4]), id)
850 ks <- bool (return []) (go append4 $ routing4 routing) (preferred /= Want_IP6)
851 ks6 <- bool (return []) (go append6 $ routing6 routing) (preferred /= Want_IP4)
852 return $ NodeFound ks ks6
853 where
854 go f var = f . R.kclosest mainlineSpace k node <$> atomically (readTVar var)
855
856 k = R.defaultK
857
858
859data GetPeers = GetPeers InfoHash (Maybe WantIP)
860
861instance BEncode GetPeers where
862 toBEncode (GetPeers ih iptyp)
863 = toDict $ info_hash_key .=! ih
864 .: want_key .=? iptyp
865 .: endDict
866 fromBEncode = fromDict $ GetPeers <$>! info_hash_key <*>? want_key
867
868
869data GotPeers = GotPeers
870 { -- | If the queried node has no peers for the infohash, returned
871 -- the K nodes in the queried nodes routing table closest to the
872 -- infohash supplied in the query.
873 peers :: [PeerAddr]
874
875 , nodes :: NodeFound
876
877 -- | The token value is a required argument for a future
878 -- announce_peer query.
879 , grantedToken :: Token
880 } -- deriving (Show, Eq, Typeable)
881
882nodeIsIPv6 :: NodeInfo -> Bool
883nodeIsIPv6 (NodeInfo _ (IPv6 _) _) = True
884nodeIsIPv6 _ = False
885
886instance BEncode GotPeers where
887 toBEncode GotPeers { nodes = NodeFound ns4 ns6, ..} = toDict $
888 nodes_key .=? (if null ns4 then Nothing
889 else Just $ S.runPut (mapM_ putNodeInfo4 ns4))
890 .: nodes6_key .=? (if null ns6 then Nothing
891 else Just $ S.runPut (mapM_ putNodeInfo4 ns6))
892 .: token_key .=! grantedToken
893 .: peers_key .=! map S.encode peers
894 .: endDict
895
896 fromBEncode = fromDict $ do
897 ns4 <- fromMaybe [] <$> optional (binary getNodeInfo4 nodes_key) -- "nodes"
898 ns6 <- fromMaybe [] <$> optional (binary getNodeInfo6 nodes6_key) -- "nodes6"
899 -- TODO: BEP 42...
900 --
901 -- Once enforced, responses to get_peers requests whose node ID does not
902 -- match its external IP should be considered to not contain a token and
903 -- thus not be eligible as storage target. Implementations should take
904 -- care that they find the closest set of nodes which return a token and
905 -- whose IDs matches their IPs before sending a store request to those
906 -- nodes.
907 --
908 -- Sounds like something to take care of at peer-search time, so I'll
909 -- ignore it for now.
910 tok <- field (req token_key) -- "token"
911 ps <- fromMaybe [] <$> optional (field (req peers_key) >>= decodePeers) -- "values"
912 pure $ GotPeers ps (NodeFound ns4 ns6) tok
913 where
914 decodePeers = either fail pure . mapM S.decode
915
916getPeersH :: Routing -> SwarmsDatabase -> NodeInfo -> GetPeers -> IO GotPeers
917getPeersH routing (SwarmsDatabase peers toks _) naddr (GetPeers ih iptyp) = do
918 ps <- do
919 tm <- getTimestamp
920 atomically $ do
921 (ps,store') <- Peers.freshPeers ih tm <$> readTVar peers
922 writeTVar peers store'
923 return ps
924 -- Filter peer results to only a single address family, IPv4 or IPv6, as
925 -- per BEP 32.
926 let notboth = iptyp >>= \case Want_Both -> Nothing
927 specific -> Just specific
928 selected = prefer4or6 naddr notboth
929 ps' = filter ( (== selected) . ipFamily . peerHost ) ps
930 tok <- grantToken toks naddr
931 ns <- findNodeH routing naddr (FindNode (coerce ih) iptyp)
932 return $ GotPeers ps' ns tok
933
934-- | Announce that the peer, controlling the querying node, is
935-- downloading a torrent on a port.
936data Announce = Announce
937 { -- | If set, the 'port' field should be ignored and the source
938 -- port of the UDP packet should be used as the peer's port
939 -- instead. This is useful for peers behind a NAT that may not
940 -- know their external port, and supporting uTP, they accept
941 -- incoming connections on the same port as the DHT port.
942 impliedPort :: Bool
943
944 -- | infohash of the torrent;
945 , topic :: InfoHash
946
947 -- | some clients announce the friendly name of the torrent here.
948 , announcedName :: Maybe ByteString
949
950 -- | the port /this/ peer is listening;
951 , port :: PortNumber
952
953 -- TODO: optional boolean "seed" key
954
955 -- | received in response to a previous get_peers query.
956 , sessionToken :: Token
957
958 } deriving (Show, Eq, Typeable)
959
960mkAnnounce :: PortNumber -> InfoHash -> Token -> Announce
961mkAnnounce portnum info token = Announce
962 { topic = info
963 , port = portnum
964 , sessionToken = token
965 , announcedName = Nothing
966 , impliedPort = False
967 }
968
969
970instance BEncode Announce where
971 toBEncode Announce {..} = toDict $
972 implied_port_key .=? flagField impliedPort
973 .: info_hash_key .=! topic
974 .: name_key .=? announcedName
975 .: port_key .=! port
976 .: token_key .=! sessionToken
977 .: endDict
978 where
979 flagField flag = if flag then Just (1 :: Int) else Nothing
980
981 fromBEncode = fromDict $ do
982 Announce <$> (boolField <$> optional (field (req implied_port_key)))
983 <*>! info_hash_key
984 <*>? name_key
985 <*>! port_key
986 <*>! token_key
987 where
988 boolField = maybe False (/= (0 :: Int))
989
990
991
992-- | The queried node must verify that the token was previously sent
993-- to the same IP address as the querying node. Then the queried node
994-- should store the IP address of the querying node and the supplied
995-- port number under the infohash in its store of peer contact
996-- information.
997data Announced = Announced
998 deriving (Show, Eq, Typeable)
999
1000instance BEncode Announced where
1001 toBEncode _ = toBEncode Ping
1002 fromBEncode _ = pure Announced
1003
1004announceH :: SwarmsDatabase -> NodeInfo -> Announce -> IO (Either Error Announced)
1005announceH (SwarmsDatabase peers toks _) naddr announcement = do
1006 checkToken toks naddr (sessionToken announcement)
1007 >>= bool (Left <$> return (Error ProtocolError "invalid parameter: token"))
1008 (Right <$> go)
1009 where
1010 go = atomically $ do
1011 modifyTVar' peers
1012 $ insertPeer (topic announcement) (announcedName announcement)
1013 $ PeerAddr
1014 { peerId = Nothing
1015 -- Avoid storing IPv4-mapped addresses.
1016 , peerHost = case nodeIP naddr of
1017 IPv6 ip6 | Just ip4 <- un4map ip6 -> IPv4 ip4
1018 a -> a
1019 , peerPort = if impliedPort announcement
1020 then nodePort naddr
1021 else port announcement
1022 }
1023 return Announced
1024
1025isReadonlyClient :: MainlineClient -> Bool
1026isReadonlyClient client = False -- TODO
1027
1028mainlineSend :: ( BEncode a
1029 , BEncode a2
1030 ) => Method
1031 -> (a2 -> b)
1032 -> (t -> a)
1033 -> MainlineClient
1034 -> t
1035 -> NodeInfo
1036 -> IO (Maybe b)
1037mainlineSend meth unwrap msg client nid addr = do
1038 reply <- sendQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr
1039 -- sendQuery will return (Just (Left _)) on a parse error. We're going to
1040 -- blow it away with the join-either sequence.
1041 -- TODO: Do something with parse errors.
1042 return $ join $ either (const Nothing) Just <$> reply
1043
1044mainlineAsync :: (BEncode a1, BEncode a2) =>
1045 Method
1046 -> (a2 -> a3)
1047 -> (t -> a1)
1048 -> Client String Method TransactionId NodeInfo (Message BValue)
1049 -> t
1050 -> NodeInfo
1051 -> (Maybe a3 -> IO ())
1052 -> IO ()
1053mainlineAsync meth unwrap msg client nid addr onresult = do
1054 asyncQuery client (mainlineSerializeer meth unwrap client) (msg nid) addr
1055 $ \reply ->
1056 -- sendQuery will return (Just (Left _)) on a parse error. We're going to
1057 -- blow it away with the join-either sequence.
1058 -- TODO: Do something with parse errors.
1059 onresult $ join $ either (const Nothing) Just <$> reply
1060
1061mainlineSerializeer :: (BEncode a2, BEncode a1) =>
1062 Method
1063 -> (a2 -> b)
1064 -> MainlineClient
1065 -> MethodSerializer
1066 TransactionId NodeInfo (Message BValue) Method a1 (Either Error b)
1067mainlineSerializeer meth unwrap client = MethodSerializer
1068 { methodTimeout = \_ ni -> return (ni, 5000000)
1069 , method = meth
1070 , wrapQuery = encodeQueryPayload meth (isReadonlyClient client)
1071 , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack)
1072 (Right . unwrap)
1073 . BE.fromBEncode)
1074 . rspPayload
1075 }
1076
1077ping :: MainlineClient -> NodeInfo -> IO Bool
1078ping client addr =
1079 fromMaybe False
1080 <$> mainlineSend (Method "ping") (\Pong -> True) (const Ping) client () addr
1081
1082-- searchQuery :: ni -> IO (Maybe [ni], [r], tok))
1083getNodes :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
1084getNodes = mainlineSend (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both)
1085
1086asyncGetNodes :: Client String Method TransactionId NodeInfo (Message BValue)
1087 -> NodeId
1088 -> NodeInfo
1089 -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ())
1090 -> IO ()
1091asyncGetNodes = mainlineAsync (Method "find_node") unwrapNodes $ flip FindNode (Just Want_Both)
1092
1093unwrapNodes :: NodeFound -> ([NodeInfo], [NodeInfo], Maybe ())
1094unwrapNodes (NodeFound ns4 ns6) = (ns4++ns6, ns4++ns6, Just ())
1095
1096getPeers :: MainlineClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[PeerAddr],Maybe Token))
1097getPeers = mainlineSend (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce
1098
1099asyncGetPeers :: Client String Method TransactionId NodeInfo (Message BValue)
1100 -> NodeId
1101 -> NodeInfo
1102 -> (Maybe ([NodeInfo], [PeerAddr], Maybe Token) -> IO ())
1103 -> IO ()
1104asyncGetPeers = mainlineAsync (Method "get_peers") unwrapPeers $ flip GetPeers (Just Want_Both) . coerce
1105
1106unwrapPeers :: GotPeers -> ([NodeInfo], [PeerAddr], Maybe Token)
1107unwrapPeers (GotPeers ps (NodeFound ns4 ns6) tok) = (ns4++ns6, ps, Just tok)
1108
1109mainlineSearch :: Either (NodeId -> NodeInfo -> IO (Maybe ([NodeInfo], [r], Maybe tok)))
1110 (NodeId -> NodeInfo -> (Maybe ([NodeInfo], [r], Maybe tok) -> IO ()) -> IO ())
1111 -> Search NodeId (IP, PortNumber) tok NodeInfo r
1112mainlineSearch qry = Search
1113 { searchSpace = mainlineSpace
1114 , searchNodeAddress = nodeIP &&& nodePort
1115 , searchQuery = qry
1116 , searchAlpha = 8
1117 , searchK = 16
1118 }
1119
1120nodeSearch :: MainlineClient -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
1121nodeSearch client = mainlineSearch (Right $ asyncGetNodes client)
1122
1123peerSearch :: MainlineClient -> Search NodeId (IP, PortNumber) Token NodeInfo PeerAddr
1124peerSearch client = mainlineSearch (Right $ asyncGetPeers client)
1125
1126-- | List of bootstrap nodes maintained by different bittorrent
1127-- software authors.
1128bootstrapNodes :: WantIP -> IO [NodeInfo]
1129bootstrapNodes want = unsafeInterleaveIO $ do
1130 let wellknowns =
1131 [ "router.bittorrent.com:6881" -- by BitTorrent Inc.
1132
1133 -- doesn't work at the moment (use git blame) of commit
1134 , "dht.transmissionbt.com:6881" -- by Transmission project
1135
1136 , "router.utorrent.com:6881"
1137 ]
1138 nss <- forM wellknowns $ \hostAndPort -> do
1139 e <- resolve want hostAndPort
1140 case e of
1141 Left _ -> return []
1142 Right sockaddr -> either (const $ return [])
1143 (return . (: []))
1144 $ nodeInfo zeroID sockaddr
1145 return $ concat nss
1146
1147-- | Resolve either a numeric network address or a hostname to a
1148-- numeric IP address of the node.
1149resolve :: WantIP -> String -> IO (Either IOError SockAddr)
1150resolve want hostAndPort = do
1151 let hints = defaultHints { addrSocketType = Datagram
1152 , addrFamily = case want of
1153 Want_IP4 -> AF_INET
1154 _ -> AF_INET6
1155 }
1156 (rport,rhost) = span (/= ':') $ reverse hostAndPort
1157 (host,port) = case rhost of
1158 [] -> (hostAndPort, Nothing)
1159 (_:hs) -> (reverse hs, Just (reverse rport))
1160 tryIOError $ do
1161 -- getAddrInfo throws exception on empty list, so this
1162 -- pattern matching never fails.
1163 info : _ <- getAddrInfo (Just hints) (Just host) port
1164 return $ addrAddress info
1165
1166
1167announce :: MainlineClient -> Announce -> NodeInfo -> IO (Maybe Announced)
1168announce client msg addr = do
1169 mainlineSend (Method "announce_peer") id (\() -> msg) client () addr
diff --git a/src/Network/BitTorrent/MainlineDHT/Symbols.hs b/src/Network/BitTorrent/MainlineDHT/Symbols.hs
deleted file mode 100644
index 05a64014..00000000
--- a/src/Network/BitTorrent/MainlineDHT/Symbols.hs
+++ /dev/null
@@ -1,24 +0,0 @@
1{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2module Network.BitTorrent.MainlineDHT.Symbols where
3
4import Data.BEncode.BDict
5
6peer_ip_key = "ip" :: BKey
7peer_id_key = "peer id" :: BKey
8peer_port_key = "port" :: BKey
9msg_type_key = "msg_type" :: BKey
10piece_key = "piece" :: BKey
11total_size_key = "total_size" :: BKey
12node_id_key = "id" :: BKey
13read_only_key = "ro" :: BKey
14want_key = "want" :: BKey
15target_key = "target" :: BKey
16nodes_key = "nodes" :: BKey
17nodes6_key = "nodes6" :: BKey
18info_hash_key = "info_hash" :: BKey
19peers_key = "values" :: BKey
20token_key = "token" :: BKey
21name_key = "name" :: BKey
22port_key = "port" :: BKey
23implied_port_key = "implied_port" :: BKey
24
diff --git a/src/Network/Kademlia.hs b/src/Network/Kademlia.hs
deleted file mode 100644
index e61afe9b..00000000
--- a/src/Network/Kademlia.hs
+++ /dev/null
@@ -1,163 +0,0 @@
1{-# LANGUAGE CPP, ScopedTypeVariables, PartialTypeSignatures, FlexibleContexts #-}
2{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE DeriveFunctor, DeriveTraversable #-}
4-- {-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE PatternSynonyms #-}
7module Network.Kademlia where
8
9import Data.Maybe
10import Data.Time.Clock.POSIX
11import Network.Kademlia.Routing as R
12#ifdef THREAD_DEBUG
13import Control.Concurrent.Lifted.Instrument
14#else
15import Control.Concurrent.Lifted
16import GHC.Conc (labelThread)
17#endif
18import Control.Concurrent.STM
19import Control.Monad
20import Data.Time.Clock.POSIX (POSIXTime)
21
22-- | The status of a given node with respect to a given routint table.
23data RoutingStatus
24 = Stranger -- ^ The node is unknown to the Kademlia routing table.
25 | Applicant -- ^ The node may be inserted pending a ping timeout.
26 | Accepted -- ^ The node has a slot in one of the Kademlia buckets.
27 deriving (Eq,Ord,Enum,Show,Read)
28
29-- | A change occured in the kademlia routing table.
30data RoutingTransition ni = RoutingTransition
31 { transitioningNode :: ni
32 , transitionedTo :: !RoutingStatus
33 }
34 deriving (Eq,Ord,Show,Read)
35
36data InsertionReporter ni = InsertionReporter
37 { -- | Called on every inbound packet. Accepts:
38 --
39 -- * Origin of packet.
40 --
41 -- * List of nodes to be pinged as a result.
42 reportArrival :: POSIXTime
43 -> ni
44 -> [ni]
45 -> IO ()
46 -- | Called on every ping probe. Accepts:
47 --
48 -- * Who was pinged.
49 --
50 -- * True Bool value if they ponged.
51 , reportPingResult :: POSIXTime
52 -> ni
53 -> Bool
54 -> IO ()
55 }
56
57quietInsertions :: InsertionReporter ni
58quietInsertions = InsertionReporter
59 { reportArrival = \_ _ _ -> return ()
60 , reportPingResult = \_ _ _ -> return ()
61 }
62
63contramapIR :: (t -> ni) -> InsertionReporter ni -> InsertionReporter t
64contramapIR f ir = InsertionReporter
65 { reportArrival = \tm ni nis -> reportArrival ir tm (f ni) (map f nis)
66 , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b
67 }
68
69-- | All the IO operations necessary to maintain a Kademlia routing table.
70data TableStateIO ni = TableStateIO
71 { -- | Write the routing table. Typically 'writeTVar'.
72 tblWrite :: R.BucketList ni -> STM ()
73
74 -- | Read the routing table. Typically 'readTVar'.
75 , tblRead :: STM (R.BucketList ni)
76
77 -- | Issue a ping to a remote node and report 'True' if the node
78 -- responded within an acceptable time and 'False' otherwise.
79 , tblPing :: ni -> IO Bool
80
81 -- | Convenience method provided to assist in maintaining state
82 -- consistent with the routing table. It will be invoked in the same
83 -- transaction that 'tblRead'\/'tblWrite' occured but only when there was
84 -- an interesting change. The returned IO action will be triggered soon
85 -- afterward.
86 --
87 -- It is not necessary to do anything interesting here. The following
88 -- trivial implementation is fine:
89 --
90 -- > tblTransition = const $ return $ return ()
91 , tblTransition :: RoutingTransition ni -> STM (IO ())
92 }
93
94vanillaIO :: TVar (BucketList ni) -> (ni -> IO Bool) -> TableStateIO ni
95vanillaIO var ping = TableStateIO
96 { tblRead = readTVar var
97 , tblWrite = writeTVar var
98 , tblPing = ping
99 , tblTransition = const $ return $ return ()
100 }
101
102-- | Everything necessary to maintain a routing table of /ni/ (node
103-- information) entries.
104data Kademlia nid ni = Kademlia { kademInsertionReporter :: InsertionReporter ni
105 , kademSpace :: KademliaSpace nid ni
106 , kademIO :: TableStateIO ni
107 }
108
109
110-- Helper to 'insertNode'.
111--
112-- Adapt return value from 'updateForPingResult' into a
113-- more easily grokked list of transitions.
114transition :: (ni,Maybe (t,ni)) -> [RoutingTransition ni]
115transition (x,m) =
116 -- Just _ <- m = Node transition: Accepted --> Stranger
117 -- Nothing <- m = Node transition: Applicant --> Stranger
118 RoutingTransition x Stranger
119 : maybeToList (accepted <$> m)
120
121-- Helper to 'transition'
122--
123-- Node transition: Applicant --> Accepted
124accepted :: (t,ni) -> RoutingTransition ni
125accepted (_,y) = RoutingTransition y Accepted
126
127
128insertNode :: Kademlia nid ni -> ni -> IO ()
129insertNode (Kademlia reporter space io) node = do
130
131 tm <- getPOSIXTime
132
133 (ps,reaction) <- atomically $ do
134 tbl <- tblRead io
135 let (inserted, ps,t') = R.updateForInbound space tm node tbl
136 tblWrite io t'
137 reaction <- case ps of
138 _ | inserted -> -- Node transition: Stranger --> Accepted
139 tblTransition io $ RoutingTransition node Accepted
140 (_:_) -> -- Node transition: Stranger --> Applicant
141 tblTransition io $ RoutingTransition node Applicant
142 _ -> return $ return ()
143 return (ps, reaction)
144
145 reportArrival reporter tm node ps
146 reaction
147
148 _ <- fork $ do
149 myThreadId >>= flip labelThread "pingResults"
150 forM_ ps $ \n -> do
151 b <- tblPing io n
152 reportPingResult reporter tm n b -- XXX: tm is timestamp of original triggering packet, not result
153 join $ atomically $ do
154 tbl <- tblRead io
155 let (replacements, t') = R.updateForPingResult space n b tbl
156 tblWrite io t'
157 ios <- sequence $ concatMap
158 (map (tblTransition io) . transition)
159 replacements
160 return $ sequence_ ios
161
162 return ()
163
diff --git a/src/Network/Kademlia/Bootstrap.hs b/src/Network/Kademlia/Bootstrap.hs
deleted file mode 100644
index 1324ae77..00000000
--- a/src/Network/Kademlia/Bootstrap.hs
+++ /dev/null
@@ -1,437 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveTraversable #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE KindSignatures #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE NamedFieldPuns #-}
10{-# LANGUAGE PartialTypeSignatures #-}
11{-# LANGUAGE PatternSynonyms #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14module Network.Kademlia.Bootstrap where
15
16import Data.Function
17import Data.Maybe
18import qualified Data.Set as Set
19import Data.Time.Clock.POSIX (getPOSIXTime)
20import Network.Kademlia.Routing as R
21#ifdef THREAD_DEBUG
22import Control.Concurrent.Lifted.Instrument
23#else
24import Control.Concurrent.Lifted
25import GHC.Conc (labelThread)
26#endif
27import Control.Concurrent.STM
28import Control.Monad
29import Data.Hashable
30import Data.Time.Clock.POSIX (POSIXTime)
31import Data.Ord
32import System.Entropy
33import System.Timeout
34import DPut
35import DebugTag
36
37import qualified Data.Wrapper.PSQInt as Int
38 ;import Data.Wrapper.PSQInt (pattern (:->))
39import Network.Address (bucketRange)
40import Network.Kademlia.Search
41import Control.Concurrent.Tasks
42import Network.Kademlia
43
44type SensibleNodeId nid ni =
45 ( Show nid
46 , Ord nid
47 , Ord ni
48 , Hashable nid
49 , Hashable ni )
50
51data BucketRefresher nid ni = forall tok addr. Ord addr => BucketRefresher
52 { -- | A staleness threshold (if a bucket goes this long without being
53 -- touched, a refresh will be triggered).
54 refreshInterval :: POSIXTime
55 -- | A TVar with the time-to-refresh schedule for each bucket.
56 --
57 -- To "touch" a bucket and prevent it from being refreshed, reschedule
58 -- its refresh time to some time into the future by modifying its
59 -- priority in this priority search queue.
60 , refreshQueue :: TVar (Int.PSQ POSIXTime)
61 -- | This is the kademlia node search specification.
62 , refreshSearch :: Search nid addr tok ni ni
63 -- | The current kademlia routing table buckets.
64 , refreshBuckets :: TVar (R.BucketList ni)
65 -- | Action to ping a node. This is used only during initial bootstrap
66 -- to get some nodes in our table. A 'True' result is interpreted as a a
67 -- pong, where 'False' is a non-response.
68 , refreshPing :: ni -> IO Bool
69 , -- | Timestamp of last bucket event.
70 refreshLastTouch :: TVar POSIXTime
71 , -- | This variable indicates whether or not we are in bootstrapping mode.
72 bootstrapMode :: TVar Bool
73 , -- | When this countdown reaches 0, we exit bootstrap mode. It is decremented on
74 -- every finished refresh.
75 bootstrapCountdown :: TVar (Maybe Int)
76 }
77
78newBucketRefresher :: ( Ord addr, Hashable addr
79 , SensibleNodeId nid ni )
80 => TVar (R.BucketList ni)
81 -> Search nid addr tok ni ni
82 -> (ni -> IO Bool)
83 -> STM (BucketRefresher nid ni)
84newBucketRefresher bkts sch ping = do
85 let spc = searchSpace sch
86 nodeId = kademliaLocation spc
87 -- bkts <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) template_ni R.defaultBucketCount
88 sched <- newTVar Int.empty
89 lasttouch <- newTVar 0 -- Would use getPOSIXTime here, or minBound, but alas...
90 bootstrapVar <- newTVar True -- Start in bootstrapping mode.
91 bootstrapCnt <- newTVar Nothing
92 return BucketRefresher
93 { refreshInterval = 15 * 60
94 , refreshQueue = sched
95 , refreshSearch = sch
96 , refreshBuckets = bkts
97 , refreshPing = ping
98 , refreshLastTouch = lasttouch
99 , bootstrapMode = bootstrapVar
100 , bootstrapCountdown = bootstrapCnt
101 }
102
103-- | This was added to avoid the compile error "Record update for
104-- insufficiently polymorphic field" when trying to update the existentially
105-- quantified field 'refreshSearch'.
106updateRefresherIO :: Ord addr
107 => Search nid addr tok ni ni
108 -> (ni -> IO Bool)
109 -> BucketRefresher nid ni -> BucketRefresher nid ni
110updateRefresherIO sch ping BucketRefresher{..} = BucketRefresher
111 { refreshSearch = sch
112 , refreshPing = ping
113 , refreshInterval = refreshInterval
114 , refreshBuckets = refreshBuckets
115 , refreshQueue = refreshQueue
116 , refreshLastTouch = refreshLastTouch
117 , bootstrapMode = bootstrapMode
118 , bootstrapCountdown = bootstrapCountdown
119 }
120
121-- | Fork a refresh loop. Kill the returned thread to terminate it.
122forkPollForRefresh :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO ThreadId
123forkPollForRefresh r@BucketRefresher{ refreshInterval
124 , refreshQueue
125 , refreshBuckets
126 , refreshSearch } = fork $ do
127 myThreadId >>= flip labelThread "pollForRefresh"
128 fix $ \again -> do
129 join $ atomically $ do
130 nextup <- Int.findMin <$> readTVar refreshQueue
131 maybe retry (return . go again) nextup
132 where
133 refresh :: Int -> IO Int
134 refresh n = do
135 -- dput XRefresh $ "Refresh time! "++ show n
136 refreshBucket r n
137
138 go again ( bktnum :-> refresh_time ) = do
139 now <- getPOSIXTime
140 case fromEnum (refresh_time - now) of
141 x | x <= 0 -> do -- Refresh time!
142 -- Move it to the back of the refresh queue.
143 atomically $ do
144 interval <- effectiveRefreshInterval r bktnum
145 modifyTVar' refreshQueue
146 $ Int.insert bktnum (now + interval)
147 -- Now fork the refresh operation.
148 -- TODO: We should probably propogate the kill signal to this thread.
149 fork $ do myThreadId >>= flip labelThread ("refresh."++show bktnum)
150 _ <- refresh bktnum
151 return ()
152 return ()
153 picoseconds -> do
154 -- dput XRefresh $ show (picoseconds `div` 10^12) ++ " seconds until refresh " ++ show bktnum
155 threadDelay ( picoseconds `div` 10^6 )
156 again
157
158
159-- | This is a helper to 'refreshBucket' which does some book keeping to decide
160-- whether or not a bucket is sufficiently refreshed or not. It will return
161-- false when we can terminate a node search.
162checkBucketFull :: Ord ni => KademliaSpace nid ni -- ^ Obtain a node id from a node.
163 -> TVar (BucketList ni) -- ^ The current routing table.
164 -> TVar (Set.Set ni) -- ^ In-range nodes found so far.
165 -> TVar Bool -- ^ The result will also be written here.
166 -> Int -- ^ The bucket number of interest.
167 -> ni -- ^ A newly found node.
168 -> STM Bool
169checkBucketFull space var resultCounter fin n found_node = do
170 let fullcount = R.defaultBucketSize
171 saveit True = writeTVar fin True >> return True
172 saveit _ = return False
173 tbl <- readTVar var
174 let counts = R.shape tbl
175 nid = kademliaLocation space found_node
176 -- Update the result set with every found node that is in the
177 -- bucket of interest.
178 when (n == R.bucketNumber space nid tbl)
179 $ modifyTVar' resultCounter (Set.insert found_node)
180 resultCount <- readTVar resultCounter
181 saveit $ case drop (n - 1) counts of
182 (cnt:_) | cnt < fullcount -> True -- bucket not full, keep going
183 _ | Set.size resultCount < fullcount -> True -- we haven't got many results, keep going
184 _ -> False -- okay, good enough, let's quit.
185
186-- | Called from 'refreshBucket' with the current time when a refresh of the
187-- supplied bucket number finishes.
188onFinishedRefresh :: BucketRefresher nid ni -> Int -> POSIXTime -> STM (IO ())
189onFinishedRefresh BucketRefresher { bootstrapCountdown
190 , bootstrapMode
191 , refreshQueue
192 , refreshBuckets } num now = do
193 bootstrapping <- readTVar bootstrapMode
194 if not bootstrapping then return $ return () -- dput XRefresh $ "Finished non-boostrapping refresh: "++show num
195 else do
196 tbl <- readTVar refreshBuckets
197 action <-
198 if num /= R.bktCount tbl - 1
199 then do modifyTVar' bootstrapCountdown (fmap pred)
200 return $ return () -- dput XRefresh $ "BOOTSTRAP decrement"
201 else do
202 -- The last bucket finished.
203 cnt <- readTVar bootstrapCountdown
204 case cnt of
205 Nothing -> do
206 let fullsize = R.defaultBucketSize
207 notfull (n,len) | n==num = False
208 | len>=fullsize = False
209 | otherwise = True
210 unfull = case filter notfull $ zip [0..] (R.shape tbl) of
211 [] -> [(0,0)] -- Schedule at least 1 more refresh.
212 xs -> xs
213 forM_ unfull $ \(n,_) -> do
214 -- Schedule immediate refresh for unfull buckets (other than this one).
215 modifyTVar' refreshQueue $ Int.insert n (now - 1)
216 writeTVar bootstrapCountdown $! Just $! length unfull
217 return $ return () -- dput XRefresh $ "BOOTSTRAP scheduling: "++show unfull
218 Just n -> do writeTVar bootstrapCountdown $! Just $! pred n
219 return $ return () -- dput XRefresh "BOOTSTRAP decrement (last bucket)"
220 cnt <- readTVar bootstrapCountdown
221 if (cnt == Just 0)
222 then do
223 -- Boostrap finished!
224 writeTVar bootstrapMode False
225 writeTVar bootstrapCountdown Nothing
226 return $ do action ; dput XRefresh $ "BOOTSTRAP complete (" ++ show (R.shape tbl) ++ ")."
227 else return $ do action ; dput XRefresh $ "BOOTSTRAP progress " ++ show (num,R.shape tbl,cnt)
228
229refreshBucket :: (Show nid, Ord ni, Ord nid, Hashable nid, Hashable ni) =>
230 BucketRefresher nid ni -> Int -> IO Int
231refreshBucket r@BucketRefresher{ refreshSearch = sch
232 , refreshBuckets = var }
233 n = do
234 tbl <- atomically (readTVar var)
235 let count = bktCount tbl
236 nid = kademliaLocation (searchSpace sch) (thisNode tbl)
237 sample <- if n+1 >= count -- Is this the last bucket?
238 then return nid -- Yes? Search our own id.
239 else kademliaSample (searchSpace sch) -- No? Generate a random id.
240 getEntropy
241 nid
242 (bucketRange n (n + 1 < count))
243 fin <- atomically $ newTVar False
244 resultCounter <- atomically $ newTVar Set.empty
245
246 dput XRefresh $ "Start refresh " ++ show (n,sample)
247
248 -- Set 15 minute timeout in order to avoid overlapping refreshes.
249 s <- search sch tbl sample $ if n+1 == R.defaultBucketCount
250 then const $ return True -- Never short-circuit the last bucket.
251 else checkBucketFull (searchSpace sch) var resultCounter fin n
252 _ <- timeout (15*60*1000000) $ do
253 atomically $ searchIsFinished s >>= check
254 atomically $ searchCancel s
255 dput XDHT $ "Finish refresh " ++ show (n,sample)
256 now <- getPOSIXTime
257 join $ atomically $ onFinishedRefresh r n now
258 rcount <- atomically $ do
259 c <- Set.size <$> readTVar resultCounter
260 b <- readTVar fin
261 return $ if b then 1 else c
262 return rcount
263
264refreshLastBucket :: SensibleNodeId nid ni => BucketRefresher nid ni -> IO ()
265refreshLastBucket r@BucketRefresher { refreshBuckets
266 , refreshQueue } = do
267
268 now <- getPOSIXTime
269 atomically $ do
270 cnt <- bktCount <$> readTVar refreshBuckets
271 -- Schedule immediate refresh.
272 modifyTVar' refreshQueue $ Int.insert (cnt-1) (now - 1)
273
274restartBootstrap :: (Hashable ni, Hashable nid, Ord ni, Ord nid, Show nid) =>
275 BucketRefresher nid ni -> STM (IO ())
276restartBootstrap r@BucketRefresher{ bootstrapMode, bootstrapCountdown } = do
277 unchanged <- readTVar bootstrapMode
278 writeTVar bootstrapMode True
279 writeTVar bootstrapCountdown Nothing
280 if not unchanged then return $ do
281 dput XRefresh "BOOTSTRAP entered bootstrap mode"
282 refreshLastBucket r
283 else return $ dput XRefresh "BOOTSTRAP already bootstrapping"
284
285bootstrap :: (Ord ni, Ord nid, Hashable nid, Hashable ni, Foldable t, Foldable t1, Show nid) =>
286 BucketRefresher nid ni
287 -> t1 ni -- ^ Nodes to bootstrap from.
288 -> t ni -- ^ Fallback nodes; used only if the others are unresponsive.
289 -> IO ()
290bootstrap r@BucketRefresher { refreshSearch = sch
291 , refreshBuckets = var
292 , refreshPing = ping
293 , bootstrapMode } ns ns0 = do
294 gotPing <- atomically $ newTVar False
295
296 -- First, ping the given nodes so that they are added to
297 -- our routing table.
298 withTaskGroup "bootstrap.resume" 20 $ \g -> do
299 forM_ ns $ \n -> do
300 let lbl = show $ kademliaLocation (searchSpace sch) n
301 forkTask g lbl $ do
302 b <- ping n
303 when b $ atomically $ writeTVar gotPing True
304
305 -- We resort to the hardcoded fallback nodes only when we got no
306 -- responses. This is to lesson the burden on well-known boostrap
307 -- nodes.
308 fallback <- atomically (readTVar gotPing) >>= return . when . not
309 fallback $ withTaskGroup "bootstrap.ping" 20 $ \g -> do
310 forM_ ns0 $ \n -> do
311 forkTask g (show $ kademliaLocation (searchSpace sch) n)
312 (void $ ping n)
313 dput XDHT "Finished bootstrap pings."
314 -- Now search our own Id by entering bootstrap mode from non-bootstrap mode.
315 join $ atomically $ do
316 writeTVar bootstrapMode False
317 restartBootstrap r
318 --
319 -- Hopefully 'forkPollForRefresh' was invoked and can take over
320 -- maintenance.
321
322
323effectiveRefreshInterval :: BucketRefresher nid ni -> Int -> STM POSIXTime
324effectiveRefreshInterval BucketRefresher{ refreshInterval
325 , refreshBuckets
326 , bootstrapMode } num = do
327 tbl <- readTVar refreshBuckets
328 bootstrapping <- readTVar bootstrapMode
329 case bootstrapping of
330 False -> return refreshInterval
331 True -> do
332 -- When bootstrapping, refresh interval for non-full buckets is only 15 seconds.
333 let fullcount = R.defaultBucketSize
334 count = fromMaybe fullcount $ listToMaybe $ drop (num - 1) $ R.shape tbl
335 if count == fullcount
336 then return refreshInterval
337 else return 15 -- seconds
338
339
340
341-- | Reschedule a bucket's refresh-time. It should be called whenever a bucket
342-- changes. This will typically be invoked from 'tblTransition'.
343--
344-- From BEP 05:
345--
346-- > Each bucket should maintain a "last changed" property to indicate how
347-- > "fresh" the contents are.
348--
349-- We will use a "time to next refresh" property instead and store it in
350-- a priority search queue.
351--
352-- In detail using an expository (not actually implemented) type
353-- 'BucketTouchEvent'...
354--
355-- >>> data BucketTouchEvent = RoutingStatus :--> RoutingStatus
356-- >>> bucketEvents =
357-- >>> [ Applicant :--> Stranger -- a node in a bucket is pinged and it responds,
358-- >>>
359-- >>> , Stranger :--> Accepted -- or a node is added to a bucket,
360-- >>>
361-- >>> , Accepted :--> Stranger -- or a node in a bucket is replaced
362-- >>> , Applicant :--> Accepted -- with another node,
363-- >>> ]
364--
365-- the bucket's last changed property should be updated. Buckets that have not
366-- been changed in 15 minutes (see 'refreshInterval') should be "refreshed."
367-- This is done by picking a random ID in the range of the bucket and
368-- performing a find_nodes search on it.
369--
370-- The only other possible BucketTouchEvents are as follows:
371--
372-- >>> not_handled =
373-- >>> , Stranger :--> Applicant -- A ping is pending, it's result is covered:
374-- >>> -- (Applicant :--> Stranger)
375-- >>> -- (Applicant :--> Accepted)
376-- >>> , Accepted :--> Applicant -- Never happens
377-- >>> ]
378--
379-- Because this BucketTouchEvent type is not actually implemented and we only
380-- receive notifications of a node's new state, it suffices to reschedule the
381-- bucket refresh 'touchBucket' on every transition to a state other than
382-- 'Applicant'.
383--
384-- XXX: Unfortunately, this means redundantly triggering twice upon every node
385-- replacement because we do not currently distinguish between standalone
386-- insertion/deletion events and an insertion/deletion pair constituting
387-- replacement.
388--
389-- It might also be better to pass the timestamp of the transition here and
390-- keep the refresh queue in better sync with the routing table by updating it
391-- within the STM monad.
392--
393-- We embed the result in the STM monad but currently, no STM state changes
394-- occur until the returned IO action is invoked. TODO: simplify?
395touchBucket :: SensibleNodeId nid ni
396 => BucketRefresher nid ni
397 -> RoutingTransition ni -- ^ What happened to the bucket?
398 -> STM (IO ())
399touchBucket r@BucketRefresher{ refreshSearch
400 , refreshInterval
401 , refreshBuckets
402 , refreshQueue
403 , refreshLastTouch
404 , bootstrapMode
405 , bootstrapCountdown }
406 RoutingTransition{ transitionedTo
407 , transitioningNode }
408 = case transitionedTo of
409 Applicant -> return $ return () -- Ignore transition to applicant.
410 _ -> return $ do -- Reschedule for any other transition.
411 now <- getPOSIXTime
412 join $ atomically $ do
413 let space = searchSpace refreshSearch
414 nid = kademliaLocation space transitioningNode
415 tbl <- readTVar refreshBuckets
416 let num = R.bucketNumber space nid tbl
417 stamp <- readTVar refreshLastTouch
418 action <- case stamp /= 0 && (now - stamp > 60) of
419 True -> do
420 -- It's been one minute since any bucket has been touched, re-enter bootstrap mode.
421 restartBootstrap r
422 False -> return $ return ()
423 interval <- effectiveRefreshInterval r num
424 modifyTVar' refreshQueue $ Int.insert num (now + interval)
425 writeTVar refreshLastTouch now
426 return action
427
428refreshKademlia :: SensibleNodeId nid ni => BucketRefresher nid ni -> Kademlia nid ni
429refreshKademlia r@BucketRefresher { refreshSearch = sch
430 , refreshPing = ping
431 , refreshBuckets = bkts
432 }
433 = Kademlia quietInsertions (searchSpace sch) (vanillaIO bkts ping)
434 { tblTransition = \tr -> do
435 io <- touchBucket r tr
436 return io
437 }
diff --git a/src/Network/Kademlia/CommonAPI.hs b/src/Network/Kademlia/CommonAPI.hs
deleted file mode 100644
index 601be5d8..00000000
--- a/src/Network/Kademlia/CommonAPI.hs
+++ /dev/null
@@ -1,84 +0,0 @@
1{-# LANGUAGE ExistentialQuantification #-}
2module Network.Kademlia.CommonAPI where
3
4
5import Control.Concurrent
6import Control.Concurrent.STM
7import Data.Aeson as J (FromJSON, ToJSON)
8import Data.Hashable
9import qualified Data.Map as Map
10import Data.Serialize as S
11import qualified Data.Set as Set
12import Data.Time.Clock.POSIX
13import Data.Typeable
14
15import Network.Kademlia.Search
16import Network.Kademlia.Routing as R
17import Crypto.Tox (SecretKey,PublicKey)
18
19data DHT = forall nid ni. ( Show ni
20 , Read ni
21 , ToJSON ni
22 , FromJSON ni
23 , Ord ni
24 , Hashable ni
25 , Show nid
26 , Ord nid
27 , Hashable nid
28 , Typeable ni
29 , S.Serialize nid
30 ) =>
31 DHT
32 { dhtBuckets :: TVar (BucketList ni)
33 , dhtSecretKey :: STM (Maybe SecretKey)
34 , dhtPing :: Map.Map String (DHTPing ni)
35 , dhtQuery :: Map.Map String (DHTQuery nid ni)
36 , dhtAnnouncables :: Map.Map String (DHTAnnouncable nid)
37 , dhtParseId :: String -> Either String nid
38 , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
39 , dhtFallbackNodes :: IO [ni]
40 , dhtBootstrap :: [ni] -> [ni] -> IO ()
41 }
42
43data DHTQuery nid ni = forall addr r tok.
44 ( Ord addr
45 , Typeable r
46 , Typeable tok
47 , Typeable ni
48 ) => DHTQuery
49 { qsearch :: Search nid addr tok ni r
50 , qhandler :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination.
51 , qshowR :: r -> String
52 , qshowTok :: tok -> Maybe String
53 }
54
55data DHTAnnouncable nid = forall dta tok ni r.
56 ( Show r
57 , Typeable dta -- information being announced
58 , Typeable tok -- token
59 , Typeable r -- search result
60 , Typeable ni -- node
61 ) => DHTAnnouncable
62 { announceParseData :: String -> Either String dta
63 , announceParseToken :: dta -> String -> Either String tok
64 , announceParseAddress :: String -> Either String ni
65 , announceSendData :: Either ( String {- search name -}
66 , String -> Either String r
67 , PublicKey {- me -} -> dta -> r -> IO ())
68 (dta -> tok -> Maybe ni -> IO (Maybe r))
69 , announceInterval :: POSIXTime
70 , announceTarget :: dta -> nid
71 }
72
73data DHTSearch nid ni = forall addr tok r. DHTSearch
74 { searchThread :: ThreadId
75 , searchState :: SearchState nid addr tok ni r
76 , searchShowTok :: tok -> Maybe String
77 , searchResults :: TVar (Set.Set String)
78 }
79
80data DHTPing ni = forall r. DHTPing
81 { pingQuery :: [String] -> ni -> IO (Maybe r)
82 , pingShowResult :: r -> String
83 }
84
diff --git a/src/Network/Kademlia/Persistence.hs b/src/Network/Kademlia/Persistence.hs
deleted file mode 100644
index d7431671..00000000
--- a/src/Network/Kademlia/Persistence.hs
+++ /dev/null
@@ -1,51 +0,0 @@
1{-# LANGUAGE NamedFieldPuns #-}
2module Network.Kademlia.Persistence where
3
4import Network.Kademlia.CommonAPI
5import Network.Kademlia.Routing as R
6
7import Control.Concurrent.STM
8import qualified Data.Aeson as J
9 ;import Data.Aeson as J (FromJSON)
10import qualified Data.ByteString.Lazy as L
11import qualified Data.HashMap.Strict as HashMap
12import Data.List
13import qualified Data.Vector as V
14import System.IO.Error
15
16saveNodes :: String -> DHT -> IO ()
17saveNodes netname DHT{dhtBuckets} = do
18 bkts <- atomically $ readTVar dhtBuckets
19 let ns = map fst $ concat $ R.toList bkts
20 bs = J.encode ns
21 fname = nodesFileName netname
22 L.writeFile fname bs
23
24loadNodes :: FromJSON ni => String -> IO [ni]
25loadNodes netname = do
26 let fname = nodesFileName netname
27 attempt <- tryIOError $ do
28 J.decode <$> L.readFile fname
29 >>= maybe (ioError $ userError "Nothing") return
30 either (const $ fallbackLoad fname) return attempt
31
32nodesFileName :: String -> String
33nodesFileName netname = netname ++ "-nodes.json"
34
35fallbackLoad :: FromJSON t => FilePath -> IO [t]
36fallbackLoad fname = do
37 attempt <- tryIOError $ do
38 J.decode <$> L.readFile fname
39 >>= maybe (ioError $ userError "Nothing") return
40 let go r = do
41 let m = HashMap.lookup "nodes" (r :: J.Object)
42 ns0 = case m of Just (J.Array v) -> V.toList v
43 Nothing -> []
44 ns1 = zip (map J.fromJSON ns0) ns0
45 issuc (J.Error _,_) = False
46 issuc _ = True
47 (ss,fs) = partition issuc ns1
48 ns = map (\(J.Success n,_) -> n) ss
49 mapM_ print (map snd fs) >> return ns
50 either (const $ return []) go attempt
51
diff --git a/src/Network/Kademlia/Routing.hs b/src/Network/Kademlia/Routing.hs
deleted file mode 100644
index a52cca73..00000000
--- a/src/Network/Kademlia/Routing.hs
+++ /dev/null
@@ -1,808 +0,0 @@
1-- |
2-- Copyright : (c) Sam Truzjan 2013
3-- (c) Joe Crayne 2017
4-- License : BSD3
5-- Maintainer : pxqr.sta@gmail.com
6-- Stability : experimental
7-- Portability : portable
8--
9-- Every node maintains a routing table of known good nodes. The
10-- nodes in the routing table are used as starting points for
11-- queries in the DHT. Nodes from the routing table are returned in
12-- response to queries from other nodes.
13--
14-- For more info see:
15-- <http://www.bittorrent.org/beps/bep_0005.html#routing-table>
16--
17{-# LANGUAGE CPP #-}
18{-# LANGUAGE RecordWildCards #-}
19{-# LANGUAGE BangPatterns #-}
20{-# LANGUAGE RankNTypes #-}
21{-# LANGUAGE ViewPatterns #-}
22{-# LANGUAGE TypeOperators #-}
23{-# LANGUAGE DeriveGeneric #-}
24{-# LANGUAGE DeriveFunctor #-}
25{-# LANGUAGE GADTs #-}
26{-# LANGUAGE ScopedTypeVariables #-}
27{-# LANGUAGE TupleSections #-}
28{-# LANGUAGE StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
29{-# OPTIONS_GHC -fno-warn-orphans #-}
30module Network.Kademlia.Routing
31 {-
32 ( -- * BucketList
33 BucketList
34 , Info(..)
35
36 -- * Attributes
37 , BucketCount
38 , defaultBucketCount
39 , BucketSize
40 , defaultBucketSize
41 , NodeCount
42
43 -- * Query
44 , Network.Kademlia.Routing.null
45 , Network.Kademlia.Routing.full
46 , thisId
47 , shape
48 , Network.Kademlia.Routing.size
49 , Network.Kademlia.Routing.depth
50 , compatibleNodeId
51
52 -- * Lookup
53 , K
54 , defaultK
55 , TableKey (..)
56 , kclosest
57
58 -- * Construction
59 , Network.Kademlia.Routing.nullTable
60 , Event(..)
61 , CheckPing(..)
62 , Network.Kademlia.Routing.insert
63
64 -- * Conversion
65 , Network.Kademlia.Routing.TableEntry
66 , Network.Kademlia.Routing.toList
67
68 -- * Routing
69 , Timestamp
70 , getTimestamp
71 ) -} where
72
73import Control.Applicative as A
74import Control.Arrow
75import Control.Monad
76import Data.Function
77import Data.Functor.Contravariant
78import Data.Functor.Identity
79import Data.List as L hiding (insert)
80import Data.Maybe
81import Data.Monoid
82import Data.Wrapper.PSQ as PSQ
83import Data.Serialize as S hiding (Result, Done)
84import qualified Data.Sequence as Seq
85import Data.Time
86import Data.Time.Clock.POSIX
87import Data.Word
88import GHC.Generics
89import Text.PrettyPrint as PP hiding ((<>))
90import Text.PrettyPrint.HughesPJClass (pPrint,Pretty)
91import qualified Data.ByteString as BS
92import Data.Bits
93import Data.Ord
94import Data.Reflection
95import Network.Address
96import Data.Typeable
97import Data.Coerce
98import Data.Hashable
99
100
101-- | Last time the node was responding to our queries.
102--
103-- Not all nodes that we learn about are equal. Some are \"good\" and
104-- some are not. Many nodes using the DHT are able to send queries
105-- and receive responses, but are not able to respond to queries
106-- from other nodes. It is important that each node's routing table
107-- must contain only known good nodes. A good node is a node has
108-- responded to one of our queries within the last 15 minutes. A
109-- node is also good if it has ever responded to one of our queries
110-- and has sent us a query within the last 15 minutes. After 15
111-- minutes of inactivity, a node becomes questionable. Nodes become
112-- bad when they fail to respond to multiple queries in a row. Nodes
113-- that we know are good are given priority over nodes with unknown
114-- status.
115--
116type Timestamp = POSIXTime
117
118getTimestamp :: IO Timestamp
119getTimestamp = do
120 utcTime <- getCurrentTime
121 return $ utcTimeToPOSIXSeconds utcTime
122
123
124
125{-----------------------------------------------------------------------
126 Bucket
127-----------------------------------------------------------------------}
128--
129-- When a k-bucket is full and a new node is discovered for that
130-- k-bucket, the least recently seen node in the k-bucket is
131-- PINGed. If the node is found to be still alive, the new node is
132-- place in a secondary list, a replacement cache. The replacement
133-- cache is used only if a node in the k-bucket stops responding. In
134-- other words: new nodes are used only when older nodes disappear.
135
136-- | Timestamp - last time this node is pinged.
137type NodeEntry ni = Binding ni Timestamp
138
139
140-- | Maximum number of 'NodeInfo's stored in a bucket. Most clients
141-- use this value.
142defaultBucketSize :: Int
143defaultBucketSize = 8
144
145data QueueMethods m elem fifo = QueueMethods
146 { pushBack :: elem -> fifo -> m fifo
147 , popFront :: fifo -> m (Maybe elem, fifo)
148 , emptyQueue :: m fifo
149 }
150
151{-
152fromQ :: Functor m =>
153 ( a -> b )
154 -> ( b -> a )
155 -> QueueMethods m elem a
156 -> QueueMethods m elem b
157fromQ embed project QueueMethods{..} =
158 QueueMethods { pushBack = \e -> fmap embed . pushBack e . project
159 , popFront = fmap (second embed) . popFront . project
160 , emptyQueue = fmap embed emptyQueue
161 }
162-}
163
164seqQ :: QueueMethods Identity ni (Seq.Seq ni)
165seqQ = QueueMethods
166 { pushBack = \e fifo -> pure (fifo Seq.|> e)
167 , popFront = \fifo -> case Seq.viewl fifo of
168 e Seq.:< fifo' -> pure (Just e, fifo')
169 Seq.EmptyL -> pure (Nothing, Seq.empty)
170 , emptyQueue = pure Seq.empty
171 }
172
173type BucketQueue ni = Seq.Seq ni
174
175bucketQ :: QueueMethods Identity ni (BucketQueue ni)
176bucketQ = seqQ
177
178
179data Compare a = Compare (a -> a -> Ordering) (Int -> a -> Int)
180
181contramapC :: (b -> a) -> Compare a -> Compare b
182contramapC f (Compare cmp hsh) = Compare (\a b -> cmp (f a) (f b))
183 (\s x -> hsh s (f x))
184
185newtype Ordered' s a = Ordered a
186 deriving (Show)
187
188-- | Hack to avoid UndecidableInstances
189newtype Shrink a = Shrink a
190 deriving (Show)
191
192type Ordered s a = Ordered' s (Shrink a)
193
194instance Reifies s (Compare a) => Eq (Ordered' s (Shrink a)) where
195 a == b = (compare a b == EQ)
196
197instance Reifies s (Compare a) => Ord (Ordered' s (Shrink a)) where
198 compare a b = cmp (coerce a) (coerce b)
199 where Compare cmp _ = reflect (Proxy :: Proxy s)
200
201instance Reifies s (Compare a) => Hashable (Ordered' s (Shrink a)) where
202 hashWithSalt salt x = hash salt (coerce x)
203 where Compare _ hash = reflect (Proxy :: Proxy s)
204
205-- | Bucket is also limited in its length — thus it's called k-bucket.
206-- When bucket becomes full, we should split it in two lists by
207-- current span bit. Span bit is defined by depth in the routing
208-- table tree. Size of the bucket should be choosen such that it's
209-- very unlikely that all nodes in bucket fail within an hour of
210-- each other.
211data Bucket s ni = Bucket
212 { bktNodes :: !(PSQ (Ordered s ni) Timestamp) -- current routing nodes
213 , bktQ :: !(BucketQueue (Timestamp,ni)) -- replacements pending time-outs
214 } deriving (Generic)
215
216#define CAN_SHOW_BUCKET 0
217
218#if CAN_SHOW_BUCKET
219deriving instance Show ni => Show (Bucket s ni)
220#endif
221
222bucketCompare :: forall p ni s. Reifies s (Compare ni) => p (Bucket s ni) -> Compare ni
223bucketCompare _ = reflect (Proxy :: Proxy s)
224
225mapBucket :: ( Reifies s (Compare a)
226 , Reifies t (Compare ni)
227 ) => (a -> ni) -> Bucket s a -> Bucket t ni
228mapBucket f (Bucket ns q) = Bucket (PSQ.fromList $ map (\(ni :-> tm) -> (f' ni :-> tm)) $ PSQ.toList ns)
229 (fmap (second f) q)
230 where f' = coerce . f . coerce
231
232
233#if 0
234
235{-
236getGenericNode :: ( Serialize (NodeId)
237 , Serialize ip
238 , Serialize u
239 ) => Get (NodeInfo)
240getGenericNode = do
241 nid <- get
242 naddr <- get
243 u <- get
244 return NodeInfo
245 { nodeId = nid
246 , nodeAddr = naddr
247 , nodeAnnotation = u
248 }
249
250putGenericNode :: ( Serialize (NodeId)
251 , Serialize ip
252 , Serialize u
253 ) => NodeInfo -> Put
254putGenericNode (NodeInfo nid naddr u) = do
255 put nid
256 put naddr
257 put u
258
259instance (Eq ip, Ord (NodeId), Serialize (NodeId), Serialize ip, Serialize u) => Serialize (Bucket) where
260 get = Bucket . psqFromPairList <$> getListOf ( (,) <$> getGenericNode <*> get ) <*> pure (runIdentity $ emptyQueue bucketQ)
261 put = putListOf (\(ni,stamp) -> putGenericNode ni >> put stamp) . psqToPairList . bktNodes
262-}
263
264#endif
265
266psqFromPairList :: (Ord p, PSQKey k) => [(k, p)] -> PSQ k p
267psqFromPairList xs = PSQ.fromList $ map (\(a,b) -> a :-> b) xs
268
269psqToPairList :: ( PSQKey t, Ord t1 ) => PSQ t t1 -> [(t, t1)]
270psqToPairList psq = map (\(a :-> b) -> (a,b)) $ PSQ.toList psq
271
272-- | Update interval, in seconds.
273delta :: NominalDiffTime
274delta = 15 * 60
275
276-- | Should maintain a set of stable long running nodes.
277--
278-- Note: pings are triggerd only when a bucket is full.
279updateBucketForInbound :: ( Coercible t1 t
280 , Alternative f
281 , Reifies s (Compare t1)
282 ) => NominalDiffTime -> t1 -> Bucket s t1 -> f ([t], Bucket s t1)
283updateBucketForInbound curTime info bucket
284 -- Just update timestamp if a node is already in bucket.
285 --
286 -- Note PingResult events should only occur for nodes we requested a ping for,
287 -- and those will always already be in the routing queue and will get their
288 -- timestamp updated here, since 'TryInsert' is called on every inbound packet,
289 -- including ping results.
290 | already_have
291 = pure ( [], map_ns $ PSQ.insertWith max (coerce info) curTime )
292 -- bucket is good, but not full => we can insert a new node
293 | PSQ.size (bktNodes bucket) < defaultBucketSize
294 = pure ( [], map_ns $ PSQ.insert (coerce info) curTime )
295 -- If there are any questionable nodes in the bucket have not been
296 -- seen in the last 15 minutes, the least recently seen node is
297 -- pinged. If any nodes in the bucket are known to have become bad,
298 -- then one is replaced by the new node in the next insertBucket
299 -- iteration.
300 | not (L.null stales)
301 = pure ( stales
302 , bucket { -- Update timestamps so that we don't redundantly ping.
303 bktNodes = updateStamps curTime (coerce stales) $ bktNodes bucket
304 -- Update queue with the pending NodeInfo in case of ping fail.
305 , bktQ = runIdentity $ pushBack bucketQ (curTime,info) $ bktQ bucket } )
306 -- When the bucket is full of good nodes, the new node is simply discarded.
307 -- We must return 'A.empty' here to ensure that bucket splitting happens
308 -- inside 'modifyBucket'.
309 | otherwise = A.empty
310 where
311 -- We (take 1) to keep a 1-to-1 correspondence between pending pings and
312 -- waiting nodes in the bktQ. This way, we don't have to worry about what
313 -- to do with failed pings for which there is no ready replacements.
314 stales = -- One stale:
315 do (n :-> t) <- maybeToList $ PSQ.findMin (bktNodes bucket)
316 guard (t < curTime - delta)
317 return $ coerce n
318 -- All stale:
319 -- map key \$ PSQ.atMost (curTime - delta) $ bktNodes bucket
320
321 already_have = maybe False (const True) $ PSQ.lookup (coerce info) (bktNodes bucket)
322
323 map_ns f = bucket { bktNodes = f (bktNodes bucket) }
324 -- map_q f = bucket { bktQ = runIdentity \$ f (bktQ bucket) }
325
326updateBucketForPingResult :: (Applicative f, Reifies s (Compare a)) =>
327 a -> Bool -> Bucket s a -> f ([(a, Maybe (Timestamp, a))], Bucket s a)
328updateBucketForPingResult bad_node got_response bucket
329 = pure ( map (,Nothing) forgotten
330 ++ map (second Just) replacements
331 , Bucket (foldr replace
332 (bktNodes bucket)
333 replacements)
334 popped
335 )
336 where
337 (top, popped) = runIdentity $ popFront bucketQ (bktQ bucket)
338
339 -- Dropped from accepted, replaced by pending.
340 replacements | got_response = [] -- Timestamp was already updated by TryInsert.
341 | Just info <- top = do
342 -- Insert only if there's a removal.
343 _ <- maybeToList $ PSQ.lookup (coerce bad_node) (bktNodes bucket)
344 return (bad_node, info)
345 | otherwise = []
346
347 -- Dropped from the pending queue without replacing.
348 forgotten | got_response = maybeToList $ fmap snd top
349 | otherwise = []
350
351
352 replace (bad_node, (tm, info)) =
353 PSQ.insert (coerce info) tm
354 . PSQ.delete (coerce bad_node)
355
356
357updateStamps :: PSQKey ni => Timestamp -> [ni] -> PSQ ni Timestamp -> PSQ ni Timestamp
358updateStamps curTime stales nodes = foldl' (\q n -> PSQ.insert n curTime q) nodes stales
359
360type BitIx = Word
361
362partitionQ :: Monad f => QueueMethods f elem b -> (elem -> Bool) -> b -> f (b, b)
363partitionQ imp test q0 = do
364 pass0 <- emptyQueue imp
365 fail0 <- emptyQueue imp
366 let flipfix a b f = fix f a b
367 flipfix q0 (pass0,fail0) $ \rec q qs -> do
368 (mb,q') <- popFront imp q
369 case mb of
370 Nothing -> return qs
371 Just e -> do qs' <- select (pushBack imp e) qs
372 rec q' qs'
373 where
374 select :: Functor f => (b -> f b) -> (b, b) -> f (b, b)
375 select f = if test e then \(a,b) -> flip (,) b <$> f a
376 else \(a,b) -> (,) a <$> f b
377
378
379
380split :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
381 forall ni s. ( Reifies s (Compare ni) ) =>
382 (ni -> Word -> Bool)
383 -> BitIx -> Bucket s ni -> (Bucket s ni, Bucket s ni)
384split testNodeIdBit i b = (Bucket ns qs, Bucket ms rs)
385 where
386 (ns,ms) = (PSQ.fromList *** PSQ.fromList) . partition (spanBit . coerce . key) . PSQ.toList $ bktNodes b
387 (qs,rs) = runIdentity $ partitionQ bucketQ (spanBit . snd) $ bktQ b
388
389 spanBit :: ni -> Bool
390 spanBit entry = testNodeIdBit entry i
391
392
393{-----------------------------------------------------------------------
394-- BucketList
395-----------------------------------------------------------------------}
396
397defaultBucketCount :: Int
398defaultBucketCount = 20
399
400defaultMaxBucketCount :: Word
401defaultMaxBucketCount = 24
402
403data Info ni nid = Info
404 { myBuckets :: BucketList ni
405 , myNodeId :: nid
406 , myAddress :: SockAddr
407 }
408 deriving Generic
409
410deriving instance (Eq ni, Eq nid) => Eq (Info ni nid)
411deriving instance (Show ni, Show nid) => Show (Info ni nid)
412
413-- instance (Eq ip, Serialize ip) => Serialize (Info ip)
414
415-- | The routing table covers the entire 'NodeId' space from 0 to 2 ^
416-- 160. The routing table is subdivided into 'Bucket's that each cover
417-- a portion of the space. An empty table has one bucket with an ID
418-- space range of @min = 0, max = 2 ^ 160@. When a node with ID \"N\"
419-- is inserted into the table, it is placed within the bucket that has
420-- @min <= N < max@. An empty table has only one bucket so any node
421-- must fit within it. Each bucket can only hold 'K' nodes, currently
422-- eight, before becoming 'Full'. When a bucket is full of known good
423-- nodes, no more nodes may be added unless our own 'NodeId' falls
424-- within the range of the 'Bucket'. In that case, the bucket is
425-- replaced by two new buckets each with half the range of the old
426-- bucket and the nodes from the old bucket are distributed among the
427-- two new ones. For a new table with only one bucket, the full bucket
428-- is always split into two new buckets covering the ranges @0..2 ^
429-- 159@ and @2 ^ 159..2 ^ 160@.
430--
431data BucketList ni = forall s. Reifies s (Compare ni) =>
432 BucketList { thisNode :: !ni
433 -- | Non-empty list of buckets.
434 , buckets :: [Bucket s ni]
435 }
436
437mapTable :: (b -> t) -> (t -> b) -> BucketList t -> BucketList b
438mapTable g f tbl@(BucketList self bkts) = reify (contramapC g $ bucketCompare bkts)
439 $ \p -> BucketList
440 { thisNode = f self
441 , buckets = map (resolve p . mapBucket f) bkts
442 }
443 where
444 resolve :: Proxy s -> Bucket s ni -> Bucket s ni
445 resolve = const id
446
447instance (Eq ni) => Eq (BucketList ni) where
448 (==) = (==) `on` Network.Kademlia.Routing.toList
449
450#if 0
451
452instance Serialize NominalDiffTime where
453 put = putWord32be . fromIntegral . fromEnum
454 get = (toEnum . fromIntegral) <$> getWord32be
455
456#endif
457
458#if CAN_SHOW_BUCKET
459deriving instance (Show ni) => Show (BucketList ni)
460#else
461instance Show ni => Show (BucketList ni) where
462 showsPrec d (BucketList self bkts) =
463 mappend "BucketList "
464 . showsPrec (d+1) self
465 . mappend " (fromList "
466 . showsPrec (d+1) (L.map (L.map tableEntry . PSQ.toList . bktNodes) $ bkts)
467 . mappend ") "
468#endif
469
470#if 0
471
472-- | Normally, routing table should be saved between invocations of
473-- the client software. Note that you don't need to store /this/
474-- 'NodeId' since it is already included in routing table.
475instance (Eq ip, Serialize ip, Ord (NodeId), Serialize (NodeId), Serialize u) => Serialize (BucketList)
476
477#endif
478
479-- | Shape of the table.
480instance Pretty (BucketList ni) where
481 pPrint t
482 | bucketCount < 6 = hcat $ punctuate ", " $ L.map PP.int ss
483 | otherwise = brackets $
484 PP.int (L.sum ss) <> " nodes, " <>
485 PP.int bucketCount <> " buckets"
486 where
487 bucketCount = L.length ss
488 ss = shape t
489
490-- | Empty table with specified /spine/ node id.
491--
492-- XXX: The comparison function argument is awkward here.
493nullTable :: (ni -> ni -> Ordering) -> (Int -> ni -> Int) -> ni -> Int -> BucketList ni
494nullTable cmp hsh ni n =
495 reify (Compare cmp hsh)
496 $ \p -> BucketList
497 ni
498 [Bucket (empty p) (runIdentity $ emptyQueue bucketQ)]
499 where
500 empty :: Reifies s (Compare ni) => Proxy s -> PSQ (Ordered s ni) Timestamp
501 empty = const $ PSQ.empty
502
503#if 0
504
505-- | Test if table is empty. In this case DHT should start
506-- bootstrapping process until table becomes 'full'.
507null :: BucketList -> Bool
508null (Tip _ _ b) = PSQ.null $ bktNodes b
509null _ = False
510
511-- | Test if table have maximum number of nodes. No more nodes can be
512-- 'insert'ed, except old ones becomes bad.
513full :: BucketList -> Bool
514full (Tip _ n _) = n == 0
515full (Zero t b) = PSQ.size (bktNodes b) == defaultBucketSize && full t
516full (One b t) = PSQ.size (bktNodes b) == defaultBucketSize && full t
517
518-- | Get the /spine/ node id.
519thisId :: BucketList -> NodeId
520thisId (Tip nid _ _) = nid
521thisId (Zero table _) = thisId table
522thisId (One _ table) = thisId table
523
524-- | Number of nodes in a bucket or a table.
525type NodeCount = Int
526
527#endif
528
529-- | Internally, routing table is similar to list of buckets or a
530-- /matrix/ of nodes. This function returns the shape of the matrix.
531shape :: BucketList ni -> [Int]
532shape (BucketList _ tbl) = map (PSQ.size . bktNodes) tbl
533
534#if 0
535
536-- | Get number of nodes in the table.
537size :: BucketList -> NodeCount
538size = L.sum . shape
539
540-- | Get number of buckets in the table.
541depth :: BucketList -> BucketCount
542depth = L.length . shape
543
544#endif
545
546lookupBucket :: forall ni nid x.
547 ( -- FiniteBits nid
548 Ord nid
549 ) => KademliaSpace nid ni -> nid -> (forall s. Reifies s (Compare ni) => [Bucket s ni] -> x) -> BucketList ni -> x
550lookupBucket space nid kont (BucketList self bkts) = kont $ go 0 [] bkts
551 where
552 d = kademliaXor space nid (kademliaLocation space self)
553
554 go :: Word -> [Bucket s ni] -> [Bucket s ni] -> [Bucket s ni]
555 go i bs (bucket : buckets)
556 | kademliaTestBit space d i = bucket : buckets ++ bs
557 | otherwise = go (succ i) (bucket:bs) buckets
558 go _ bs [] = bs
559
560bucketNumber :: forall ni nid.
561 KademliaSpace nid ni -> nid -> BucketList ni -> Int
562bucketNumber space nid (BucketList self bkts) = fromIntegral $ go 0 bkts
563 where
564 d = kademliaXor space nid (kademliaLocation space self)
565
566 go :: Word -> [Bucket s ni] -> Word
567 go i (bucket : buckets)
568 | kademliaTestBit space d i = i
569 | otherwise = go (succ i) buckets
570 go i [] = i
571
572
573compatibleNodeId :: forall ni nid.
574 ( Serialize nid, FiniteBits nid) =>
575 (ni -> nid) -> BucketList ni -> IO nid
576compatibleNodeId nodeId tbl = genBucketSample prefix br
577 where
578 br = bucketRange (L.length (shape tbl) - 1) True
579 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
580 bs = BS.pack $ take nodeIdSize $ tablePrefix (testIdBit . nodeId) tbl ++ repeat 0
581 prefix = either error id $ S.decode bs
582
583tablePrefix :: (ni -> Word -> Bool) -> BucketList ni -> [Word8]
584tablePrefix testbit = map (packByte . take 8 . (++repeat False))
585 . chunksOf 8
586 . tableBits testbit
587 where
588 packByte = foldl1' (.|.) . zipWith bitmask [7,6 .. 0]
589 bitmask ix True = bit ix
590 bitmask _ _ = 0
591
592tableBits :: (ni -> Word -> Bool) -> BucketList ni -> [Bool]
593tableBits testbit (BucketList self bkts) =
594 zipWith const (map (testbit self) [0..])
595 bkts
596
597selfNode :: BucketList ni -> ni
598selfNode (BucketList self _) = self
599
600chunksOf :: Int -> [e] -> [[e]]
601chunksOf i ls = map (take i) (build (splitter ls)) where
602 splitter :: [e] -> ([e] -> a -> a) -> a -> a
603 splitter [] _ n = n
604 splitter l c n = l `c` splitter (drop i l) c n
605
606build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
607build g = g (:) []
608
609
610
611-- | Count of closest nodes in find_node reply.
612type K = Int
613
614-- | Default 'K' is equal to 'defaultBucketSize'.
615defaultK :: K
616defaultK = 8
617
618#if 0
619class TableKey dht k where
620 toNodeId :: k -> NodeId
621
622instance TableKey dht (NodeId) where
623 toNodeId = id
624
625#endif
626
627-- | In Kademlia, the distance metric is XOR and the result is
628-- interpreted as an unsigned integer.
629newtype NodeDistance nodeid = NodeDistance nodeid
630 deriving (Eq, Ord)
631
632-- | distance(A,B) = |A xor B| Smaller values are closer.
633distance :: Bits nid => nid -> nid -> NodeDistance nid
634distance a b = NodeDistance $ xor a b
635
636-- | Order by closeness: nearest nodes first.
637rank :: ( Ord nid
638 ) => KademliaSpace nid ni -> nid -> [ni] -> [ni]
639rank space nid = L.sortBy (comparing (kademliaXor space nid . kademliaLocation space))
640
641
642-- | Get a list of /K/ closest nodes using XOR metric. Used in
643-- 'find_node' and 'get_peers' queries.
644kclosest :: ( -- FiniteBits nid
645 Ord nid
646 ) =>
647 KademliaSpace nid ni -> Int -> nid -> BucketList ni -> [ni]
648kclosest space k nid tbl = take k $ rank space nid (L.concat bucket)
649 ++ rank space nid (L.concat everyone)
650 where
651 (bucket,everyone) =
652 L.splitAt 1
653 . lookupBucket space nid (L.map (coerce . L.map PSQ.key . PSQ.toList . bktNodes))
654 $ tbl
655
656
657
658{-----------------------------------------------------------------------
659-- Routing
660-----------------------------------------------------------------------}
661
662splitTip :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
663 ( Reifies s (Compare ni) ) =>
664 (ni -> Word -> Bool)
665 -> ni -> BitIx -> Bucket s ni -> [ Bucket s ni ]
666splitTip testNodeBit ni i bucket
667 | testNodeBit ni i = [zeros , ones ]
668 | otherwise = [ones , zeros ]
669 where
670 (ones, zeros) = split testNodeBit i bucket
671
672-- | Used in each query.
673--
674-- TODO: Kademlia non-empty subtrees should should split if they have less than
675-- k nodes in them. Which subtrees I mean is illustrated in Fig 1. of Kademlia
676-- paper. The rule requiring additional splits is in section 2.4.
677modifyBucket
678 :: -- ( Eq ip , Ord (NodeId) , FiniteBits (NodeId)) =>
679 forall ni nid xs.
680 KademliaSpace nid ni
681 -> nid -> (forall s. Reifies s (Compare ni) => Bucket s ni -> Maybe (xs, Bucket s ni)) -> BucketList ni -> Maybe (xs,BucketList ni)
682modifyBucket space nid f (BucketList self bkts)
683 = second (BucketList self) <$> go (0 :: BitIx) bkts
684 where
685 d = kademliaXor space nid (kademliaLocation space self)
686
687 -- go :: BitIx -> [Bucket s ni] -> Maybe (xs, [Bucket s ni])
688
689 go !i (bucket : buckets@(_:_))
690 | kademliaTestBit space d i = second (: buckets) <$> f bucket
691 | otherwise = second (bucket :) <$> go (succ i) buckets
692
693 go !i [bucket] = second (: []) <$> f bucket <|> gosplit
694 where
695 gosplit | i < defaultMaxBucketCount = go i (splitTip ( kademliaTestBit space
696 . kademliaLocation space )
697 self
698 i
699 bucket)
700 | otherwise = Nothing -- Limit the number of buckets.
701
702
703bktCount :: BucketList ni -> Int
704bktCount (BucketList _ bkts) = L.length bkts
705
706-- | Triggering event for atomic table update
707data Event ni = TryInsert { foreignNode :: ni }
708 | PingResult { foreignNode :: ni , ponged :: Bool }
709
710#if 0
711deriving instance Eq (NodeId) => Eq (Event)
712deriving instance ( Show ip
713 , Show (NodeId)
714 , Show u
715 ) => Show (Event)
716
717#endif
718
719eventId :: (ni -> nid) -> Event ni -> nid
720eventId nodeId (TryInsert ni) = nodeId ni
721eventId nodeId (PingResult ni _) = nodeId ni
722
723
724-- | Actions requested by atomic table update
725data CheckPing ni = CheckPing [ni]
726
727#if 0
728
729deriving instance Eq (NodeId) => Eq (CheckPing)
730deriving instance ( Show ip
731 , Show (NodeId)
732 , Show u
733 ) => Show (CheckPing)
734
735#endif
736
737
738-- | Call on every inbound packet (including requested ping results).
739-- Returns a triple (was_inserted, to_ping, tbl') where
740--
741-- [ /was_inserted/ ] True if the node was added to the routing table.
742--
743-- [ /to_ping/ ] A list of nodes to ping and then run 'updateForPingResult'.
744-- This will be empty if /was_inserted/, but a non-inserted node
745-- may be added to a replacement queue and will be inserted if
746-- one of the items in this list time out.
747--
748-- [ /tbl'/ ] The updated routing 'BucketList'.
749--
750updateForInbound ::
751 KademliaSpace nid ni
752 -> Timestamp -> ni -> BucketList ni -> (Bool, [ni], BucketList ni)
753updateForInbound space tm ni tbl@(BucketList _ bkts) =
754 maybe (False, [],tbl) (\(ps,tbl') -> (True, ps, tbl'))
755 $ modifyBucket space
756 (kademliaLocation space ni)
757 (updateBucketForInbound tm ni)
758 tbl
759
760-- | Update the routing table with the results of a ping.
761--
762-- Each (a,(tm,b)) in the returned list indicates that the node /a/ was deleted from the
763-- routing table and the node /b/, with timestamp /tm/, has taken its place.
764updateForPingResult ::
765 KademliaSpace nid ni
766 -> ni -- ^ The pinged node.
767 -> Bool -- ^ True if we got a reply, False if it timed out.
768 -> BucketList ni -- ^ The routing table.
769 -> ( [(ni,Maybe (Timestamp, ni))], BucketList ni )
770updateForPingResult space ni got_reply tbl =
771 fromMaybe ([],tbl)
772 $ modifyBucket space
773 (kademliaLocation space ni)
774 (updateBucketForPingResult ni got_reply)
775 tbl
776
777
778{-----------------------------------------------------------------------
779-- Conversion
780-----------------------------------------------------------------------}
781
782type TableEntry ni = (ni, Timestamp)
783
784tableEntry :: NodeEntry ni -> TableEntry ni
785tableEntry (a :-> b) = (a, b)
786
787toList :: BucketList ni -> [[TableEntry ni]]
788toList (BucketList _ bkts) = coerce $ L.map (L.map tableEntry . PSQ.toList . bktNodes) bkts
789
790data KademliaSpace nid ni = KademliaSpace
791 { -- | Given a node record (probably including IP address), yields a
792 -- kademlia xor-metric location.
793 kademliaLocation :: ni -> nid
794 -- | Used when comparing locations. This is similar to
795 -- 'Data.Bits.testBit' except that the ordering of bits is reversed, so
796 -- that 0 is the most significant bit.
797 , kademliaTestBit :: nid -> Word -> Bool
798 -- | The Kademlia xor-metric.
799 , kademliaXor :: nid -> nid -> nid
800
801 , kademliaSample :: forall m. Applicative m => (Int -> m BS.ByteString) -> nid -> (Int,Word8,Word8) -> m nid
802 }
803
804instance Contravariant (KademliaSpace nid) where
805 contramap f ks = ks
806 { kademliaLocation = kademliaLocation ks . f
807 }
808
diff --git a/src/Network/Kademlia/Search.hs b/src/Network/Kademlia/Search.hs
deleted file mode 100644
index 1be1afc1..00000000
--- a/src/Network/Kademlia/Search.hs
+++ /dev/null
@@ -1,236 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE PatternSynonyms #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE LambdaCase #-}
7module Network.Kademlia.Search where
8
9import Control.Concurrent.Tasks
10import Control.Concurrent.STM
11import Control.Monad
12import Data.Function
13import Data.Maybe
14import qualified Data.Set as Set
15 ;import Data.Set (Set)
16import Data.Hashable (Hashable(..)) -- for type sigs
17import System.IO.Error
18
19import qualified Data.MinMaxPSQ as MM
20 ;import Data.MinMaxPSQ (MinMaxPSQ, MinMaxPSQ')
21import qualified Data.Wrapper.PSQ as PSQ
22 ;import Data.Wrapper.PSQ (pattern (:->), Binding, pattern Binding, Binding', PSQKey)
23import Network.Kademlia.Routing as R
24#ifdef THREAD_DEBUG
25import Control.Concurrent.Lifted.Instrument
26#else
27import Control.Concurrent.Lifted
28import GHC.Conc (labelThread)
29#endif
30
31data Search nid addr tok ni r = Search
32 { searchSpace :: KademliaSpace nid ni
33 , searchNodeAddress :: ni -> addr
34 , searchQuery :: Either (nid -> ni -> IO (Maybe ([ni], [r], Maybe tok)))
35 (nid -> ni -> (Maybe ([ni],[r],Maybe tok) -> IO ()) -> IO ())
36 , searchAlpha :: Int -- α = 8
37 -- | 'searchK' should be larger than 'searchAlpha'. How much larger depends on
38 -- how fast the queries are. For Tox's much slower onion-routed queries, we
39 -- need to ensure that closer non-responding queries don't completely push out
40 -- farther away queries.
41 --
42 -- For BitTorrent, setting them both 8 was not an issue, but that is no longer
43 -- supported because now the number of remembered informants is now the
44 -- difference between these two numbers. So, if searchK = 16 and searchAlpha =
45 -- 4, then the number of remembered query responses is 12.
46 , searchK :: Int -- K = 16
47 }
48
49data SearchState nid addr tok ni r = SearchState
50 { -- | The number of pending queries. Incremented before any query is sent
51 -- and decremented when we get a reply.
52 searchPendingCount :: TVar Int
53 -- | Nodes scheduled to be queried (roughly at most K).
54 , searchQueued :: TVar (MinMaxPSQ ni nid)
55 -- | The nearest (K - α) nodes that issued a reply.
56 --
57 -- α is the maximum number of simultaneous queries.
58 , searchInformant :: TVar (MinMaxPSQ' ni nid (Maybe tok))
59 -- | This tracks already-queried addresses so we avoid bothering them
60 -- again. XXX: We could probably keep only the pending queries in this
61 -- set. It also can be a bounded 'MinMaxPSQ', although searchAlpha
62 -- should limit the number of outstanding queries.
63 , searchVisited :: TVar (Set addr)
64 , searchSpec :: Search nid addr tok ni r
65 }
66
67
68newSearch :: ( Ord addr
69 , PSQKey nid
70 , PSQKey ni
71 ) =>
72 {-
73 KademliaSpace nid ni
74 -> (ni -> addr)
75 -> (ni -> IO ([ni], [r])) -- the query action.
76 -> (r -> STM Bool) -- receives search results.
77 -> nid -- target of search
78 -}
79 Search nid addr tok ni r
80 -> nid
81 -> [ni] -- Initial nodes to query.
82 -> STM (SearchState nid addr tok ni r)
83newSearch s@(Search space nAddr qry _ _) target ns = do
84 c <- newTVar 0
85 q <- newTVar $ MM.fromList
86 $ map (\n -> n :-> kademliaXor space target (kademliaLocation space n))
87 $ ns
88 i <- newTVar MM.empty
89 v <- newTVar Set.empty
90 return -- (Search space nAddr qry) , r , target
91 ( SearchState c q i v s )
92
93-- | Discard a value from a key-priority-value tuple. This is useful for
94-- swaping items from a "MinMaxPSQ'" to a "MinMaxPSQ".
95stripValue :: Binding' k p v -> Binding k p
96stripValue (Binding ni _ nid) = (ni :-> nid)
97
98-- | Reset a 'SearchState' object to ready it for a repeated search.
99reset :: (Ord ni, Ord nid, Hashable ni, Hashable nid) =>
100 (nid -> STM [ni])
101 -> Search nid addr1 tok1 ni r1
102 -> nid
103 -> SearchState nid addr tok ni r
104 -> STM (SearchState nid addr tok ni r)
105reset nearestNodes qsearch target st = do
106 searchIsFinished st >>= check -- Wait for a search to finish before resetting.
107 bktNodes <- map (\ni -> ni :-> kademliaLocation (searchSpace qsearch) ni)
108 <$> nearestNodes target
109 priorInformants <- map stripValue . MM.toList <$> readTVar (searchInformant st)
110 writeTVar (searchQueued st) $ MM.fromList $ priorInformants ++ bktNodes
111 writeTVar (searchInformant st) MM.empty
112 writeTVar (searchVisited st) Set.empty
113 writeTVar (searchPendingCount st) 0
114 return st
115
116sendAsyncQuery :: forall addr nid tok ni r.
117 ( Ord addr
118 , PSQKey nid
119 , PSQKey ni
120 , Show nid
121 ) =>
122 Search nid addr tok ni r
123 -> nid
124 -> (r -> STM Bool) -- ^ return False to terminate the search.
125 -> SearchState nid addr tok ni r
126 -> Binding ni nid
127 -> TaskGroup
128 -> IO ()
129sendAsyncQuery Search{..} searchTarget searchResult sch@SearchState{..} (ni :-> d) g =
130 case searchQuery of
131 Left blockingQuery ->
132 forkTask g "searchQuery" $ do
133 myThreadId >>= flip labelThread ("searchQuery." ++ show searchTarget)
134 reply <- blockingQuery searchTarget ni `catchIOError` const (return Nothing)
135 atomically $ do
136 modifyTVar searchPendingCount pred
137 maybe (return ()) go reply
138 Right nonblockingQuery -> do
139 nonblockingQuery searchTarget ni $ \reply ->
140 atomically $ do
141 modifyTVar searchPendingCount pred
142 maybe (return ()) go reply
143 where
144 go (ns,rs,tok) = do
145 vs <- readTVar searchVisited
146 -- We only queue a node if it is not yet visited
147 let insertFoundNode :: Int
148 -> ni
149 -> MinMaxPSQ ni nid
150 -> MinMaxPSQ ni nid
151 insertFoundNode k n q
152 | searchNodeAddress n `Set.member` vs
153 = q
154 | otherwise = MM.insertTake k n ( kademliaXor searchSpace searchTarget
155 $ kademliaLocation searchSpace n )
156 q
157
158 qsize0 <- MM.size <$> readTVar searchQueued
159 let qsize = if qsize0 < searchK then searchK else qsize0 -- Allow searchQueued to grow
160 -- only when there's fewer than
161 -- K elements.
162 modifyTVar searchQueued $ \q -> foldr (insertFoundNode qsize) q ns
163 modifyTVar searchInformant $ MM.insertTake' (searchK - searchAlpha) ni tok d
164 flip fix rs $ \loop -> \case
165 r:rs' -> do
166 wanting <- searchResult r
167 if wanting then loop rs'
168 else searchCancel sch
169 [] -> return ()
170
171
172searchIsFinished :: ( PSQKey nid
173 , PSQKey ni
174 ) => SearchState nid addr tok ni r -> STM Bool
175searchIsFinished SearchState{..} = do
176 q <- readTVar searchQueued
177 cnt <- readTVar searchPendingCount
178 informants <- readTVar searchInformant
179 return $ cnt == 0
180 && ( MM.null q
181 || ( MM.size informants >= (searchK searchSpec - searchAlpha searchSpec)
182 && ( PSQ.prio (fromJust $ MM.findMax informants)
183 <= PSQ.prio (fromJust $ MM.findMin q))))
184
185searchCancel :: SearchState nid addr tok ni r -> STM ()
186searchCancel SearchState{..} = do
187 writeTVar searchPendingCount 0
188 writeTVar searchQueued MM.empty
189
190search ::
191 ( Ord r
192 , Ord addr
193 , PSQKey nid
194 , PSQKey ni
195 , Show nid
196 ) => Search nid addr tok ni r -> R.BucketList ni -> nid -> (r -> STM Bool) -> IO (SearchState nid addr tok ni r)
197search sch buckets target result = do
198 let ns = R.kclosest (searchSpace sch) (searchK sch) target buckets
199 st <- atomically $ newSearch sch target ns
200 forkIO $ searchLoop sch target result st
201 return st
202
203searchLoop :: ( Ord addr, Ord nid, Ord ni, Show nid, Hashable nid, Hashable ni )
204 => Search nid addr tok ni r -- ^ Query and distance methods.
205 -> nid -- ^ The target we are searching for.
206 -> (r -> STM Bool) -- ^ Invoked on each result. Return False to quit searching.
207 -> SearchState nid addr tok ni r -- ^ Search-related state.
208 -> IO ()
209searchLoop sch@Search{..} target result s@SearchState{..} = do
210 myThreadId >>= flip labelThread ("search."++show target)
211 withTaskGroup ("search.g."++show target) searchAlpha $ \g -> fix $ \again -> do
212 join $ atomically $ do
213 cnt <- readTVar $ searchPendingCount
214 check (cnt <= 8) -- Only 8 pending queries at a time.
215 informants <- readTVar searchInformant
216 found <- MM.minView <$> readTVar searchQueued
217 case found of
218 Just (ni :-> d, q)
219 | -- If there's fewer than /k - α/ informants and there's any
220 -- node we haven't yet got a response from.
221 (MM.size informants < searchK - searchAlpha) && (cnt > 0 || not (MM.null q))
222 -- Or there's no informants yet at all.
223 || MM.null informants
224 -- Or if the closest scheduled node is nearer than the
225 -- nearest /k/ informants.
226 || (d < PSQ.prio (fromJust $ MM.findMax informants))
227 -> -- Then the search continues, send a query.
228 do writeTVar searchQueued q
229 modifyTVar searchVisited $ Set.insert (searchNodeAddress ni)
230 modifyTVar searchPendingCount succ
231 return $ do
232 sendAsyncQuery sch target result s (ni :-> d) g
233 again
234 _ -> -- Otherwise, we are finished.
235 do check (cnt == 0)
236 return $ return ()
diff --git a/src/Network/Lossless.hs b/src/Network/Lossless.hs
deleted file mode 100644
index 861792ab..00000000
--- a/src/Network/Lossless.hs
+++ /dev/null
@@ -1,124 +0,0 @@
1-- | This module uses 'Data.PacketBuffer' appropriately to implement a reliable
2-- transport over an underlying lossy one.
3--
4-- It was written to be a helper to 'Network.Tox.Session' but it is
5-- representation-agnostic and so could potentially be used on an unrelated
6-- lossy transport.
7{-# LANGUAGE CPP #-}
8{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE TupleSections #-}
10module Network.Lossless where
11
12import Control.Concurrent.STM.TChan
13import Control.Monad
14import Control.Monad.STM
15import Data.Function
16import Data.Word
17import System.IO.Error
18
19import Data.PacketBuffer as PB
20import DPut
21import DebugTag
22import Network.QueryResponse
23
24#ifdef THREAD_DEBUG
25import Control.Concurrent.Lifted.Instrument
26#else
27import Control.Concurrent.Lifted
28#endif
29
30-- | Sequencing information for a packet.
31data SequenceInfo = SequenceInfo
32 { sequenceNumber :: {-# UNPACK #-} !Word32 -- ^ Packets are ordered by their 'sequenceNumber'.
33 , sequenceAck :: {-# UNPACK #-} !Word32 -- ^ This is the sender's latest received in-order packet.
34 }
35 deriving (Eq,Ord,Show)
36
37data OutgoingInfo y = OutgoingInfo
38 { oIsLossy :: Bool -- ^ True if the packet is treated as lossy.
39 , oEncoded :: y -- ^ The packet.
40 , oHandleException :: Maybe (IOError -> IO ()) -- ^ Optionally handle send failure.
41 }
42
43-- | Obtain a reliable transport form an unreliable one.
44lossless :: Show addr =>
45 (x -> addr -> IO (PacketInboundEvent (x',addr'))) -- ^ Used to classify newly arrived packets.
46 -> (SequenceInfo -> x' -> addr' -> IO (OutgoingInfo y)) -- ^ Used to encode and classify outbound packets.
47 -> addr -- ^ The remote address for this session.
48 -> TransportA String addr x y -- ^ An unreliable lossy transport.
49
50 -> IO ( Transport String addr' x' -- ^ A reliable lossless transport.
51 , [Word32] -> IO () -- ^ Use this to request lost packets be re-sent.
52 , IO ([Word32],Word32) -- ^ Use this to discover missing packets to request.
53 )
54lossless isLossless encode saddr udp = do
55 pb <- atomically newPacketBuffer
56 oob <- atomically newTChan -- Out-of-band channel, these packets (or
57 -- errors) bypass the packet buffer to be
58 -- received immediately.
59 rloop <- forkIO $ do
60 -- This thread enqueues inbound packets or writes them to the oob
61 -- channel.
62 myThreadId >>= flip labelThread ("lossless."++show saddr)
63 fix $ \loop -> do
64 awaitMessage udp $ \m -> do
65 m' <- mapM (mapM $ uncurry isLossless) m
66 case m' of
67 Nothing -> do
68 atomically $ writeTChan oob Nothing
69 -- Quit thread here.
70 Just (Left e) -> do
71 atomically $ writeTChan oob (Just $ Left e)
72 loop
73 Just (Right event) -> do
74 atomically $ do
75 -- x' <- isLossless xaddr x
76 PB.grokInboundPacket pb event
77 case event of
78 PacketReceivedLossy {} -> writeTChan oob (Just $ Right $ peReceivedPayload event)
79 _ -> do
80 report <- pbReport "enqueued" pb
81 writeTChan oob (Just $ Left report)
82 loop
83 let tr = Transport
84 { awaitMessage = \kont -> do
85 join $ atomically $ orElse
86 (do x <- readTChan oob
87 return $ kont $! x)
88 (do x <- PB.awaitReadyPacket pb
89 report <- pbReport "dequeued" pb
90 return $ do
91 atomically $ writeTChan oob (Just $ Left report)
92 kont $! Just (Right x))
93 , sendMessage = \a' x' -> do
94 seqno <- atomically $ do
95 seqno <- PB.nextToSendSequenceNumber pb
96 ack <- PB.expectingSequenceNumber pb
97 return $ SequenceInfo seqno ack
98 OutgoingInfo islossy x oops <- encode seqno x' a'
99 (isfull,nn) <-
100 if islossy
101 then do
102 dput XNetCrypto $ shows saddr $ " <-- Lossy packet " ++ show seqno
103 return (False,(0,0)) -- avoid updating seqno on lossy packets.
104 else do
105 dput XNetCrypto $ shows saddr $ " <-- Lossless packet " ++ show seqno
106 atomically $ PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x)
107 when isfull $ do
108 dput XNetCrypto $ shows saddr $ " <-- Outbound queue is full! Retrying... " ++ show (nn,seqno)
109 atomically $ do
110 (isfull,_) <- PB.grokOutboundPacket pb (PacketSent (sequenceNumber seqno) x)
111 when isfull retry
112 let sendit = sendMessage udp saddr x
113 maybe sendit (catchIOError sendit) oops
114 , closeTransport = do
115 atomically $ writeTChan oob Nothing -- quit rloop thread
116 closeTransport udp
117 }
118 resend ns = do
119 xs <- atomically $ retrieveForResend pb ns
120 dput XNetCrypto $ shows saddr $ " <-- Resending " ++ show (length xs) ++ " packets."
121 forM_ xs $ \x -> do
122 dput XNetCrypto $ shows saddr $ " <-- Resending packet."
123 sendMessage udp saddr . snd $ x
124 return (tr, resend, atomically $ PB.packetNumbersToRequest pb)
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
deleted file mode 100644
index c4ff50e3..00000000
--- a/src/Network/QueryResponse.hs
+++ /dev/null
@@ -1,638 +0,0 @@
1-- | This module can implement any query\/response protocol. It was written
2-- with Kademlia implementations in mind.
3
4{-# LANGUAGE CPP #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE PartialTypeSignatures #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TupleSections #-}
11module Network.QueryResponse where
12
13#ifdef THREAD_DEBUG
14import Control.Concurrent.Lifted.Instrument
15#else
16import Control.Concurrent
17import GHC.Conc (labelThread)
18#endif
19import Control.Concurrent.STM
20import Control.Exception
21import Control.Monad
22import qualified Data.ByteString as B
23 ;import Data.ByteString (ByteString)
24import Data.Function
25import Data.Functor.Contravariant
26import qualified Data.IntMap.Strict as IntMap
27 ;import Data.IntMap.Strict (IntMap)
28import qualified Data.Map.Strict as Map
29 ;import Data.Map.Strict (Map)
30import Data.Time.Clock.POSIX
31import qualified Data.Word64Map as W64Map
32 ;import Data.Word64Map (Word64Map)
33import Data.Word
34import Data.Maybe
35import GHC.Event
36import Network.Socket
37import Network.Socket.ByteString as B
38import System.Endian
39import System.IO
40import System.IO.Error
41import System.Timeout
42import DPut
43import DebugTag
44import Data.TableMethods
45
46-- | Three methods are required to implement a datagram based query\/response protocol.
47data TransportA err addr x y = Transport
48 { -- | Blocks until an inbound packet is available. Returns 'Nothing' when
49 -- no more packets are expected due to a shutdown or close event.
50 -- Otherwise, the packet will be parsed as type /x/ and an origin address
51 -- /addr/. Parse failure is indicated by the type 'err'.
52 awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a
53 -- | Send an /y/ packet to the given destination /addr/.
54 , sendMessage :: addr -> y -> IO ()
55 -- | Shutdown and clean up any state related to this 'Transport'.
56 , closeTransport :: IO ()
57 }
58
59type Transport err addr x = TransportA err addr x x
60
61-- | This function modifies a 'Transport' to use higher-level addresses and
62-- packet representations. It could be used to change UDP 'ByteString's into
63-- bencoded syntax trees or to add an encryption layer in which addresses have
64-- associated public keys.
65layerTransportM ::
66 (x -> addr -> IO (Either err (x', addr')))
67 -- ^ Function that attempts to transform a low-level address/packet
68 -- pair into a higher level representation.
69 -> (y' -> addr' -> IO (y, addr))
70 -- ^ Function to encode a high-level address/packet into a lower level
71 -- representation.
72 -> TransportA err addr x y
73 -- ^ The low-level transport to be transformed.
74 -> TransportA err addr' x' y'
75layerTransportM parse encode tr =
76 tr { awaitMessage = \kont ->
77 awaitMessage tr $ \m -> mapM (mapM $ uncurry parse) m >>= kont . fmap join
78 , sendMessage = \addr' msg' -> do
79 (msg,addr) <- encode msg' addr'
80 sendMessage tr addr msg
81 }
82
83
84-- | This function modifies a 'Transport' to use higher-level addresses and
85-- packet representations. It could be used to change UDP 'ByteString's into
86-- bencoded syntax trees or to add an encryption layer in which addresses have
87-- associated public keys.
88layerTransport ::
89 (x -> addr -> Either err (x', addr'))
90 -- ^ Function that attempts to transform a low-level address/packet
91 -- pair into a higher level representation.
92 -> (y' -> addr' -> (y, addr))
93 -- ^ Function to encode a high-level address/packet into a lower level
94 -- representation.
95 -> TransportA err addr x y
96 -- ^ The low-level transport to be transformed.
97 -> TransportA err addr' x' y'
98layerTransport parse encode tr =
99 layerTransportM (\x addr -> return $ parse x addr)
100 (\x' addr' -> return $ encode x' addr')
101 tr
102
103-- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar'
104-- is used to share the same underlying socket, so be sure to fork a thread for
105-- both returned 'Transport's to avoid hanging.
106partitionTransport :: ((b,a) -> Either (x,xaddr) (b,a))
107 -> ((x,xaddr) -> Maybe (b,a))
108 -> Transport err a b
109 -> IO (Transport err xaddr x, Transport err a b)
110partitionTransport parse encodex tr =
111 partitionTransportM (return . parse) (return . encodex) tr
112
113-- | Paritions a 'Transport' into two higher-level transports. Note: An 'MVar'
114-- is used to share the same underlying socket, so be sure to fork a thread for
115-- both returned 'Transport's to avoid hanging.
116partitionTransportM :: ((b,a) -> IO (Either (x,xaddr) (b,a)))
117 -> ((x,xaddr) -> IO (Maybe (b,a)))
118 -> Transport err a b
119 -> IO (Transport err xaddr x, Transport err a b)
120partitionTransportM parse encodex tr = do
121 mvar <- newEmptyMVar
122 let xtr = tr { awaitMessage = \kont -> fix $ \again -> do
123 awaitMessage tr $ \m -> case m of
124 Just (Right msg) -> parse msg >>=
125 either (kont . Just . Right)
126 (\y -> putMVar mvar y >> again)
127 Just (Left e) -> kont $ Just (Left e)
128 Nothing -> kont Nothing
129 , sendMessage = \addr' msg' -> do
130 msg_addr <- encodex (msg',addr')
131 mapM_ (uncurry . flip $ sendMessage tr) msg_addr
132 }
133 ytr = Transport
134 { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right
135 , sendMessage = sendMessage tr
136 , closeTransport = return ()
137 }
138 return (xtr, ytr)
139
140partitionAndForkTransport ::
141 (dst -> msg -> IO ())
142 -> ((b,a) -> IO (Either (x,xaddr) (b,a)))
143 -> ((x,xaddr) -> IO (Maybe (Either (msg,dst) (b,a))))
144 -> Transport err a b
145 -> IO (Transport err xaddr x, Transport err a b)
146partitionAndForkTransport forkedSend parse encodex tr = do
147 mvar <- newEmptyMVar
148 let xtr = tr { awaitMessage = \kont -> fix $ \again -> do
149 awaitMessage tr $ \m -> case m of
150 Just (Right msg) -> parse msg >>=
151 either (kont . Just . Right)
152 (\y -> putMVar mvar y >> again)
153 Just (Left e) -> kont $ Just (Left e)
154 Nothing -> kont Nothing
155 , sendMessage = \addr' msg' -> do
156 msg_addr <- encodex (msg',addr')
157 case msg_addr of
158 Just (Right (b,a)) -> sendMessage tr a b
159 Just (Left (msg,dst)) -> forkedSend dst msg
160 Nothing -> return ()
161 }
162 ytr = Transport
163 { awaitMessage = \kont -> takeMVar mvar >>= kont . Just . Right
164 , sendMessage = sendMessage tr
165 , closeTransport = return ()
166 }
167 return (xtr, ytr)
168
169-- |
170-- * f add x --> Nothing, consume x
171-- --> Just id, leave x to a different handler
172-- --> Just g, apply g to x and leave that to a different handler
173addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x
174addHandler onParseError f tr = tr
175 { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \m -> do
176 case m of
177 Just (Right (x, addr)) -> f addr x >>= maybe eat (kont . Just . Right . (, addr) . ($ x))
178 Just (Left e ) -> onParseError e >> kont (Just $ Left e)
179 Nothing -> kont $ Nothing
180 }
181
182-- | Modify a 'Transport' to invoke an action upon every received packet.
183onInbound :: (addr -> x -> IO ()) -> Transport err addr x -> Transport err addr x
184onInbound f tr = addHandler (const $ return ()) (\addr x -> f addr x >> return (Just id)) tr
185
186-- * Using a query\/response client.
187
188-- | Fork a thread that handles inbound packets. The returned action may be used
189-- to terminate the thread and clean up any related state.
190--
191-- Example usage:
192--
193-- > -- Start client.
194-- > quitServer <- forkListener "listener" (clientNet client)
195-- > -- Send a query q, recieve a response r.
196-- > r <- sendQuery client method q
197-- > -- Quit client.
198-- > quitServer
199forkListener :: String -> Transport err addr x -> IO (IO ())
200forkListener name client = do
201 thread_id <- forkIO $ do
202 myThreadId >>= flip labelThread ("listener."++name)
203 fix $ awaitMessage client . const
204 dput XMisc $ "Listener died: " ++ name
205 return $ do
206 closeTransport client
207 killThread thread_id
208
209asyncQuery_ :: Client err meth tid addr x
210 -> MethodSerializer tid addr x meth a b
211 -> a
212 -> addr
213 -> (Maybe b -> IO ())
214 -> IO (tid,POSIXTime,Int)
215asyncQuery_ (Client net d err pending whoami _) meth q addr0 withResponse = do
216 now <- getPOSIXTime
217 (tid,addr,expiry) <- atomically $ do
218 tbl <- readTVar pending
219 ((tid,addr,expiry), tbl') <- dispatchRegister (tableMethods d)
220 (methodTimeout meth)
221 now
222 (withResponse . fmap (unwrapResponse meth))
223 addr0
224 tbl
225 -- (addr,expiry) <- methodTimeout meth tid addr0
226 writeTVar pending tbl'
227 return (tid,addr,expiry)
228 self <- whoami (Just addr)
229 mres <- do sendMessage net addr (wrapQuery meth tid self addr q)
230 return $ Just ()
231 `catchIOError` (\e -> return Nothing)
232 return (tid,now,expiry)
233
234asyncQuery :: Show meth => Client err meth tid addr x
235 -> MethodSerializer tid addr x meth a b
236 -> a
237 -> addr
238 -> (Maybe b -> IO ())
239 -> IO ()
240asyncQuery client meth q addr withResponse0 = do
241 tm <- getSystemTimerManager
242 tidvar <- newEmptyMVar
243 timedout <- registerTimeout tm 1000000 $ do
244 dput XMisc $ "async TIMEDOUT " ++ show (method meth)
245 withResponse0 Nothing
246 tid <- takeMVar tidvar
247 dput XMisc $ "async TIMEDOUT mvar " ++ show (method meth)
248 case client of
249 Client { clientDispatcher = d, clientPending = pending } -> do
250 atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending
251 (tid,now,expiry) <- asyncQuery_ client meth q addr $ \x -> do
252 unregisterTimeout tm timedout
253 withResponse0 x
254 putMVar tidvar tid
255 updateTimeout tm timedout expiry
256 dput XMisc $ "FIN asyncQuery "++show (method meth)++" TIMEOUT="++show expiry
257
258-- | Send a query to a remote peer. Note that this function will always time
259-- out if 'forkListener' was never invoked to spawn a thread to receive and
260-- dispatch the response.
261sendQuery ::
262 forall err a b tbl x meth tid addr.
263 Client err meth tid addr x -- ^ A query/response implementation.
264 -> MethodSerializer tid addr x meth a b -- ^ Information for marshaling the query.
265 -> a -- ^ The outbound query.
266 -> addr -- ^ Destination address of query.
267 -> IO (Maybe b) -- ^ The response, or 'Nothing' if it timed out.
268sendQuery c@(Client net d err pending whoami _) meth q addr0 = do
269 mvar <- newEmptyMVar
270 (tid,now,expiry) <- asyncQuery_ c meth q addr0 $ mapM_ (putMVar mvar)
271 mres <- timeout expiry $ takeMVar mvar
272 case mres of
273 Just b -> return $ Just b
274 Nothing -> do
275 atomically $ readTVar pending >>= dispatchCancel (tableMethods d) tid >>= writeTVar pending
276 return Nothing
277
278-- * Implementing a query\/response 'Client'.
279
280-- | All inputs required to implement a query\/response client.
281data Client err meth tid addr x = forall tbl. Client
282 { -- | The 'Transport' used to dispatch and receive packets.
283 clientNet :: Transport err addr x
284 -- | Methods for handling inbound packets.
285 , clientDispatcher :: DispatchMethods tbl err meth tid addr x
286 -- | Methods for reporting various conditions.
287 , clientErrorReporter :: ErrorReporter addr x meth tid err
288 -- | State necessary for routing inbound responses and assigning unique
289 -- /tid/ values for outgoing queries.
290 , clientPending :: TVar tbl
291 -- | An action yielding this client\'s own address. It is invoked once
292 -- on each outbound and inbound packet. It is valid for this to always
293 -- return the same value.
294 --
295 -- The argument, if supplied, is the remote address for the transaction.
296 -- This can be used to maintain consistent aliases for specific peers.
297 , clientAddress :: Maybe addr -> IO addr
298 -- | Transform a query /tid/ value to an appropriate response /tid/
299 -- value. Normally, this would be the identity transformation, but if
300 -- /tid/ includes a unique cryptographic nonce, then it should be
301 -- generated here.
302 , clientResponseId :: tid -> IO tid
303 }
304
305-- | An incoming message can be classified into three cases.
306data MessageClass err meth tid addr x
307 = IsQuery meth tid -- ^ An unsolicited query is handled based on it's /meth/ value. Any response
308 -- should include the provided /tid/ value.
309 | IsResponse tid -- ^ A response to a outgoing query we associated with a /tid/ value.
310 | IsUnsolicited (addr -> addr -> IO (Maybe (x -> x))) -- ^ Transactionless informative packet. The io action will be invoked
311 -- with the source and destination address of a message. If it handles the
312 -- message, it should return Nothing. Otherwise, it should return a transform
313 -- (usually /id/) to apply before the next handler examines it.
314 | IsUnknown err -- ^ None of the above.
315
316-- | Handler for an inbound query of type /x/ from an address of type _addr_.
317data MethodHandler err tid addr x = forall a b. MethodHandler
318 { -- | Parse the query into a more specific type for this method.
319 methodParse :: x -> Either err a
320 -- | Serialize the response for transmission, given a context /ctx/ and the origin
321 -- and destination addresses.
322 , methodSerialize :: tid -> addr -> addr -> b -> x
323 -- | Fully typed action to perform upon the query. The remote origin
324 -- address of the query is provided to the handler.
325 , methodAction :: addr -> a -> IO b
326 }
327 -- | See also 'IsUnsolicited' which likely makes this constructor unnecessary.
328 | forall a. NoReply
329 { -- | Parse the query into a more specific type for this method.
330 methodParse :: x -> Either err a
331 -- | Fully typed action to perform upon the query. The remote origin
332 -- address of the query is provided to the handler.
333 , noreplyAction :: addr -> a -> IO ()
334 }
335
336contramapAddr :: (a -> b) -> MethodHandler err tid b x -> MethodHandler err tid a x
337contramapAddr f (MethodHandler p s a)
338 = MethodHandler
339 p
340 (\tid src dst result -> s tid (f src) (f dst) result)
341 (\addr arg -> a (f addr) arg)
342contramapAddr f (NoReply p a)
343 = NoReply p (\addr arg -> a (f addr) arg)
344
345
346-- | Attempt to invoke a 'MethodHandler' upon a given inbound query. If the
347-- parse is successful, the returned IO action will construct our reply if
348-- there is one. Otherwise, a parse err is returned.
349dispatchQuery :: MethodHandler err tid addr x -- ^ Handler to invoke.
350 -> tid -- ^ The transaction id for this query\/response session.
351 -> addr -- ^ Our own address, to which the query was sent.
352 -> x -- ^ The query packet.
353 -> addr -- ^ The origin address of the query.
354 -> Either err (IO (Maybe x))
355dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr =
356 fmap (\a -> Just . wrapR tid self addr <$> f addr a) $ unwrapQ x
357dispatchQuery (NoReply unwrapQ f) tid self x addr =
358 fmap (\a -> f addr a >> return Nothing) $ unwrapQ x
359
360-- | These four parameters are required to implement an outgoing query. A
361-- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that
362-- might be returned by 'lookupHandler'.
363data MethodSerializer tid addr x meth a b = MethodSerializer
364 { -- | Returns the microseconds to wait for a response to this query being
365 -- sent to the given address. The /addr/ may also be modified to add
366 -- routing information.
367 methodTimeout :: tid -> addr -> STM (addr,Int)
368 -- | A method identifier used for error reporting. This needn't be the
369 -- same as the /meth/ argument to 'MethodHandler', but it is suggested.
370 , method :: meth
371 -- | Serialize the outgoing query /a/ into a transmittable packet /x/.
372 -- The /addr/ arguments are, respectively, our own origin address and the
373 -- destination of the request. The /tid/ argument is useful for attaching
374 -- auxiliary notations on all outgoing packets.
375 , wrapQuery :: tid -> addr -> addr -> a -> x
376 -- | Parse an inbound packet /x/ into a response /b/ for this query.
377 , unwrapResponse :: x -> b
378 }
379
380
381-- | To dispatch responses to our outbound queries, we require three
382-- primitives. See the 'transactionMethods' function to create these
383-- primitives out of a lookup table and a generator for transaction ids.
384--
385-- The type variable /d/ is used to represent the current state of the
386-- transaction generator and the table of pending transactions.
387data TransactionMethods d tid addr x = TransactionMethods
388 {
389 -- | Before a query is sent, this function stores an 'MVar' to which the
390 -- response will be written too. The returned /tid/ is a transaction id
391 -- that can be used to forget the 'MVar' if the remote peer is not
392 -- responding.
393 dispatchRegister :: (tid -> addr -> STM (addr,Int)) -> POSIXTime -> (Maybe x -> IO ()) -> addr -> d -> STM ((tid,addr,Int), d)
394 -- | This method is invoked when an incoming packet /x/ indicates it is
395 -- a response to the transaction with id /tid/. The returned IO action
396 -- will write the packet to the correct 'MVar' thus completing the
397 -- dispatch.
398 , dispatchResponse :: tid -> x -> d -> STM (d, IO ())
399 -- | When a timeout interval elapses, this method is called to remove the
400 -- transaction from the table.
401 , dispatchCancel :: tid -> d -> STM d
402 }
403
404-- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a
405-- function for generating unique transaction ids.
406transactionMethods ::
407 TableMethods t tid -- ^ Table methods to lookup values by /tid/.
408 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/.
409 -> TransactionMethods (g,t (Maybe x -> IO ())) tid addr x
410transactionMethods methods generate = transactionMethods' id id methods generate
411
412microsecondsDiff :: Int -> POSIXTime
413microsecondsDiff us = fromIntegral us / 1000000
414
415-- | Like 'transactionMethods' but allows extra information to be stored in the
416-- table of pending transactions. This also enables multiple 'Client's to
417-- share a single transaction table.
418transactionMethods' ::
419 ((Maybe x -> IO ()) -> a) -- ^ store MVar into table entry
420 -> (a -> Maybe x -> IO void) -- ^ load MVar from table entry
421 -> TableMethods t tid -- ^ Table methods to lookup values by /tid/.
422 -> (g -> (tid,g)) -- ^ Generate a new unique /tid/ value and update the generator state /g/.
423 -> TransactionMethods (g,t a) tid addr x
424transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods
425 { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
426 , dispatchRegister = \getTimeout now v a0 (g,t) -> do
427 let (tid,g') = generate g
428 (a,expiry) <- getTimeout tid a0
429 let t' = insert tid (store v) (now + microsecondsDiff expiry) t
430 return ( (tid,a,expiry), (g',t') )
431 , dispatchResponse = \tid x (g,t) ->
432 case lookup tid t of
433 Just v -> let t' = delete tid t
434 in return ((g,t'),void $ load v $ Just x)
435 Nothing -> return ((g,t), return ())
436 }
437
438-- | A set of methods necessary for dispatching incoming packets.
439data DispatchMethods tbl err meth tid addr x = DispatchMethods
440 { -- | Classify an inbound packet as a query or response.
441 classifyInbound :: x -> MessageClass err meth tid addr x
442 -- | Lookup the handler for a inbound query.
443 , lookupHandler :: meth -> Maybe (MethodHandler err tid addr x)
444 -- | Methods for handling incoming responses.
445 , tableMethods :: TransactionMethods tbl tid addr x
446 }
447
448-- | These methods indicate what should be done upon various conditions. Write
449-- to a log file, make debug prints, or simply ignore them.
450--
451-- [ /addr/ ] Address of remote peer.
452--
453-- [ /x/ ] Incoming or outgoing packet.
454--
455-- [ /meth/ ] Method id of incoming or outgoing request.
456--
457-- [ /tid/ ] Transaction id for outgoing packet.
458--
459-- [ /err/ ] Error information, typically a 'String'.
460data ErrorReporter addr x meth tid err = ErrorReporter
461 { -- | Incoming: failed to parse packet.
462 reportParseError :: err -> IO ()
463 -- | Incoming: no handler for request.
464 , reportMissingHandler :: meth -> addr -> x -> IO ()
465 -- | Incoming: unable to identify request.
466 , reportUnknown :: addr -> x -> err -> IO ()
467 }
468
469ignoreErrors :: ErrorReporter addr x meth tid err
470ignoreErrors = ErrorReporter
471 { reportParseError = \_ -> return ()
472 , reportMissingHandler = \_ _ _ -> return ()
473 , reportUnknown = \_ _ _ -> return ()
474 }
475
476logErrors :: ( Show addr
477 , Show meth
478 ) => ErrorReporter addr x meth tid String
479logErrors = ErrorReporter
480 { reportParseError = \err -> dput XMisc err
481 , reportMissingHandler = \meth addr x -> dput XMisc $ show addr ++ " --> Missing handler ("++show meth++")"
482 , reportUnknown = \addr x err -> dput XMisc $ show addr ++ " --> " ++ err
483 }
484
485printErrors :: ( Show addr
486 , Show meth
487 ) => Handle -> ErrorReporter addr x meth tid String
488printErrors h = ErrorReporter
489 { reportParseError = \err -> hPutStrLn h err
490 , reportMissingHandler = \meth addr x -> hPutStrLn h $ show addr ++ " --> Missing handler ("++show meth++")"
491 , reportUnknown = \addr x err -> hPutStrLn h $ show addr ++ " --> " ++ err
492 }
493
494-- Change the /err/ type for an 'ErrorReporter'.
495instance Contravariant (ErrorReporter addr x meth tid) where
496 -- contramap :: (t5 -> t4) -> ErrorReporter t3 t2 t1 t t4 -> ErrorReporter t3 t2 t1 t t5
497 contramap f (ErrorReporter pe mh unk)
498 = ErrorReporter (\e -> pe (f e))
499 mh
500 (\addr x e -> unk addr x (f e))
501
502-- | Handle a single inbound packet and then invoke the given continuation.
503-- The 'forkListener' function is implemented by passing this function to 'fix'
504-- in a forked thread that loops until 'awaitMessage' returns 'Nothing' or
505-- throws an exception.
506handleMessage ::
507 Client err meth tid addr x
508 -> addr
509 -> x
510 -> IO (Maybe (x -> x))
511handleMessage (Client net d err pending whoami responseID) addr plain = do
512 -- Just (Left e) -> do reportParseError err e
513 -- return $! Just id
514 -- Just (Right (plain, addr)) -> do
515 case classifyInbound d plain of
516 IsQuery meth tid -> case lookupHandler d meth of
517 Nothing -> do reportMissingHandler err meth addr plain
518 return $! Just id
519 Just m -> do
520 self <- whoami (Just addr)
521 tid' <- responseID tid
522 either (\e -> do reportParseError err e
523 return $! Just id)
524 (>>= \m -> do mapM_ (sendMessage net addr) m
525 return $! Nothing)
526 (dispatchQuery m tid' self plain addr)
527 IsUnsolicited action -> do
528 self <- whoami (Just addr)
529 action self addr
530 return Nothing
531 IsResponse tid -> do
532 action <- atomically $ do
533 ts0 <- readTVar pending
534 (ts, action) <- dispatchResponse (tableMethods d) tid plain ts0
535 writeTVar pending ts
536 return action
537 action
538 return $! Nothing
539 IsUnknown e -> do reportUnknown err addr plain e
540 return $! Just id
541 -- Nothing -> return $! id
542
543-- * UDP Datagrams.
544
545-- | Access the address family of a given 'SockAddr'. This convenient accessor
546-- is missing from 'Network.Socket', so I implemented it here.
547sockAddrFamily :: SockAddr -> Family
548sockAddrFamily (SockAddrInet _ _ ) = AF_INET
549sockAddrFamily (SockAddrInet6 _ _ _ _) = AF_INET6
550sockAddrFamily (SockAddrUnix _ ) = AF_UNIX
551sockAddrFamily _ = AF_CAN -- SockAddrCan constructor deprecated
552
553-- | Packets with an empty payload may trigger EOF exception.
554-- 'udpTransport' uses this function to avoid throwing in that
555-- case.
556ignoreEOF :: a -> IOError -> IO a
557ignoreEOF def e | isEOFError e = pure def
558 | otherwise = throwIO e
559
560-- | Hard-coded maximum packet size for incoming UDP Packets received via
561-- 'udpTransport'.
562udpBufferSize :: Int
563udpBufferSize = 65536
564
565-- | Wrapper around 'B.sendTo' that silently ignores DoesNotExistError.
566saferSendTo :: Socket -> ByteString -> SockAddr -> IO ()
567saferSendTo sock bs saddr = void (B.sendTo sock bs saddr)
568 `catch` \e ->
569 -- sendTo: does not exist (Network is unreachable)
570 -- Occurs when IPv6 or IPv4 network is not available.
571 -- Currently, we require -threaded to prevent a forever-hang in this case.
572 if isDoesNotExistError e
573 then return ()
574 else throw e
575
576-- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's. The
577-- argument is the listen-address for incoming packets. This is a useful
578-- low-level 'Transport' that can be transformed for higher-level protocols
579-- using 'layerTransport'.
580udpTransport :: SockAddr -> IO (Transport err SockAddr ByteString)
581udpTransport bind_address = fst <$> udpTransport' bind_address
582
583-- | Like 'udpTransport' except also returns the raw socket (for broadcast use).
584udpTransport' :: SockAddr -> IO (Transport err SockAddr ByteString, Socket)
585udpTransport' bind_address = do
586 let family = sockAddrFamily bind_address
587 sock <- socket family Datagram defaultProtocol
588 when (family == AF_INET6) $ do
589 setSocketOption sock IPv6Only 0
590 setSocketOption sock Broadcast 1
591 bind sock bind_address
592 let tr = Transport {
593 awaitMessage = \kont -> do
594 r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do
595 Just . Right <$!> B.recvFrom sock udpBufferSize
596 kont $! r
597 , sendMessage = case family of
598 AF_INET6 -> \case
599 (SockAddrInet port addr) -> \bs ->
600 -- Change IPv4 to 4mapped6 address.
601 saferSendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0
602 addr6 -> \bs -> saferSendTo sock bs addr6
603 AF_INET -> \case
604 (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do
605 let host4 = toBE32 raw4
606 -- Change 4mapped6 to ordinary IPv4.
607 -- dput XMisc $ "4mapped6 -> "++show (SockAddrInet port host4)
608 saferSendTo sock bs (SockAddrInet port host4)
609 addr@(SockAddrInet6 {}) -> \bs -> dput XMisc ("Discarding packet to "++show addr)
610 addr4 -> \bs -> saferSendTo sock bs addr4
611 _ -> \addr bs -> saferSendTo sock bs addr
612 , closeTransport = close sock
613 }
614 return (tr, sock)
615
616chanTransport :: (addr -> TChan (x, addr)) -> addr -> TChan (x, addr) -> TVar Bool -> Transport err addr x
617chanTransport chanFromAddr self achan aclosed = Transport
618 { awaitMessage = \kont -> do
619 x <- atomically $ (Just <$> readTChan achan)
620 `orElse`
621 (readTVar aclosed >>= check >> return Nothing)
622 kont $ Right <$> x
623 , sendMessage = \them bs -> do
624 atomically $ writeTChan (chanFromAddr them) (bs,self)
625 , closeTransport = atomically $ writeTVar aclosed True
626 }
627
628-- | Returns a pair of transports linked together to simulate two computers talking to each other.
629testPairTransport :: IO (Transport err SockAddr ByteString, Transport err SockAddr ByteString)
630testPairTransport = do
631 achan <- atomically newTChan
632 bchan <- atomically newTChan
633 aclosed <- atomically $ newTVar False
634 bclosed <- atomically $ newTVar False
635 let a = SockAddrInet 1 1
636 b = SockAddrInet 2 2
637 return ( chanTransport (const bchan) a achan aclosed
638 , chanTransport (const achan) b bchan bclosed )
diff --git a/src/Network/QueryResponse/TCP.hs b/src/Network/QueryResponse/TCP.hs
deleted file mode 100644
index bad61727..00000000
--- a/src/Network/QueryResponse/TCP.hs
+++ /dev/null
@@ -1,192 +0,0 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE CPP #-}
3module Network.QueryResponse.TCP where
4
5#ifdef THREAD_DEBUG
6import Control.Concurrent.Lifted.Instrument
7#else
8import Control.Concurrent.Lifted
9import GHC.Conc (labelThread)
10#endif
11
12import Control.Arrow
13import Control.Concurrent.STM
14import Control.Monad
15import Data.ByteString (ByteString,hPut)
16import Data.Function
17import Data.Hashable
18import Data.Maybe
19import Data.Ord
20import Data.Time.Clock.POSIX
21import Data.Word
22import Network.BSD
23import Network.Socket
24import System.Timeout
25import System.IO
26import System.IO.Error
27
28import DebugTag
29import DPut
30import Connection.Tcp (socketFamily)
31import qualified Data.MinMaxPSQ as MM
32import Network.QueryResponse
33
34data TCPSession st
35 = PendingTCPSession
36 | TCPSession
37 { tcpHandle :: Handle
38 , tcpState :: st
39 , tcpThread :: ThreadId
40 }
41
42newtype TCPAddress = TCPAddress SockAddr
43 deriving (Eq,Ord,Show)
44
45instance Hashable TCPAddress where
46 hashWithSalt salt (TCPAddress x) = case x of
47 SockAddrInet port addr -> hashWithSalt salt (fromIntegral port :: Word16,addr)
48 SockAddrInet6 port b c d -> hashWithSalt salt (fromIntegral port :: Word16,b,c,d)
49 _ -> 0
50
51data TCPCache st = TCPCache
52 { lru :: TVar (MM.MinMaxPSQ' TCPAddress (Down POSIXTime) (TCPSession st))
53 , tcpMax :: Int
54 }
55
56data SessionProtocol x y = SessionProtocol
57 { streamGoodbye :: IO () -- ^ "Goodbye" protocol upon termination.
58 , streamDecode :: IO (Maybe x) -- ^ Parse inbound messages.
59 , streamEncode :: y -> IO () -- ^ Serialize outbound messages.
60 }
61
62data StreamHandshake addr x y = StreamHandshake
63 { streamHello :: addr -> Handle -> IO (SessionProtocol x y) -- ^ "Hello" protocol upon fresh connection.
64 , streamAddr :: addr -> SockAddr
65 }
66
67killSession :: TCPSession st -> IO ()
68killSession PendingTCPSession = return ()
69killSession TCPSession{tcpThread=t} = killThread t
70
71showStat r = case r of PendingTCPSession -> "pending."
72 TCPSession {} -> "established."
73
74acquireConnection :: MVar (Maybe (Either a (x, addr)))
75 -> TCPCache (SessionProtocol x y)
76 -> StreamHandshake addr x y
77 -> addr
78 -> Bool
79 -> IO (Maybe (y -> IO ()))
80acquireConnection mvar tcpcache stream addr bDoCon = do
81 now <- getPOSIXTime
82 -- dput XTCP $ "acquireConnection 0 " ++ show (streamAddr stream addr)
83 entry <- atomically $ do
84 c <- readTVar (lru tcpcache)
85 let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c
86 case v of
87 Nothing | bDoCon -> writeTVar (lru tcpcache)
88 $ MM.insert' (TCPAddress $ streamAddr stream addr) PendingTCPSession (Down now) c
89 | otherwise -> return ()
90 Just (tm, v) -> modifyTVar' (lru tcpcache) $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down now)
91 return v
92 -- dput XTCP $ "acquireConnection 1 " ++ show (streamAddr stream addr, fmap (second showStat) entry)
93 case entry of
94 Nothing -> fmap join $ forM (guard bDoCon) $ \() -> do
95 proto <- getProtocolNumber "tcp"
96 mh <- catchIOError (do h <- timeout 10000000 $ do
97 sock <- socket (socketFamily $ streamAddr stream addr) Stream proto
98 connect sock (streamAddr stream addr) `catchIOError` (\e -> close sock)
99 h <- socketToHandle sock ReadWriteMode
100 hSetBuffering h NoBuffering
101 return h
102 return h)
103 $ \e -> return Nothing
104 ret <- fmap join $ forM mh $ \h -> do
105 st <- streamHello stream addr h
106 dput XTCP $ "TCP Connected! " ++ show (streamAddr stream addr)
107 signal <- newTVarIO False
108 rthread <- forkIO $ do
109 atomically (readTVar signal >>= check)
110 fix $ \loop -> do
111 x <- streamDecode st
112 dput XTCP $ "TCP streamDecode " ++ show (streamAddr stream addr) ++ " --> " ++ maybe "Nothing" (const "got") x
113 case x of
114 Just u -> do
115 m <- timeout (1000000) $ putMVar mvar $ Just $ Right (u, addr)
116 when (isNothing m) $ do
117 dput XTCP $ "TCP "++show (streamAddr stream addr) ++ " dropped packet."
118 tryTakeMVar mvar
119 return ()
120 loop
121 Nothing -> do
122 dput XTCP $ "TCP disconnected: " ++ show (streamAddr stream addr)
123 do atomically $ modifyTVar' (lru tcpcache)
124 $ MM.delete (TCPAddress $ streamAddr stream addr)
125 c <- atomically $ readTVar (lru tcpcache)
126 now <- getPOSIXTime
127 forM_ (zip [1..] $ MM.toList c) $ \(i,MM.Binding (TCPAddress addr) r (Down tm)) -> do
128 dput XTCP $ unwords [show i ++ ".", "Still connected:", show addr, show (now - tm), showStat r]
129 hClose h
130 let showAddr a = show (streamAddr stream a)
131 labelThread rthread ("tcp:"++showAddr addr)
132 let v = TCPSession
133 { tcpHandle = h
134 , tcpState = st
135 , tcpThread = rthread
136 }
137 t <- getPOSIXTime
138 retires <- atomically $ do
139 c <- readTVar (lru tcpcache)
140 let (rs,c') = MM.takeView (tcpMax tcpcache)
141 $ MM.insert' (TCPAddress $ streamAddr stream addr) v (Down t) c
142 writeTVar (lru tcpcache) c'
143 writeTVar signal True
144 return rs
145 forM_ retires $ \(MM.Binding (TCPAddress k) r _) -> void $ forkIO $ do
146 myThreadId >>= flip labelThread ("tcp-close:"++show k)
147 dput XTCP $ "TCP dropped: " ++ show k
148 killSession r
149 case r of TCPSession {tcpState=st,tcpHandle=h} -> do
150 streamGoodbye st
151 hClose h
152 _ -> return ()
153
154 return $ Just $ streamEncode st
155 when (isNothing ret) $ do
156 atomically $ modifyTVar' (lru tcpcache) $ MM.delete (TCPAddress $ streamAddr stream addr)
157 return ret
158 Just (tm, PendingTCPSession)
159 | not bDoCon -> return Nothing
160 | otherwise -> fmap join $ timeout 10000000 $ atomically $ do
161 c <- readTVar (lru tcpcache)
162 let v = MM.lookup' (TCPAddress $ streamAddr stream addr) c
163 case v of
164 Just (_,TCPSession{tcpState=st}) -> return $ Just $ streamEncode st
165 Nothing -> return Nothing
166 _ -> retry
167 Just (tm, v@TCPSession {tcpState=st}) -> return $ Just $ streamEncode st
168
169closeAll :: TCPCache (SessionProtocol x y) -> StreamHandshake addr x y -> IO ()
170closeAll tcpcache stream = do
171 cache <- atomically $ swapTVar (lru tcpcache) MM.empty
172 forM_ (MM.toList cache) $ \(MM.Binding (TCPAddress addr) r tm) -> do
173 killSession r
174 case r of TCPSession{tcpState=st,tcpHandle=h} -> streamGoodbye st >> hClose h
175 _ -> return ()
176
177tcpTransport :: Int -- ^ maximum number of TCP links to maintain.
178 -> StreamHandshake addr x y
179 -> IO (TCPCache (SessionProtocol x y), TransportA err addr x (Bool,y))
180tcpTransport maxcon stream = do
181 msgvar <- newEmptyMVar
182 tcpcache <- atomically $ (`TCPCache` maxcon) <$> newTVar (MM.empty)
183 return $ (,) tcpcache Transport
184 { awaitMessage = \f -> takeMVar msgvar >>= \x -> f x `catchIOError` (\e -> dput XTCP ("TCP transport stopped. " ++ show e) >> f Nothing)
185 , sendMessage = \addr (bDoCon,y) -> do
186 t <- forkIO $ do
187 msock <- acquireConnection msgvar tcpcache stream addr bDoCon
188 mapM_ ($ y) msock
189 `catchIOError` \e -> dput XTCP $ "TCP-send: " ++ show e
190 labelThread t "tcp-send"
191 , closeTransport = closeAll tcpcache stream
192 }
diff --git a/src/Network/SessionTransports.hs b/src/Network/SessionTransports.hs
deleted file mode 100644
index e9daf6c1..00000000
--- a/src/Network/SessionTransports.hs
+++ /dev/null
@@ -1,98 +0,0 @@
1{-# LANGUAGE NamedFieldPuns #-}
2module Network.SessionTransports
3 ( Sessions
4 , initSessions
5 , newSession
6 , sessionHandler
7 ) where
8
9import Control.Concurrent
10import Control.Concurrent.STM
11import Control.Monad
12import qualified Data.IntMap.Strict as IntMap
13 ;import Data.IntMap.Strict (IntMap)
14import qualified Data.Map.Strict as Map
15 ;import Data.Map.Strict (Map)
16
17import Network.Address (SockAddr,either4or6)
18import Network.QueryResponse
19import qualified Data.IntervalSet as S
20 ;import Data.IntervalSet (IntSet)
21
22data Sessions x = Sessions
23 { sessionsByAddr :: TVar (Map SockAddr (IntMap (x -> IO Bool)))
24 , sessionsById :: TVar (IntMap SockAddr)
25 , sessionIds :: TVar IntSet
26 , sessionsSendRaw :: SockAddr -> x -> IO ()
27 }
28
29initSessions :: (SockAddr -> x -> IO ()) -> IO (Sessions x)
30initSessions send = atomically $ do
31 byaddr <- newTVar Map.empty
32 byid <- newTVar IntMap.empty
33 idset <- newTVar S.empty
34 return Sessions { sessionsByAddr = byaddr
35 , sessionsById = byid
36 , sessionIds = idset
37 , sessionsSendRaw = send
38 }
39
40
41
42rmSession :: Int -> (Maybe (IntMap x)) -> (Maybe (IntMap x))
43rmSession sid Nothing = Nothing
44rmSession sid (Just m) = case IntMap.delete sid m of
45 m' | IntMap.null m' -> Nothing
46 | otherwise -> Just m'
47
48newSession :: Sessions raw
49 -> (addr -> y -> IO raw)
50 -> (SockAddr -> raw -> IO (Maybe (x, addr)))
51 -> SockAddr
52 -> IO (Maybe (Int,TransportA err addr x y))
53newSession Sessions{sessionsByAddr,sessionsById,sessionIds,sessionsSendRaw} unwrap wrap addr0 = do
54 mvar <- newEmptyMVar
55 let saddr = -- Canonical in case of 6-mapped-4 addresses.
56 either id id $ either4or6 addr0
57 handlePacket x = do
58 m <- wrap saddr x
59 case m of
60 Nothing -> return False
61 Just x' -> do putMVar mvar $! Just $! x'
62 return True
63 msid <- atomically $ do
64 msid <- S.nearestOutsider 0 <$> readTVar sessionIds
65 forM msid $ \sid -> do
66 modifyTVar' sessionIds $ S.insert sid
67 modifyTVar' sessionsById $ IntMap.insert sid saddr
68 modifyTVar' sessionsByAddr $ Map.insertWith IntMap.union saddr
69 $ IntMap.singleton sid handlePacket
70 return sid
71 forM msid $ \sid -> do
72 let tr = Transport
73 { awaitMessage = \kont -> do
74 x <- takeMVar mvar
75 kont $! Right <$> x
76 , sendMessage = \addr x -> do
77 x' <- unwrap addr x
78 sessionsSendRaw saddr x'
79 , closeTransport = do
80 tryTakeMVar mvar
81 putMVar mvar Nothing
82 atomically $ do
83 modifyTVar' sessionIds $ S.delete sid
84 modifyTVar' sessionsById $ IntMap.delete sid
85 modifyTVar' sessionsByAddr $ Map.alter (rmSession sid) saddr
86 }
87 return (sid,tr)
88
89sessionHandler :: Sessions x -> (SockAddr -> x -> IO (Maybe (x -> x)))
90sessionHandler Sessions{sessionsByAddr} = \addr0 x -> do
91 let addr = -- Canonical in case of 6-mapped-4 addresses.
92 either id id $ either4or6 addr0
93 dispatch [] = return ()
94 dispatch (f:fs) = do b <- f x
95 when (not b) $ dispatch fs
96 fs <- atomically $ Map.lookup addr <$> readTVar sessionsByAddr
97 mapM_ (dispatch . IntMap.elems) fs
98 return Nothing -- consume all packets.
diff --git a/src/Network/SocketLike.hs b/src/Network/SocketLike.hs
deleted file mode 100644
index d533dd7f..00000000
--- a/src/Network/SocketLike.hs
+++ /dev/null
@@ -1,124 +0,0 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE CPP #-}
3-- |
4--
5-- A socket could be used indirectly via a 'System.IO.Handle' or a conduit from
6-- Michael Snoyman's conduit package. But doing so presents an encapsulation
7-- problem. Do we allow access to the underlying socket and trust that it wont
8-- be used in an unsafe way? Or do we protect it at the higher level and deny
9-- access to various state information?
10--
11-- The 'SocketLike' class enables the approach that provides a safe wrapper to
12-- the underlying socket and gives access to various state information without
13-- enabling direct reads or writes.
14module Network.SocketLike
15 ( SocketLike(..)
16 , RestrictedSocket
17 , restrictSocket
18 , restrictHandleSocket
19 -- * Re-exports
20 --
21 -- | To make the 'SocketLike' methods less awkward to use, the types
22 -- 'CUInt', 'SockAddr', and 'PortNumber' are re-exported.
23 , CUInt
24 , PortNumber
25 , SockAddr(..)
26 ) where
27
28import Network.Socket
29 ( PortNumber
30 , SockAddr
31 )
32import Foreign.C.Types ( CUInt )
33
34import qualified Network.Socket as NS
35import System.IO (Handle,hClose,hIsOpen)
36
37-- | A safe (mostly read-only) interface to a 'NS.Socket'. Note that despite
38-- how this class is named, it provides no access to typical 'NS.Socket' uses
39-- like sending or receiving network packets.
40class SocketLike sock where
41 -- | See 'NS.getSocketName'
42 getSocketName :: sock -> IO SockAddr
43 -- | See 'NS.getPeerName'
44 getPeerName :: sock -> IO SockAddr
45 -- | See 'NS.getPeerCred'
46 getPeerCred :: sock -> IO (CUInt, CUInt, CUInt)
47 -- | See 'NS.socketPort'
48 socketPort :: sock -> IO PortNumber
49 -- | See 'NS.sIsConnected'
50 --
51 -- __Warning__: Don't rely on this method if it's possible the socket was
52 -- converted into a 'Handle'.
53 sIsConnected :: sock -> IO Bool
54 -- | See 'NS.sIsBound'
55 sIsBound :: sock -> IO Bool
56 -- | See 'NS.sIsListening'
57 sIsListening :: sock -> IO Bool
58 -- | See 'NS.sIsReadable'
59 sIsReadable :: sock -> IO Bool
60 -- | See 'NS.sIsWritable'
61 sIsWritable :: sock -> IO Bool
62
63 -- | This is the only exposed write-access method to the
64 -- underlying state. Usually implemented by 'NS.close'
65 sClose :: sock -> IO ()
66
67instance SocketLike NS.Socket where
68 getSocketName = NS.getSocketName
69 getPeerName = NS.getPeerName
70 getPeerCred = NS.getPeerCred
71 socketPort = NS.socketPort
72#if MIN_VERSION_network(2,4,0)
73 sIsConnected = NS.isConnected -- warning: this is always False if the socket
74 -- was converted to a Handle
75 sIsBound = NS.isBound
76 sIsListening = NS.isListening
77 sIsReadable = NS.isReadable
78 sIsWritable = NS.isWritable
79 sClose = NS.close
80#else
81 sIsConnected = NS.sIsConnected -- warning: this is always False if the socket
82 -- was converted to a Handle
83 sIsBound = NS.sIsBound
84 sIsListening = NS.sIsListening
85 sIsReadable = NS.sIsReadable
86 sIsWritable = NS.sIsWritable
87 sClose = NS.sClose
88#endif
89
90
91-- | An encapsulated socket. Data reads and writes are not possible.
92data RestrictedSocket = Restricted (Maybe Handle) NS.Socket deriving Show
93
94instance SocketLike RestrictedSocket where
95 getSocketName (Restricted mb sock) = NS.getSocketName sock
96 getPeerName (Restricted mb sock) = NS.getPeerName sock
97 getPeerCred (Restricted mb sock) = NS.getPeerCred sock
98 socketPort (Restricted mb sock) = NS.socketPort sock
99#if MIN_VERSION_network(2,4,0)
100 sIsConnected (Restricted mb sock) = maybe (NS.isConnected sock) (hIsOpen) mb
101 sIsBound (Restricted mb sock) = NS.isBound sock
102 sIsListening (Restricted mb sock) = NS.isListening sock
103 sIsReadable (Restricted mb sock) = NS.isReadable sock
104 sIsWritable (Restricted mb sock) = NS.isWritable sock
105 sClose (Restricted mb sock) = maybe (NS.close sock) (\h -> hClose h >> NS.close sock) mb
106#else
107 sIsConnected (Restricted mb sock) = maybe (NS.sIsConnected sock) (hIsOpen) mb
108 sIsBound (Restricted mb sock) = NS.sIsBound sock
109 sIsListening (Restricted mb sock) = NS.sIsListening sock
110 sIsReadable (Restricted mb sock) = NS.sIsReadable sock
111 sIsWritable (Restricted mb sock) = NS.sIsWritable sock
112 sClose (Restricted mb sock) = maybe (NS.sClose sock) (\h -> hClose h >> NS.sClose sock) mb
113#endif
114
115-- | Create a 'RestrictedSocket' that explicitly disallows sending or
116-- receiving data.
117restrictSocket :: NS.Socket -> RestrictedSocket
118restrictSocket socket = Restricted Nothing socket
119
120-- | Build a 'RestrictedSocket' for which 'sClose' will close the given
121-- 'Handle'. It is intended that this 'Handle' was obtained via
122-- 'NS.socketToHandle'.
123restrictHandleSocket :: Handle -> NS.Socket -> RestrictedSocket
124restrictHandleSocket h socket = Restricted (Just h) socket
diff --git a/src/Network/StreamServer.hs b/src/Network/StreamServer.hs
deleted file mode 100644
index 80ed4ee2..00000000
--- a/src/Network/StreamServer.hs
+++ /dev/null
@@ -1,154 +0,0 @@
1-- | This module implements a bare-bones TCP or Unix socket server.
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeOperators #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE RankNTypes #-}
7module Network.StreamServer
8 ( streamServer
9 , ServerHandle
10 , ServerConfig(..)
11 , withSession
12 , quitListening
13 , dummyServerHandle
14 , listenSocket
15 ) where
16
17import Data.Monoid
18import Network.Socket as Socket
19import System.Directory (removeFile)
20import System.IO
21 ( IOMode(..)
22 , stderr
23 , hFlush
24 )
25import Control.Monad
26import Control.Monad.Fix (fix)
27#ifdef THREAD_DEBUG
28import Control.Concurrent.Lifted.Instrument
29 ( forkIO, threadDelay, ThreadId, mkWeakThreadId, labelThread, myThreadId
30 , killThread )
31#else
32import GHC.Conc (labelThread)
33import Control.Concurrent
34 ( forkIO, threadDelay, ThreadId, mkWeakThreadId, myThreadId
35 , killThread )
36#endif
37import Control.Exception (handle,finally)
38import System.IO.Error (tryIOError)
39import System.Mem.Weak
40import System.IO.Error
41
42-- import Data.Conduit
43import System.IO (Handle)
44import Control.Concurrent.MVar (newMVar)
45
46import Network.SocketLike
47import DPut
48import DebugTag
49
50data ServerHandle = ServerHandle Socket (Weak ThreadId)
51
52listenSocket :: ServerHandle -> RestrictedSocket
53listenSocket (ServerHandle sock _) = restrictSocket sock
54
55-- | Create a useless do-nothing 'ServerHandle'.
56dummyServerHandle :: IO ServerHandle
57dummyServerHandle = do
58 mvar <- newMVar Closed
59 let sock = MkSocket 0 AF_UNSPEC NoSocketType 0 mvar
60 thread <- mkWeakThreadId <=< forkIO $ return ()
61 return (ServerHandle sock thread)
62
63removeSocketFile :: SockAddr -> IO ()
64removeSocketFile (SockAddrUnix fname) = removeFile fname
65removeSocketFile _ = return ()
66
67-- | Terminate the server accept-loop. Call this to shut down the server.
68quitListening :: ServerHandle -> IO ()
69quitListening (ServerHandle socket acceptThread) =
70 finally (Socket.getSocketName socket >>= removeSocketFile)
71 (do mapM_ killThread =<< deRefWeak acceptThread
72 Socket.close socket)
73
74
75-- | It's 'bshow' instead of 'show' to enable swapping in a 'ByteString'
76-- variation. (This is not exported.)
77bshow :: Show a => a -> String
78bshow e = show e
79
80-- | Send a string to stderr. Not exported. Default 'serverWarn' when
81-- 'withSession' is used to configure the server.
82warnStderr :: String -> IO ()
83warnStderr str = dput XMisc str >> hFlush stderr
84
85data ServerConfig = ServerConfig
86 { serverWarn :: String -> IO ()
87 -- ^ Action to report warnings and errors.
88 , serverSession :: RestrictedSocket -> Int -> Handle -> IO ()
89 -- ^ Action to handle interaction with a client
90 }
91
92-- | Initialize a 'ServerConfig' using the provided session handler.
93withSession :: (RestrictedSocket -> Int -> Handle -> IO ()) -> ServerConfig
94withSession session = ServerConfig warnStderr session
95
96-- | Launch a thread to listen at the given bind address and dispatch
97-- to session handler threads on every incoming connection. Supports
98-- IPv4 and IPv6, TCP and unix sockets.
99--
100-- The returned handle can be used with 'quitListening' to terminate the
101-- thread and prevent any new sessions from starting. Currently active
102-- session threads will not be terminated or signaled in any way.
103streamServer :: ServerConfig -> [SockAddr] -> IO ServerHandle
104streamServer cfg addrs = do
105 let warn = serverWarn cfg
106 family = case addrs of
107 SockAddrInet {}:_ -> AF_INET
108 SockAddrInet6 {}:_ -> AF_INET6
109 SockAddrUnix {}:_ -> AF_UNIX
110 [] -> AF_INET6
111 sock <- socket family Stream 0
112 setSocketOption sock ReuseAddr 1
113 let tryBind addr next _ = do
114 tryIOError (removeSocketFile addr)
115 bind sock addr
116 `catchIOError` \e -> next (Just e)
117 fix $ \loop -> let again mbe = do
118 forM_ mbe $ \e -> warn $ "bind-error: " <> bshow addrs <> " " <> bshow e
119 threadDelay 5000000
120 loop
121 in foldr tryBind again addrs Nothing
122 listen sock maxListenQueue
123 thread <- mkWeakThreadId <=< forkIO $ do
124 myThreadId >>= flip labelThread "StreamServer.acceptLoop"
125 acceptLoop cfg sock 0
126 return (ServerHandle sock thread)
127
128-- | Not exported. This, combined with 'acceptException' form a mutually
129-- recursive loop that handles incoming connections. To quit the loop, the
130-- socket must be closed by 'quitListening'.
131acceptLoop :: ServerConfig -> Socket -> Int -> IO ()
132acceptLoop cfg sock n = handle (acceptException cfg n sock) $ do
133 con <- accept sock
134 let conkey = n + 1
135 h <- socketToHandle (fst con) ReadWriteMode
136 forkIO $ do
137 myThreadId >>= flip labelThread "StreamServer.session"
138 serverSession cfg (restrictHandleSocket h (fst con)) conkey h
139 acceptLoop cfg sock (n + 1)
140
141acceptException :: ServerConfig -> Int -> Socket -> IOError -> IO ()
142acceptException cfg n sock ioerror = do
143 Socket.close sock
144 case show (ioeGetErrorType ioerror) of
145 "resource exhausted" -> do -- try again
146 serverWarn cfg $ ("acceptLoop: resource exhasted")
147 threadDelay 500000
148 acceptLoop cfg sock (n + 1)
149 "invalid argument" -> do -- quit on closed socket
150 return ()
151 message -> do -- unexpected exception
152 serverWarn cfg $ ("acceptLoop: "<>bshow message)
153 return ()
154
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
deleted file mode 100644
index 98c03b80..00000000
--- a/src/Network/Tox.hs
+++ /dev/null
@@ -1,456 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveFoldable #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveGeneric #-}
7{-# LANGUAGE DeriveTraversable #-}
8{-# LANGUAGE ExistentialQuantification #-}
9{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE NamedFieldPuns #-}
13{-# LANGUAGE PatternSynonyms #-}
14{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE TupleSections #-}
18{-# LANGUAGE ViewPatterns #-}
19module Network.Tox where
20
21#ifdef THREAD_DEBUG
22import Control.Concurrent.Lifted.Instrument
23#else
24import Control.Concurrent.Lifted
25#endif
26import Control.Concurrent.STM
27import Control.Exception (throwIO)
28import Control.Monad
29import Crypto.PubKey.Curve25519
30import Crypto.Random
31import Data.Bits.ByteString ()
32import qualified Data.ByteString as B
33 ;import Data.ByteString (ByteString)
34import qualified Data.ByteString.Char8 as C8
35import Data.Data
36import Data.Functor.Identity
37import Data.Functor.Contravariant
38import Data.Maybe
39import qualified Data.MinMaxPSQ as MinMaxPSQ
40import qualified Data.Serialize as S
41import Data.Time.Clock.POSIX (getPOSIXTime)
42import Data.Word
43import Network.Socket
44import System.Endian
45import System.IO.Error
46
47import Data.TableMethods
48import qualified Data.Word64Map
49import Network.BitTorrent.DHT.Token as Token
50import qualified Data.Wrapper.PSQ as PSQ
51import System.Global6
52import Network.Address (WantIP (..),IP,getBindAddress)
53import qualified Network.Kademlia.Routing as R
54import Network.QueryResponse
55import Crypto.Tox
56import Data.Word64Map (fitsInInt)
57import qualified Data.Word64Map (empty)
58import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap)
59import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket)
60import qualified Network.Tox.DHT.Handlers as DHT
61import qualified Network.Tox.DHT.Transport as DHT
62import Network.Tox.NodeId
63import qualified Network.Tox.Onion.Handlers as Onion
64import qualified Network.Tox.Onion.Transport as Onion
65import Network.Tox.Transport
66import Network.Tox.TCP (tcpClient)
67import OnionRouter
68import Network.Tox.ContactInfo
69import Text.XXD
70import DPut
71import DebugTag
72import TCPProber
73import Network.Tox.Avahi
74import Network.Tox.Session
75import qualified Data.Tox.Relay as TCP
76import Network.Tox.Relay
77import Network.SessionTransports
78import Network.Kademlia.Search
79import HandshakeCache
80
81updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()
82updateIP tblvar a = do
83 bkts <- readTVar tblvar
84 case nodeInfo (nodeId (R.thisNode bkts)) a of
85 Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
86 Left _ -> return ()
87
88genNonce24 :: DRG g =>
89 TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId
90genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do
91 (g,pending) <- readTVar var
92 let (bs, g') = randomBytesGenerate 24 g
93 writeTVar var (g',pending)
94 return $ DHT.TransactionId nonce8 (Nonce24 bs)
95
96
97gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen)
98gen g = let (bs, g') = randomBytesGenerate 24 g
99 (ws, g'') = randomBytesGenerate 8 g'
100 Right w = S.runGet S.getWord64be ws
101 in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' )
102
103intKey :: DHT.TransactionId -> Int
104intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w
105
106w64Key :: DHT.TransactionId -> Word64
107w64Key (DHT.TransactionId (Nonce8 w) _) = w
108
109nonceKey :: DHT.TransactionId -> Nonce8
110nonceKey (DHT.TransactionId n _) = n
111
112-- | Return my own address.
113myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets
114 -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets
115 -> Maybe NodeInfo -- ^ Interested remote address
116 -> IO NodeInfo
117myAddr routing4 routing6 maddr = atomically $ do
118 let var = case flip DHT.prefer4or6 Nothing <$> maddr of
119 Just Want_IP6 -> routing4
120 _ -> routing6
121 a <- readTVar var
122 return $ R.thisNode a
123
124newClient :: (DRG g, Show addr, Show meth) =>
125 g -> Transport String addr x
126 -> (Client String meth DHT.TransactionId addr x
127 -> x
128 -> MessageClass String meth DHT.TransactionId addr x)
129 -> (Maybe addr -> IO addr)
130 -> (Client String meth DHT.TransactionId addr x
131 -> meth
132 -> Maybe (MethodHandler String DHT.TransactionId addr x))
133 -> (forall d. TransactionMethods d DHT.TransactionId addr x
134 -> TransactionMethods d DHT.TransactionId addr x)
135 -> (Client String meth DHT.TransactionId addr x
136 -> Transport String addr x -> Transport String addr x)
137 -> IO (Client String meth DHT.TransactionId addr x)
138newClient drg net classify selfAddr handlers modifytbl modifynet = do
139 -- If we have 8-byte keys for IntMap, then use it for transaction lookups.
140 -- Otherwise, use ordinary Map. The details of which will be hidden by an
141 -- existential closure (see mkclient below).
142 --
143 tblvar <-
144 if fitsInInt (Proxy :: Proxy Word64)
145 then do
146 let intmapT = transactionMethods (contramap intKey intMapMethods) gen
147 intmap_var <- atomically $ newTVar (drg, mempty)
148 return $ Right (intmapT,intmap_var)
149 else do
150 let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen
151 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
152 return $ Left (word64mapT,map_var)
153 let dispatch tbl var handlers client = DispatchMethods
154 { classifyInbound = classify client
155 , lookupHandler = handlers -- var
156 , tableMethods = modifytbl tbl
157 }
158 eprinter = logErrors -- printErrors stderr
159 mkclient (tbl,var) handlers =
160 let client = Client
161 { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
162 , clientDispatcher = dispatch tbl var (handlers client) client
163 , clientErrorReporter = eprinter
164 , clientPending = var
165 , clientAddress = selfAddr
166 , clientResponseId = genNonce24 var
167 }
168 in client
169 return $ either mkclient mkclient tblvar handlers
170
171data Tox extra = Tox
172 { toxDHT :: DHT.Client
173 , toxOnion :: Onion.Client RouteId
174 , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
175 , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted)
176 , toxHandshakes :: Transport String SockAddr (Handshake Encrypted)
177 , toxHandshakeCache :: HandshakeCache
178 , toxCryptoKeys :: TransportCrypto
179 , toxRouting :: DHT.Routing
180 , toxTokens :: TVar SessionTokens
181 , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
182 , toxOnionRoutes :: OnionRouter
183 , toxContactInfo :: ContactInfo extra
184 , toxAnnounceToLan :: IO ()
185 , toxBindAddress :: SockAddr
186 }
187
188
189
190-- | Create a DHTPublicKey packet to send to a remote contact.
191getContactInfo :: Tox extra -> IO DHT.DHTPublicKey
192getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
193 r4 <- readTVar $ DHT.routing4 toxRouting
194 r6 <- readTVar $ DHT.routing6 toxRouting
195 nonce <- transportNewNonce toxCryptoKeys
196 let self = nodeId n4
197 n4 = R.thisNode r4
198 n6 = R.thisNode r6
199 n4s = R.kclosest DHT.toxSpace 4 self r4
200 n6s = R.kclosest DHT.toxSpace 4 self r6
201 ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
202 ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
203 return $ do
204 timestamp <- round . (* 1000000) <$> getPOSIXTime
205 return DHT.DHTPublicKey
206 { dhtpkNonce = timestamp
207 , dhtpk = id2key self
208 , dhtpkNodes = DHT.SendNodes $ take 4 ns
209 }
210
211isLocalHost :: SockAddr -> Bool
212isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
213isLocalHost _ = False
214
215addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
216addVerbosity tr =
217 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
218 forM_ m $ mapM_ $ \(msg,addr) -> do
219 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
220 mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x))
221 $ xxd 0 msg
222 kont m
223 , sendMessage = \addr msg -> do
224 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do
225 mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x))
226 $ xxd 0 msg
227 sendMessage tr addr msg
228 }
229
230newKeysDatabase :: IO (TVar Onion.AnnouncedKeys)
231newKeysDatabase =
232 atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty
233
234
235getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r)
236getOnionAlias crypto dhtself remoteNode = atomically $ do
237 ni <- dhtself
238 let alias = case remoteNode of
239 Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _)
240 -> ni { nodeId = key2id uk }
241 _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
242 return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
243
244newOnionClient :: DRG g =>
245 TransportCrypto
246 -> Transport String (Onion.OnionDestination RouteId) Onion.Message
247 -> DHT.Routing
248 -> TVar SessionTokens
249 -> TVar Onion.AnnouncedKeys
250 -> OnionRouter
251 -> TVar (g, Data.Word64Map.Word64Map a)
252 -> ((Maybe Onion.Message -> IO ()) -> a)
253 -> (a -> Maybe Onion.Message -> IO void)
254 -> Client String
255 DHT.PacketKind
256 DHT.TransactionId
257 (Onion.OnionDestination RouteId)
258 Onion.Message
259newOnionClient crypto net r toks keydb orouter map_var store load = c
260 where
261 eprinter = logErrors
262 c = Client
263 { clientNet = addHandler (reportParseError eprinter) (handleMessage c) net
264 , clientDispatcher = DispatchMethods
265 { classifyInbound = Onion.classify
266 , lookupHandler = Onion.handlers net r toks keydb
267 , tableMethods = hookQueries orouter DHT.transactionKey
268 $ transactionMethods' store load (contramap w64Key w64MapMethods) gen
269 }
270 , clientErrorReporter = eprinter
271 , clientPending = map_var
272 , clientAddress = getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 r)
273 , clientResponseId = genNonce24 map_var
274 }
275
276newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for.
277 -> [String] -- ^ Bind-address to listen on. Must provide at least one.
278 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
279 -> Maybe SecretKey -- ^ Optional DHT secret key to use.
280 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
281 -> IO (Tox extra)
282newTox keydb bindspecs onsess suppliedDHTKey tcp = do
283 addrs <- mapM (`getBindAddress` True) bindspecs
284 let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just)
285 failedBind mbe = do
286 forM_ mbe $ \e -> do
287 dput XDHT $ "tox udp bind error: " ++ show addrs ++ " " ++ show e
288 throwIO e
289 throwIO $ userError "Tox UDP listen port?"
290 (udp,sock) <- foldr tryBind failedBind addrs Nothing
291 addr <- getSocketName sock
292 (relay,sendTCP) <- tcpRelay addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x)
293 tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp sendTCP
294 return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) }
295
296-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
297newToxOverTransport :: TVar Onion.AnnouncedKeys
298 -> SockAddr
299 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
300 -> Maybe SecretKey
301 -> Onion.UDPTransport
302 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
303 -> IO (Tox extra)
304newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
305 roster <- newContactInfo
306 crypto0 <- newCrypto
307 let -- patch in supplied DHT key
308 crypto1 = fromMaybe crypto0 $do
309 k <- suppliedDHTKey
310 return crypto0
311 { transportSecret = k
312 , transportPublic = toPublic k
313 }
314 -- patch in newly allocated roster state.
315 crypto = crypto1 { userKeys = myKeyPairs roster }
316 forM_ suppliedDHTKey $ \k -> do
317 maybe (dput XMisc "failed to encode suppliedDHTKey")
318 (dputB XMisc . C8.append "Using suppliedDHTKey: ")
319 $ encodeSecret k
320
321 drg <- drgNew
322 let lookupClose _ = return Nothing
323
324 mkrouting <- DHT.newRouting addr crypto updateIP updateIP
325 (orouter,otbl) <- newOnionRouter crypto (dput XRoutes)
326 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes)
327 <- toxTransport crypto orouter lookupClose udp
328 (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x))
329 tcp
330 sessions <- initSessions (sendMessage cryptonet)
331
332 let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
333 tbl4 = DHT.routing4 $ mkrouting (error "missing client")
334 tbl6 = DHT.routing6 $ mkrouting (error "missing client")
335 updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr
336 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
337 (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)
338
339 hscache <- newHandshakeCache crypto (sendMessage handshakes)
340 let sparams = SessionParams
341 { spCrypto = crypto
342 , spSessions = sessions
343 , spGetSentHandshake = getSentHandshake hscache
344 , spOnNewSession = onNewSession roster addr
345 }
346
347 -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked.
348 -- This function should only initialize state.
349 orouter' <- forkRouteBuilder orouter
350 $ \nid ni -> fmap (\(_,ns,_)->ns)
351 <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid ni
352
353 toks <- do
354 nil <- nullSessionTokens
355 atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
356 let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
357 let onionclient = newOnionClient crypto onionnet (mkrouting dhtclient) toks keydb orouter' otbl
358 Right $ \case
359 Right v -> v
360 Left v -> \_ ->
361 dput XUnexpected "TCP-sent onion query got response over UDP?"
362
363 return Tox
364 { toxDHT = dhtclient
365 , toxOnion = onionclient
366 , toxToRoute = onInbound (updateContactInfo roster) dtacrypt
367 , toxCrypto = addHandler (dput XMisc) (sessionHandler sessions) cryptonet
368 , toxHandshakes = addHandler (dput XMisc) (handshakeH sparams) handshakes
369 , toxHandshakeCache = hscache
370 , toxCryptoKeys = crypto
371 , toxRouting = mkrouting dhtclient
372 , toxTokens = toks
373 , toxAnnouncedKeys = keydb
374 , toxOnionRoutes = orouter' -- TODO: see above
375 , toxContactInfo = roster
376 , toxAnnounceToLan = return ()
377 , toxBindAddress = addr
378 }
379
380onionTimeout :: Tox extra -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
381onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od
382
383routing4nodeInfo :: DHT.Routing -> IO NodeInfo
384routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv
385
386dnssdAnnounce :: Tox extra -> IO ()
387dnssdAnnounce tox = do
388 ni <- routing4nodeInfo (toxRouting tox)
389 keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox)
390 announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys)
391
392dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO ()
393dnssdDiscover tox ni toxid = do
394 acts <- atomically $ readTVar $ accounts $ toxContactInfo tox
395 now <- getPOSIXTime
396 forM toxid $ \tid ->
397 forM acts $ \act ->
398 atomically $ setContactAddr now (id2key tid) ni act
399
400 void $ DHT.ping (toxDHT tox) ni
401
402-- | Returns:
403--
404-- * action to shutdown this node, terminating all threads.
405--
406-- * action to bootstrap an IPv4 Kademlia table.
407--
408-- * action to bootstrap an IPv6 Kademlia table.
409forkTox :: Tox extra -> Bool -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
410forkTox tox with_avahi = do
411 quitHs <- forkListener "toxHandshakes" (toxHandshakes tox)
412 quitToRoute <- forkListener "toxToRoute" (toxToRoute tox)
413 quitOnion <- forkListener "toxOnion" (clientNet $ toxOnion tox)
414 quitDHT <- forkListener "toxDHT" (clientNet $ toxDHT tox)
415 quitNC <- forkListener "toxCrypto" (toxCrypto tox)
416 quitTCP <- forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
417 quitAvahi <- if with_avahi then do
418 forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
419 forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
420 dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox)
421 dnssdOut <- forkIO $ dnssdAnnounce tox
422 labelThread dnssdIn "tox-avahi-monitor"
423 labelThread dnssdOut "tox-avahi-publish"
424 return $ forM_ [dnssdIn,dnssdOut] killThread
425 else return $ return ()
426 keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox)
427 return ( do quitAvahi
428 killThread keygc
429 quitNC
430 quitDHT
431 quitOnion
432 quitTCP
433 quitRouteBuilder (toxOnionRoutes tox)
434 quitToRoute
435 quitHs
436 , bootstrap (DHT.refresher4 $ toxRouting tox)
437 , bootstrap (DHT.refresher6 $ toxRouting tox)
438 )
439
440-- TODO: Don't export this. The exported interface is 'toxAnnounceToLan'.
441announceToLan :: Socket -> NodeId -> IO ()
442announceToLan sock nid = do
443 addrs <- broadcastAddrs
444 forM_ addrs $ \addr -> do
445 (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram })
446 (Just addr)
447 (Just "33445")
448 let broadcast = addrAddress broadcast_info
449 bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid)
450 dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid
451 saferSendTo sock bs broadcast
452
453
454toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous
455toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox)
456
diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs
deleted file mode 100644
index 8c728660..00000000
--- a/src/Network/Tox/AggregateSession.hs
+++ /dev/null
@@ -1,374 +0,0 @@
1-- | This module aggregates all sessions to the same remote Tox contact into a
2-- single online/offline presence. This allows multiple lossless links to the
3-- same identity at different addresses, or even to the same address.
4{-# LANGUAGE CPP #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE PatternSynonyms #-}
8module Network.Tox.AggregateSession
9 ( AggregateSession
10 , newAggregateSession
11 , aggregateStatus
12 , checkCompatible
13 , compatibleKeys
14 , AddResult(..)
15 , addSession
16 , DelResult(..)
17 , delSession
18 , closeAll
19 , awaitAny
20 , dispatchMessage
21 ) where
22
23
24import Control.Concurrent.STM
25import Control.Concurrent.STM.TMChan
26import Control.Monad
27import Data.Dependent.Sum
28import Data.Function
29import qualified Data.IntMap.Strict as IntMap
30 ;import Data.IntMap.Strict (IntMap)
31import Data.List
32import Data.Time.Clock.POSIX
33import System.IO.Error
34
35#ifdef THREAD_DEBUG
36import Control.Concurrent.Lifted.Instrument
37#else
38import Control.Concurrent.Lifted
39import GHC.Conc (labelThread)
40#endif
41
42import Connection (Status (..))
43import Crypto.Tox (PublicKey, toPublic)
44import Data.Tox.Msg
45import Data.Wrapper.PSQInt as PSQ
46import DPut
47import DebugTag
48import Network.QueryResponse
49import Network.Tox.Crypto.Transport
50import Network.Tox.DHT.Transport (key2id)
51import Network.Tox.NodeId (ToxProgress (..))
52import Network.Tox.Session
53
54-- | For each component session, we track the current status.
55data SingleCon = SingleCon
56 { singleSession :: Session -- ^ A component session.
57 , singleStatus :: TVar (Status ToxProgress) -- ^ Either 'AwaitingSessionPacket' or 'Established'.
58 }
59
60-- | A collection of sessions between the same local and remote identities.
61data AggregateSession = AggregateSession
62 { -- | The set of component sessions indexed by their ID.
63 contactSession :: TVar (IntMap SingleCon)
64 -- | Each inbound packets is written to this channel with the session ID
65 -- from which it came originally.
66 , contactChannel :: TMChan (Int,CryptoMessage)
67 -- | The set of 'Established' sessions IDs.
68 , contactEstablished :: TVar (IntMap ())
69 -- | Callback for state-change notifications.
70 , notifyState :: AggregateSession -> Session -> Status ToxProgress -> STM ()
71 }
72
73
74-- | Create a new empty aggregate session. The argument is a callback to
75-- receive notifications when the new session changes status. There are three
76-- possible status values:
77--
78-- [ Dormant ] - No pending or established sessions.
79--
80-- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are
81-- fully established.
82--
83-- [ Established ] - At least one session is fully established and we can
84-- send and receive packets via this aggregate.
85--
86-- The 'Session' object is provided to the callback so that it can determine the
87-- current remote and local identities for this AggregateSession. It may not even
88-- be Established, so do not use it to send or receive packets.
89newAggregateSession :: (AggregateSession -> Session -> Status ToxProgress -> STM ())
90 -> STM AggregateSession
91newAggregateSession notify = do
92 vimap <- newTVar IntMap.empty
93 chan <- newTMChan
94 vemap <- newTVar IntMap.empty
95 return AggregateSession
96 { contactSession = vimap
97 , contactChannel = chan
98 , contactEstablished = vemap
99 , notifyState = notify
100 }
101
102-- | Information returned from 'addSession'. Note that a value other than
103-- 'RejectedSession' does not mean there is any 'Established' session in the
104-- Aggregate. Sessions are in 'AwaitingSessionPacket' state until a single
105-- packet is received from the remote end.
106data AddResult = FirstSession -- ^ Initial connection with this contact.
107 | AddedSession -- ^ Added another connection to active session.
108 | RejectedSession -- ^ Failed to add session (wrong contact / closed session).
109
110-- | The 'keepAlive' thread juggles three scheduled tasks.
111data KeepAliveEvents = DoTimeout -- ^ A session timed-out, close it.
112 | DoAlive -- ^ Send a the keep-alive becon for a session.
113 | DoRequestMissing -- ^ Detect and request lost packets.
114 deriving Enum
115
116-- | This call loops until the provided sesison is closed or times out. It
117-- monitors the provided (non-empty) priority queue for scheduled tasks (see
118-- 'KeepAliveEvents') to perform for the connection.
119keepAlive :: Session -> TVar (PSQ POSIXTime) -> IO ()
120keepAlive s q = do
121 myThreadId >>= flip labelThread
122 (intercalate "." ["beacon"
123 , take 8 $ show $ key2id $ sTheirUserKey s
124 , show $ sSessionID s])
125
126 let -- outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e
127 unexpected e = dput XUnexpected $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e
128
129 doAlive = do
130 -- outPrint $ "Beacon"
131 sendMessage (sTransport s) () (Pkt ALIVE ==> ())
132
133 doRequestMissing = do
134 (ns,nmin) <- sMissingInbound s
135 -- outPrint $ "PacketRequest " ++ show (nmin,ns)
136 sendMessage (sTransport s) () (Pkt PacketRequest ==> MissingPackets ns)
137 `catchIOError` \e -> do
138 unexpected $ "PacketRequest " ++ take 200 (show (nmin,length ns,ns))
139 unexpected $ "PacketRequest: " ++ show e
140 -- Quit thread by scheduling a timeout event.
141 now <- getPOSIXTime
142 atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) now
143
144 re tm again e io = do
145 io
146 atomically $ modifyTVar' q $ PSQ.insert (fromEnum e) tm
147 again
148
149 doEvent again now e = case e of
150 DoTimeout -> do dput XNetCrypto $ "TIMEOUT: " ++ show (sSessionID s)
151 sClose s
152 DoAlive -> re (now + 10) again e doAlive
153 DoRequestMissing -> re (now + 5) again e doRequestMissing -- tox-core does this at 1 second intervals
154
155 fix $ \again -> do
156
157 now <- getPOSIXTime
158 join $ atomically $ do
159 PSQ.findMin <$> readTVar q >>= \case
160 Nothing -> error "keepAlive: unexpected empty PSQ."
161 Just ( k :-> tm ) ->
162 return $ if now < tm then threadDelay (toMicroseconds $ tm - now) >> again
163 else doEvent again now (toEnum k)
164
165
166-- | This function forks two threads: the 'keepAlive' beacon-sending thread and
167-- a thread to read all packets from the provided 'Session' and forward them to
168-- 'contactChannel' for a containing 'AggregateSession'
169forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId
170forkSession c s setStatus = forkIO $ do
171 myThreadId >>= flip labelThread
172 (intercalate "." ["s"
173 , take 8 $ show $ key2id $ sTheirUserKey s
174 , show $ sSessionID s])
175
176 q <- atomically $ newTVar $ fromList
177 [ fromEnum DoAlive :-> 0
178 , fromEnum DoRequestMissing :-> 0
179 ]
180
181 let sendPacket :: CryptoMessage -> STM ()
182 sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg)
183
184 inPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " --> " ++ e
185
186 bump = do
187 -- inPrint $ "BUMP: " ++ show (sSessionID s)
188 now <- getPOSIXTime
189 atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) (now + 15)
190
191 onPacket body loop Nothing = return ()
192 onPacket body loop (Just (Left e)) = inPrint e >> loop
193 onPacket body loop (Just (Right x)) = body loop x
194
195 awaitPacket body = fix $ awaitMessage (sTransport s) . onPacket body
196
197 atomically $ setStatus $ InProgress AwaitingSessionPacket
198 awaitPacket $ \_ (online,()) -> do
199 when (msgID online /= M ONLINE) $ do
200 inPrint $ "Unexpected initial packet: " ++ show (msgID online)
201 atomically $ do setStatus Established
202 sendPacket online
203 bump
204 beacon <- forkIO $ keepAlive s q
205 awaitPacket $ \awaitNext (x,()) -> do
206 bump
207 case msgID x of
208 M ALIVE -> return ()
209 M KillPacket -> sClose s
210 _ -> atomically $ sendPacket x
211 awaitNext
212 atomically $ setStatus Dormant
213 killThread beacon
214
215-- | Add a new session (in 'AwaitingSessionPacket' state) to the
216-- 'AggregateSession'. If the supplied session is not compatible because it is
217-- between the wrong ToxIDs or because the AggregateSession is closed,
218-- 'RejectedSession' will be returned. Otherwise, the operation is successful.
219--
220-- The status-change callback may be triggered by this call as the aggregate
221-- may transition from 'Dormant' (empty) to 'AwaitingSessionPacket' (at least
222-- one active session).
223addSession :: AggregateSession -> Session -> IO AddResult
224addSession c s = do
225 (result,mcon,replaced) <- atomically $ do
226 let them = sTheirUserKey s
227 me = toPublic $ sOurKey s
228 compat <- checkCompatible me them c
229 let result = case compat of
230 Nothing -> FirstSession
231 Just True -> AddedSession
232 Just False -> RejectedSession
233 case result of
234 RejectedSession -> return (result,Nothing,Nothing)
235 _ -> do
236 statvar <- newTVar Dormant
237 imap <- readTVar (contactSession c)
238 let con = SingleCon s statvar
239 s0 = IntMap.lookup (sSessionID s) imap
240 imap' = IntMap.insert (sSessionID s) con imap
241 writeTVar (contactSession c) imap'
242 return (result,Just con,s0)
243
244 mapM_ (sClose . singleSession) replaced
245 forM_ mcon $ \con ->
246 forkSession c s $ \progress -> do
247 writeTVar (singleStatus con) progress
248 emap <- readTVar (contactEstablished c)
249 emap' <- case progress of
250 Established -> do
251 when (IntMap.null emap) $ notifyState c c s Established
252 return $ IntMap.insert (sSessionID s) () emap
253 _ -> do
254 let emap' = IntMap.delete (sSessionID s) emap
255 when (IntMap.null emap' && not (IntMap.null emap)) $ do
256 imap <- readTVar (contactSession c)
257 notifyState c c s
258 $ if IntMap.null imap then Dormant
259 else InProgress AwaitingSessionPacket
260 return emap'
261 writeTVar (contactEstablished c) emap'
262 return result
263
264-- | Information returned from 'delSession'.
265data DelResult = NoSession -- ^ Contact is completely disconnected.
266 | DeletedSession -- ^ Connection removed but session remains active.
267
268-- | Close and remove the componenent session corresponding to the provided
269-- Session ID.
270--
271-- The status-change callback may be triggered as the aggregate may may
272-- transition to 'Dormant' (empty) or 'AwaitingSessionPacket' (if the last
273-- 'Established' session is closed).
274delSession :: AggregateSession -> Int -> IO DelResult
275delSession c sid = do
276 (con, r) <- atomically $ do
277 imap <- readTVar (contactSession c)
278 emap <- readTVar (contactEstablished c)
279 let emap' = IntMap.delete sid emap
280 imap' = IntMap.delete sid imap
281 case IntMap.toList emap of
282 (sid0,_):_ | IntMap.null emap'
283 , let s = singleSession $ imap IntMap.! sid0
284 -> notifyState c c s
285 $ if IntMap.null imap' then Dormant
286 else InProgress AwaitingSessionPacket
287 _ -> return ()
288 writeTVar (contactSession c) imap'
289 writeTVar (contactEstablished c) emap'
290 return ( IntMap.lookup sid imap, IntMap.null imap')
291 mapM_ (sClose . singleSession) con
292 return $ if r then NoSession
293 else DeletedSession
294
295-- | Send a packet to one or all of the component sessions in the aggregate.
296dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID.
297 -> CryptoMessage -> IO ()
298dispatchMessage c msid msg = join $ atomically $ do
299 imap <- readTVar (contactSession c)
300 let go = case msid of Nothing -> forM_ imap
301 Just sid -> forM_ (IntMap.lookup sid imap)
302 return $ go $ \con -> sendMessage (sTransport $ singleSession con) () msg
303
304-- | Retry until:
305--
306-- * a packet arrives (with component session ID) arrives.
307--
308-- * the 'AggregateSession' is closed with 'closeAll'.
309awaitAny :: AggregateSession -> STM (Maybe (Int,CryptoMessage))
310awaitAny c = readTMChan (contactChannel c)
311
312-- | Close all connections associated with the aggregate. No new sessions will
313-- be accepted after this, and the notify callback will be informed that we've
314-- transitioned to 'Dormant'.
315closeAll :: AggregateSession -> IO ()
316closeAll c = join $ atomically $ do
317 imap <- readTVar (contactSession c)
318 closeTMChan (contactChannel c)
319 return $ forM_ (IntMap.keys imap) $ \sid -> delSession c sid
320
321-- | Query the current status of the aggregate, there are three possible
322-- values:
323--
324-- [ Dormant ] - No pending or established sessions.
325--
326-- [ InProgress AwaitingSessionPacket ] - Sessions are pending, but none are
327-- fully established.
328--
329-- [ Established ] - At least one session is fully established and we can
330-- send and receive packets via this aggregate.
331--
332aggregateStatus :: AggregateSession -> STM (Status ToxProgress)
333aggregateStatus c = do
334 isclosed <- isClosedTMChan (contactChannel c)
335 imap <- readTVar (contactSession c)
336 emap <- readTVar (contactEstablished c)
337 return $ case () of
338 _ | isclosed -> Dormant
339 | not (IntMap.null emap) -> Established
340 | not (IntMap.null imap) -> InProgress AwaitingSessionPacket
341 | otherwise -> Dormant
342
343-- | Query whether the supplied ToxID keys are compatible with this aggregate.
344--
345-- [ Nothing ] Any keys would be compatible because there is not yet any
346-- sessions in progress.
347--
348-- [ Just True ] The supplied keys match the session in progress.
349--
350-- [ Just False ] The supplied keys are incompatible.
351checkCompatible :: PublicKey -- ^ Local Tox key (for which we know the secret).
352 -> PublicKey -- ^ Remote Tox key.
353 -> AggregateSession -> STM (Maybe Bool)
354checkCompatible me them c = do
355 isclosed <- isClosedTMChan (contactChannel c)
356 imap <- readTVar (contactSession c)
357 return $ case IntMap.elems imap of
358 _ | isclosed -> Just False -- All keys are incompatible (closed).
359 con:_ -> Just $ sTheirUserKey (singleSession con) == them
360 && toPublic (sOurKey $ singleSession con) == me
361 [] -> Nothing
362
363-- | Returns the local and remote keys that are compatible with this aggregate.
364-- If 'Nothing' Is returned, then either no key is compatible ('closeAll' was
365-- called) or all keys are compatible because no sessions have been associated.
366compatibleKeys :: AggregateSession -> STM (Maybe (PublicKey,PublicKey))
367compatibleKeys c = do
368 isclosed <- isClosedTMChan (contactChannel c)
369 imap <- readTVar (contactSession c)
370 return $ case IntMap.elems imap of
371 _ | isclosed -> Nothing -- none.
372 con:_ -> Just ( toPublic (sOurKey $ singleSession con)
373 , sTheirUserKey (singleSession con))
374 [] -> Nothing -- any.
diff --git a/src/Network/Tox/Avahi.hs b/src/Network/Tox/Avahi.hs
deleted file mode 100644
index 635ba656..00000000
--- a/src/Network/Tox/Avahi.hs
+++ /dev/null
@@ -1,65 +0,0 @@
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ViewPatterns #-}
4module Network.Tox.Avahi
5 ( module Network.Tox.Avahi
6 , NodeInfo(..)
7 , NodeId
8 ) where
9
10import Control.Applicative
11import Data.Foldable
12import Network.Address
13import Network.Avahi
14import Network.BSD (getHostName)
15import Network.Tox.NodeId
16import Text.Read
17
18toxServiceName :: String
19toxServiceName = "_tox_dht._udp"
20
21toxServiceDomain :: String
22toxServiceDomain = "local"
23
24(<.>) :: String -> String -> String
25a <.> b = a ++ "." ++ b
26
27toxService :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> Service
28toxService hostname (fromIntegral -> port) dhtkey toxid =
29 Service {
30 serviceProtocol = PROTO_UNSPEC,
31 serviceName = "Tox DHT @ " ++ hostname,
32 serviceType = toxServiceName,
33 serviceDomain = toxServiceDomain,
34 serviceHost = if null hostname then "" else hostname <.> toxServiceDomain,
35 serviceAddress = Nothing,
36 servicePort = port,
37 serviceText = maybe (show dhtkey) (show . ((,) dhtkey)) toxid
38 }
39
40announceToxServiceWithHostname :: String -> PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
41announceToxServiceWithHostname = (boobs.boobs) announce toxService
42 where boobs = ((.).(.))
43
44announceToxService :: PortNumber -> NodeId -> (Maybe NodeId) -> IO ()
45announceToxService a b c = do
46 h <- getHostName
47 announceToxServiceWithHostname h a b c
48
49queryToxService :: (NodeInfo -> Maybe NodeId -> IO ()) -> IO ()
50queryToxService cb =
51 browse $
52 BrowseQuery
53 { lookupProtocol = PROTO_UNSPEC
54 , lookupServiceName = toxServiceName
55 , lookupDomain = toxServiceDomain
56 , lookupCallback = runCallback
57 }
58 where
59 runCallback Service {..} = do
60 let both :: Maybe (NodeId, NodeId)
61 both = readMaybe serviceText
62 nid = (fst <$> both) <|> readMaybe serviceText
63 addr = readMaybe =<< serviceAddress
64 p = fromIntegral servicePort
65 forM_ nid $ \n -> forM_ addr $ \a -> cb (NodeInfo n a p) (snd <$> both)
diff --git a/src/Network/Tox/ContactInfo.hs b/src/Network/Tox/ContactInfo.hs
deleted file mode 100644
index e7cb48c1..00000000
--- a/src/Network/Tox/ContactInfo.hs
+++ /dev/null
@@ -1,172 +0,0 @@
1{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE LambdaCase #-}
3module Network.Tox.ContactInfo where
4
5import Connection
6
7import Data.Time.Clock.POSIX
8import Control.Concurrent.STM
9import Control.Monad
10import Crypto.PubKey.Curve25519
11import qualified Data.HashMap.Strict as HashMap
12 ;import Data.HashMap.Strict (HashMap)
13import Data.Maybe
14import Network.Tox.DHT.Transport as DHT
15import Network.Tox.NodeId (id2key)
16import Network.Tox.Onion.Transport as Onion
17import DPut
18import DebugTag
19
20newtype ContactInfo extra = ContactInfo
21 -- | Map our toxid public key to an Account record.
22 { accounts :: TVar (HashMap NodeId{-my userkey-} (Account extra))
23 }
24
25data Account extra = Account
26 { userSecret :: SecretKey -- local secret key
27 , contacts :: TVar (HashMap NodeId{-friend's userkey-} Contact) -- received contact info
28 , accountExtra :: TVar extra
29 , eventChan :: TChan ContactEvent
30 }
31
32data ContactEvent = OnionRouted { contact :: PublicKey, onionRouted :: OnionData }
33 | PolicyChange { contact :: PublicKey, policyChange :: Policy }
34 | AddrChange { contact :: PublicKey, addrChange :: NodeInfo }
35 | SessionEstablished { contact :: PublicKey }
36 | SessionTerminated { contact :: PublicKey }
37
38data Contact = Contact
39 { contactKeyPacket :: TVar (Maybe (POSIXTime,DHT.DHTPublicKey))
40 , contactLastSeenAddr :: TVar (Maybe (POSIXTime,NodeInfo))
41 , contactFriendRequest :: TVar (Maybe (POSIXTime,DHT.FriendRequest))
42 , contactPolicy :: TVar (Maybe Connection.Policy)
43 }
44
45newContactInfo :: IO (ContactInfo extra)
46newContactInfo = atomically $ ContactInfo <$> newTVar HashMap.empty
47
48myKeyPairs :: ContactInfo extra -> STM [(SecretKey,PublicKey)]
49myKeyPairs (ContactInfo accounts) = do
50 acnts <- readTVar accounts
51 forM (HashMap.toList acnts) $ \(nid, Account{userSecret}) -> do
52 return (userSecret,id2key nid)
53
54updateContactInfo :: ContactInfo extra -> Onion.AnnouncedRendezvous -> (PublicKey,Onion.OnionData) -> IO ()
55updateContactInfo roster Onion.AnnouncedRendezvous{remoteUserKey} (localUserKey,omsg) = do
56 dput XMisc "updateContactInfo!!!"
57 now <- getPOSIXTime
58 atomically $ do
59 as <- readTVar (accounts roster)
60 maybe (return ())
61 (updateAccount now remoteUserKey omsg)
62 $ HashMap.lookup (key2id localUserKey) as
63
64initContact :: STM Contact
65initContact = Contact <$> newTVar Nothing
66 <*> newTVar Nothing
67 <*> newTVar Nothing
68 <*> newTVar Nothing
69
70getContact :: PublicKey -> Account extra -> STM (Maybe Contact)
71getContact remoteUserKey acc = do
72 let rkey = key2id remoteUserKey
73 cmap <- readTVar (contacts acc)
74 return $ HashMap.lookup rkey cmap
75
76updateAccount' :: PublicKey -> Account extra -> (Contact -> STM ()) -> STM ()
77updateAccount' remoteUserKey acc updater = do
78 let rkey = key2id remoteUserKey
79 cmap <- readTVar (contacts acc)
80 contact <- case HashMap.lookup rkey cmap of
81 Just contact -> return contact
82 Nothing -> do contact <- initContact
83 writeTVar (contacts acc) $ HashMap.insert rkey contact cmap
84 return contact
85 updater contact
86
87updateAccount :: POSIXTime -> PublicKey -> Onion.OnionData -> Account extra -> STM ()
88updateAccount now remoteUserKey omsg acc = do
89 updateAccount' remoteUserKey acc $ onionUpdate now omsg
90 writeTChan (eventChan acc) $ OnionRouted remoteUserKey omsg
91
92onionUpdate :: POSIXTime -> OnionData -> Contact -> STM ()
93onionUpdate now (Onion.OnionDHTPublicKey dhtpk) contact
94 = writeTVar (contactKeyPacket contact) $ Just (now,dhtpk)
95onionUpdate now (Onion.OnionFriendRequest fr) contact
96 = writeTVar (contactFriendRequest contact) $ Just (now,fr)
97
98policyUpdate :: Policy -> Contact -> STM ()
99policyUpdate policy contact = writeTVar (contactPolicy contact) $ Just policy
100
101addrUpdate :: POSIXTime -> NodeInfo -> Contact -> STM ()
102addrUpdate now addr contact = writeTVar (contactLastSeenAddr contact) $ Just (now,addr)
103
104setContactPolicy :: PublicKey -> Policy -> Account extra -> STM ()
105setContactPolicy remoteUserKey policy acc = do
106 updateAccount' remoteUserKey acc $ policyUpdate policy
107 writeTChan (eventChan acc) $ PolicyChange remoteUserKey policy
108
109setContactAddr :: POSIXTime -> PublicKey -> NodeInfo -> Account extra -> STM ()
110setContactAddr now remoteUserKey addr acc = do
111 contact <- getContact remoteUserKey acc
112 let update = updateAccount' remoteUserKey acc $ addrUpdate now addr
113 let notify = writeTChan (eventChan acc) $ AddrChange remoteUserKey addr
114 join <$> traverse (readTVar . contactLastSeenAddr) contact >>= \case
115 Just (_, a) | addr == a -> update -- updates time only
116 Just (t, _) | now > t + 60 -> update >> notify -- update IP if existing one is old
117 Nothing -> update >> notify -- or if we don't have any
118 _ -> return () -- otherwise just wait
119
120setEstablished :: PublicKey -> Account extra -> STM ()
121setEstablished remoteUserKey acc =
122 writeTChan (eventChan acc) $ SessionEstablished remoteUserKey
123
124setTerminated :: PublicKey -> Account extra -> STM ()
125setTerminated remoteUserKey acc =
126 writeTChan (eventChan acc) $ SessionTerminated remoteUserKey
127
128
129addContactInfo :: ContactInfo extra -> SecretKey -> extra -> STM ()
130addContactInfo (ContactInfo as) sk extra = do
131 a <- newAccount sk extra
132 modifyTVar' as $ HashMap.insert (key2id $ toPublic sk) a
133
134delContactInfo :: ContactInfo extra -> PublicKey -> STM ()
135delContactInfo (ContactInfo as) pk = modifyTVar' as $ HashMap.delete (key2id pk)
136
137newAccount :: SecretKey -> extra -> STM (Account extra)
138newAccount sk extra = Account sk <$> newTVar HashMap.empty
139 <*> newTVar extra
140 <*> newBroadcastTChan
141
142dnsPresentation :: ContactInfo extra -> STM String
143dnsPresentation (ContactInfo accsvar) = do
144 accs <- readTVar accsvar
145 ms <- forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
146 cs <- readTVar cvar
147 rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
148 mkpkt <- readTVar (contactKeyPacket c)
149 return $ fmap (\(_,d) -> (nid,d)) mkpkt
150 return $
151 "; local key = " ++ show (key2id $ toPublic sec) ++ "\n"
152 ++ concatMap dnsPresentation1 (catMaybes rs)
153 return $ concat ms
154
155dnsPresentation1 :: (NodeId,DHTPublicKey) -> String
156dnsPresentation1 (nid,dk) = unlines
157 [ concat [ show nid, ".tox. IN CNAME ", show (key2id $ dhtpk dk), ".dht." ]
158 ]
159
160type LocalKey = NodeId
161type RemoteKey = NodeId
162
163friendRequests :: ContactInfo extra -> STM (HashMap LocalKey [(RemoteKey,DHT.FriendRequest)])
164friendRequests (ContactInfo roster) = do
165 accs <- readTVar roster
166 forM accs $ \Account { userSecret = sec, contacts = cvar } -> do
167 cs <- readTVar cvar
168 rs <- forM (HashMap.toList cs) $ \(nid,c) -> do
169 mfr <- readTVar (contactFriendRequest c)
170 return $ fmap (\(_,x) -> (nid,x)) mfr
171 return $ catMaybes rs
172
diff --git a/src/Network/Tox/Crypto/Transport.hs b/src/Network/Tox/Crypto/Transport.hs
deleted file mode 100644
index a18b550d..00000000
--- a/src/Network/Tox/Crypto/Transport.hs
+++ /dev/null
@@ -1,1029 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE NamedFieldPuns #-}
8{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TupleSections #-}
11{-# LANGUAGE ViewPatterns #-}
12module Network.Tox.Crypto.Transport
13 ( showCryptoMsg
14 , parseCrypto
15 , encodeCrypto
16 , unpadCryptoMsg
17 , decodeRawCryptoMsg
18 , parseHandshakes
19 , encodeHandshakes
20 , CryptoData(..)
21 , CryptoMessage(..)
22 , MessageName(..)
23 , CryptoPacket(..)
24 , HandshakeData(..)
25 , Handshake(..)
26 , PeerInfo(..)
27 , UserStatus(..)
28 , TypingStatus(..)
29 , GroupChatId(..)
30 , MessageType(..)
31 , isKillPacket, isOFFLINE
32 , KnownLossyness(..)
33 , AsWord16(..)
34 , AsWord64(..)
35 -- feild name classes
36 , HasGroupChatID(..)
37 , HasGroupNumber(..)
38 , HasPeerNumber(..)
39 , HasMessageNumber(..)
40 , HasMessageName(..)
41 , HasMessageData(..)
42 , HasName(..)
43 , HasTitle(..)
44 , HasMessage(..)
45 , HasMessageType(..)
46 -- lenses
47#ifdef USE_lens
48 , groupNumber, groupNumberToJoin, peerNumber, messageNumber
49 , messageName, messageData, name, title, message, messageType
50#endif
51 -- constructor
52 -- utils
53 , sizedN
54 , sizedAtLeastN
55 , isIndirectGrpChat
56 , fromEnum8
57 , fromEnum16
58 , toEnum8
59 , getCryptoMessage
60 , putCryptoMessage
61 ) where
62
63import Crypto.Tox
64import Data.Tox.Msg
65import Network.Tox.DHT.Transport (Cookie)
66import Network.Tox.NodeId
67import DPut
68import DebugTag
69import Data.PacketBuffer as PB
70
71import Network.Socket
72import Data.ByteArray
73import Data.Dependent.Sum
74
75import Control.Monad
76import Data.ByteString as B
77import Data.Function
78import Data.Maybe
79import Data.Monoid
80import Data.Word
81import Data.Bits
82import Crypto.Hash
83import Data.Functor.Contravariant
84import Data.Functor.Identity
85import Data.Text as T
86import Data.Text.Encoding as T
87import Data.Serialize as S
88import Control.Arrow
89import GHC.TypeNats
90
91showCryptoMsg :: Word32 -> CryptoMessage -> [Char]
92showCryptoMsg _ msg = show msg
93
94parseCrypto :: (ByteString, SockAddr) -> Either (CryptoPacket Encrypted, SockAddr) (ByteString, SockAddr)
95parseCrypto (bbs,saddr) = case B.uncons bbs of
96 Just (0x1b,bs) -> case runGet get bs of
97 Right pkt -> Left (pkt, saddr) -- Successful parse, handle this packet.
98 Left _ -> Right (bs,saddr) -- Failed parse, strip first byte and pass it on.
99 _ -> Right (bbs,saddr) -- Type-code mismatch, pass it on.
100
101encodeCrypto :: (CryptoPacket Encrypted, SockAddr) -> Maybe (ByteString, SockAddr)
102encodeCrypto (x,saddr) = Just (B.cons 0x1b (runPut $ put x),saddr)
103
104parseHandshakes :: ByteString -> SockAddr -> Either String (Handshake Encrypted, SockAddr)
105parseHandshakes (B.uncons -> Just (0x1a,pkt)) saddr = left ("parseHandshakes: "++) $ (,saddr) <$> runGet get pkt
106parseHandshakes bs _ = Left $ "parseHandshakes_: " ++ show (B.unpack $ B.take 1 bs)
107
108encodeHandshakes :: Handshake Encrypted -> SockAddr -> (ByteString, SockAddr)
109encodeHandshakes x saddr = (B.cons 0x1a (runPut $ put x),saddr)
110
111{-
112createRequestPacket :: Word32 -> [Word32] -> CryptoMessage
113createRequestPacket seqno xs = let r = UpToN PacketRequest (B.pack ns)
114 in dtrace XNetCrypto ("createRequestPacket " ++ show seqno ++ " " ++ show xs ++ " -----> " ++ show r) r
115 where
116 ys = Prelude.map (subtract (seqno - 1)) xs
117 reduceToSums [] = []
118 reduceToSums (x:xs) = x:(reduceToSums $ Prelude.map (subtract x) xs)
119 makeZeroes :: Word32 -> [Word32]
120 -- makeZeroes 0 = []
121 makeZeroes x
122 = let (d,m)= x `divMod` 255
123 zeros= Prelude.replicate (fromIntegral d) 0
124 in zeros ++ [m]
125 ns :: [Word8]
126 ns = Prelude.map fromIntegral (reduceToSums ys >>= makeZeroes)
127-}
128
129data Handshake (f :: * -> *) = Handshake
130 { -- The cookie is a cookie obtained by
131 -- sending a cookie request packet to the peer and getting a cookie
132 -- response packet with a cookie in it. It may also be obtained in the
133 -- handshake packet by a peer receiving a handshake packet (Other
134 -- Cookie).
135 handshakeCookie :: Cookie f
136 -- The nonce is a nonce used to encrypt the encrypted part of the handshake
137 -- packet.
138 , handshakeNonce :: Nonce24
139 -- The encrypted part of the handshake packet is encrypted with the long
140 -- term user-keys of both peers.
141 , handshakeData :: f HandshakeData
142 }
143
144instance Serialize (Handshake Encrypted) where
145 get = Handshake <$> get <*> get <*> get
146 put (Handshake cookie n24 dta) = put cookie >> put n24 >> put dta
147
148data HandshakeData = HandshakeData
149 { baseNonce :: Nonce24
150 -- ^ 24 bytes base nonce, recipient uses this to encrypt packets sent to the one who sent this handshake
151 -- adding one each time, so it can double as something like an approximate packet number
152 , sessionKey :: PublicKey
153 -- ^ session public key of the peer (32 bytes)
154 -- The recipient of the handshake encrypts using this public key when sending CryptoPackets
155 , cookieHash :: Digest SHA512
156 -- ^ sha512 hash of the entire Cookie sitting outside the encrypted part
157 -- This prevents a replay attack where a new cookie is inserted into
158 -- an old valid handshake packet
159 , otherCookie :: Cookie Encrypted
160 -- ^ Other Cookie (used by the recipient to respond to the handshake packet)
161 }
162 deriving (Eq,Ord,Show)
163
164instance Sized HandshakeData where
165 size = contramap baseNonce size
166 <> contramap (key2id . sessionKey) size
167 <> ConstSize 64 -- contramap cookieHash size -- missing instance Sized (Digest SHA512)
168 <> contramap otherCookie size
169
170instance Serialize HandshakeData where
171 get = HandshakeData <$> get
172 <*> getPublicKey
173 <*> (fromJust . digestFromByteString <$> getBytes 64)
174 <*> get
175 put (HandshakeData n k h c) = do
176 put n
177 putPublicKey k
178 putByteString (convert h)
179 put c
180
181data CryptoPacket (f :: * -> *) = CryptoPacket
182 { -- | The last 2 bytes of the nonce used to encrypt 'pktData'
183 pktNonce :: Word16
184 -- The payload is encrypted with the session key and 'baseNonce' set by
185 -- the receiver in their handshake + packet number (starting at 0, big
186 -- endian math).
187 , pktData :: f CryptoData
188 }
189
190deriving instance Show (CryptoPacket Encrypted)
191
192instance Sized CryptoData where
193 size = contramap bufferStart size
194 <> contramap bufferEnd size
195 <> contramap bufferData size
196
197instance Serialize (CryptoPacket Encrypted) where
198 get = CryptoPacket <$> get <*> get
199 put (CryptoPacket n16 dta) = put n16 >> put dta
200
201data CryptoData = CryptoData
202 { -- | [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
203 bufferStart :: Word32
204 -- | [ uint32_t packet number if lossless
205 -- , sendbuffer buffer_end if lossy , (big endian)]
206 , bufferEnd :: Word32
207 -- | [data] (TODO See Note [Padding])
208 , bufferData :: CryptoMessage
209 } deriving (Eq,Show)
210
211{-
212Note [Padding]
213
214TODO: The 'bufferData' field of 'CryptoData' should probably be something like
215/Padded CryptoMessage/ because c-toxcore strips leading zeros on incoming and
216pads leading zeros on outgoing packets.
217
218After studying c-toxcore (at commit c49a6e7f5bc245a51a3c85cc2c8b7f881c412998),
219I've determined the following behavior.
220
221Incoming: All leading zero bytes are stripped until possibly the whole packet
222is consumed (in which case it is discarded). This happens at
223toxcore/net_crypto.c:1366:handle_data_packet_core().
224
225Outgoing: The number of zeros added is:
226
227 padding_length len = (1373 - len) `mod` 8 where
228
229where /len/ is the size of the non-padded CryptoMessage. This happens at
230toxcore/net_crypto.c:936:send_data_packet_helper()
231
232The number 1373 is written in C as MAX_CRYPTO_DATA_SIZE which is defined in
233terms of the max /NetCrypto/ packet size (1400) minus the minimum possible size
234of an id-byte (1) and a /CryptoPacket Encrypted/ ( 2 + 4 + 4 + 16 ).
235
236One effect of this is that short messages will be padded to at least 5 bytes.
237-}
238
239instance Serialize CryptoData where
240 get = do
241 ack <- get
242 seqno <- get
243 cm <- getCryptoMessage ack
244 return $ CryptoData ack seqno cm
245 put (CryptoData ack seqno dta) = do
246 put ack
247 put seqno
248 putCryptoMessage ack dta
249
250data TypingStatus = NotTyping | Typing deriving (Show,Read,Eq,Ord,Enum)
251instance Serialize TypingStatus where
252 get = do
253 x <- get :: Get Word8
254 return (toEnum8 x)
255 put x = put (fromEnum8 x :: Word8)
256
257unpadCryptoMsg :: CryptoMessage -> CryptoMessage
258unpadCryptoMsg msg@(Pkt Padding :=> Identity (Padded bs)) =
259 let unpadded = B.dropWhile (== msgbyte Padding) bs
260 in either (const msg) id $ runGet (getCryptoMessage 0) unpadded
261unpadCryptoMsg msg = msg
262
263decodeRawCryptoMsg :: CryptoData -> CryptoMessage
264decodeRawCryptoMsg (CryptoData ack seqno cm) = unpadCryptoMsg cm
265
266instance Sized CryptoMessage where
267 size = VarSize $ \case
268 Pkt t :=> Identity x -> case sizeFor t of
269 ConstSize sz -> 1 + sz
270 VarSize f -> 1 + f x
271
272sizeFor :: Sized x => p x -> Size x
273sizeFor _ = size
274
275
276getCryptoMessage :: Word32 -> Get CryptoMessage
277getCryptoMessage seqno = fix $ \stripPadding -> do
278 t <- getWord8
279 case msgTag t of
280 Just (M Padding) -> stripPadding
281 Just (M msg) -> do x <- getPacket seqno
282 return $ Pkt msg ==> x
283 Nothing -> return $ Pkt MESSAGE ==> "Unhandled packet: " <> T.pack (show t) -- $ Pkt Padding ==> Padded mempty
284
285putCryptoMessage :: Word32 -> CryptoMessage -> Put
286putCryptoMessage seqno (Pkt t :=> Identity x) = do
287 putWord8 (msgbyte t)
288 putPacket seqno x
289
290
291#ifdef USE_lens
292erCompat :: String -> a
293erCompat lens = error $ "Use of '" ++ lens ++ "' lens on incompatible CryptoMessage type"
294#endif
295
296
297newtype GroupChatId = GrpId ByteString -- 33 bytes
298 deriving (Show,Eq)
299
300class HasGroupChatID x where
301 getGroupChatID :: x -> GroupChatId
302 setGroupChatID :: x -> GroupChatId -> x
303
304sizedN :: Int -> ByteString -> ByteString
305sizedN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
306 else B.take n bs
307
308sizedAtLeastN :: Int -> ByteString -> ByteString
309sizedAtLeastN n bs = if B.length bs < n then B.append bs (B.replicate (n - B.length bs) 0)
310 else bs
311
312{-
313instance HasGroupChatID CryptoMessage where
314 -- Get
315 getGroupChatID (Pkt INVITE_CONFERENCE :=> Identity payload)
316 = let (xs,ys) = B.splitAt 1 payload'
317 payload' = sizedN 38 payload
318 in case B.unpack xs of
319 [isResponse] | 0 <- isResponse -> GrpId (B.take 33 $ B.drop 2 ys) -- skip group number
320 [isResponse] | 1 <- isResponse -> GrpId (B.take 33 $ B.drop 4 ys) -- skip two group numbers
321 _ -> GrpId "" -- error "Unexpected value in INVITE_GROUPCHAT message"
322
323 getGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) = GrpId (B.take 33 $ B.drop 2 (sizedN 35 payload))
324 getGroupChatID _ = error "getGroupChatID on non-groupchat message."
325
326 -- Set
327 setGroupChatID msg@(Pkt INVITE_CONFERENCE :=> Identity payload) (GrpId newid)
328 = let (xs,ys) = B.splitAt 1 payload'
329 payload' = sizedN 38 payload
330 in case B.unpack xs of
331 [isResponse] | 0 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 2 ys), sizedN 33 newid]) -- keep group number
332 [isResponse] | 1 <- isResponse -> UpToN INVITE_GROUPCHAT (B.concat [xs, (B.take 4 ys), sizedN 33 newid]) -- keep two group numbers
333 _ -> msg -- unexpected condition, leave unchanged
334
335 setGroupChatID (Pkt ONLINE_PACKET :=> Identity payload) (GrpId newid) = Pkt ONLINE_PACKET ==> (B.concat [B.take 2 payload, sizedN 33 newid])
336 setGroupChatID _ _= error "setGroupChatID on non-groupchat message."
337-}
338
339#ifdef USE_lens
340groupChatID :: (Functor f, HasGroupChatID x) => (GroupChatId -> f GroupChatId) -> (x -> f x)
341groupChatID = lens getGroupChatID setGroupChatID
342#endif
343
344type GroupNumber = Word16
345type PeerNumber = Word16
346type MessageNumber = Word32
347
348class HasGroupNumber x where
349 getGroupNumber :: x -> GroupNumber
350 setGroupNumber :: x -> GroupNumber -> x
351
352{-
353instance HasGroupNumber CryptoMessage where
354 getGroupNumber (Pkt INVITE_CONFERENCE :=> Identity (sizedN 39 -> B.uncons -> Just (isResp,xs))) -- note isResp should be 0 or 1
355 = let twobytes = B.take 2 xs
356 Right n = S.decode twobytes
357 in n
358 getGroupNumber (UpToN (fromEnum -> x) (sizedN 2 -> twobytes)) | x >= 0x61 && x <= 0x63
359 = let Right n = S.decode twobytes in n
360 getGroupNumber (UpToN (fromEnum -> 0xC7) (sizedN 2 -> twobytes))
361 = let Right n = S.decode twobytes in n
362
363 getGroupNumber _ = error "getGroupNumber on CryptoMessage without group number field."
364
365 setGroupNumber (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (isResp,xs))) groupnum
366 = UpToN INVITE_GROUPCHAT (B.cons isResp (B.append (S.encode groupnum) (B.drop 2 xs)))
367 setGroupNumber (UpToN xE@(fromEnum -> x) (sizedAtLeastN 2 -> B.splitAt 2 -> (twobytes,xs))) groupnum
368 | x >= 0x61 && x <= 0x63 = UpToN xE (B.append (S.encode groupnum) xs)
369 | x == 0xC7 = UpToN xE (B.append (S.encode groupnum) xs)
370 setGroupNumber _ _ = error "setGroupNumber on CryptoMessage without group number field."
371-}
372
373#ifdef USE_lens
374groupNumber :: (Functor f, HasGroupNumber x) => (Word16 -> f Word16) -> (x -> f x)
375groupNumber = lens getGroupNumber setGroupNumber
376#endif
377
378class HasGroupNumberToJoin x where
379 getGroupNumberToJoin :: x -> GroupNumber
380 setGroupNumberToJoin :: x -> GroupNumber -> x
381
382{-
383instance HasGroupNumberToJoin CryptoMessage where
384 getGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) -- only response has to-join
385 = let twobytes = B.take 2 (B.drop 2 xs) -- skip group number (local)
386 Right n = S.decode twobytes
387 in n
388 getGroupNumberToJoin _ = error "getGroupNumberToJoin on CryptoMessage without group number (to join) field."
389 setGroupNumberToJoin (UpToN INVITE_GROUPCHAT (sizedN 39 -> B.uncons -> Just (1,xs))) groupnum
390 = let (a,b) = B.splitAt 2 xs
391 (twoBytes,c) = B.splitAt 2 b
392 twoBytes' = S.encode groupnum
393 in UpToN INVITE_GROUPCHAT (B.cons 1 (B.concat [a,twoBytes',c]))
394 setGroupNumberToJoin _ _ = error "setGroupNumberToJoin on CryptoMessage without group number (to join) field."
395-}
396
397#ifdef USE_lens
398groupNumberToJoin :: (Functor f, HasGroupNumberToJoin x) => (GroupNumber -> f GroupNumber) -> (x -> f x)
399groupNumberToJoin = lens getGroupNumberToJoin setGroupNumberToJoin
400#endif
401
402class HasPeerNumber x where
403 getPeerNumber :: x -> PeerNumber
404 setPeerNumber :: x -> PeerNumber -> x
405
406{-
407instance HasPeerNumber CryptoMessage where
408 getPeerNumber (UpToN (fromEnum -> 0x63) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
409 = let Right n = S.decode twobytes in n
410 getPeerNumber (UpToN (fromEnum -> 0xC7) (sizedN 4 -> B.splitAt 2 -> (grpnum,twobytes)))
411 = let Right n = S.decode twobytes in n
412 getPeerNumber _ = error "getPeerNumber on CryptoMessage without peer number field."
413
414 setPeerNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum
415 = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
416 setPeerNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 4 -> B.splitAt 2 -> (gnum,xs))) peernum
417 = UpToN xE (B.concat [gnum,S.encode peernum, B.drop 2 xs])
418 setPeerNumber _ _ = error "setPeerNumber on CryptoMessage without peer number field."
419-}
420
421#ifdef USE_lens
422peerNumber :: (Functor f, HasPeerNumber x) => (Word16 -> f Word16) -> (x -> f x)
423peerNumber = lens getPeerNumber setPeerNumber
424#endif
425
426class HasMessageNumber x where
427 getMessageNumber :: x -> MessageNumber
428 setMessageNumber :: x -> MessageNumber -> x
429
430{-
431instance HasMessageNumber CryptoMessage where
432 getMessageNumber (UpToN (fromEnum -> 0x63) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
433 = let Right n = S.decode fourbytes in n
434 getMessageNumber (UpToN (fromEnum -> 0xC7) (sizedN 8 -> B.splitAt 4 -> (_,fourbytes)))
435 = let Right n = S.decode fourbytes in n
436 getMessageNumber _ = error "getMessageNumber on CryptoMessage without message number field."
437
438 setMessageNumber (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum
439 = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
440 setMessageNumber (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 8 -> B.splitAt 4 -> (bs,xs))) messagenum
441 = UpToN xE (B.concat [bs,S.encode messagenum, B.drop 4 xs])
442 setMessageNumber _ _ = error "setMessageNumber on CryptoMessage without message number field."
443-}
444
445#ifdef USE_lens
446messageNumber :: (Functor f, HasMessageNumber x) => (Word32 -> f Word32) -> (x -> f x)
447messageNumber = lens getMessageNumber setMessageNumber
448#endif
449
450class HasMessageName x where
451 getMessageName :: x -> MessageName
452 setMessageName :: x -> MessageName -> x
453
454{-
455instance HasMessageName CryptoMessage where
456 getMessageName (UpToN (fromEnum -> 0x63) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
457 = let [n] = B.unpack onebyte
458 in toEnum . fromIntegral $ n
459 getMessageName (UpToN (fromEnum -> 0xC7) (sizedN 9 -> B.splitAt 8 -> (_,onebyte)))
460 = let [n] = B.unpack onebyte
461 in toEnum . fromIntegral $ n
462 getMessageName _ = error "getMessageName on CryptoMessage without message name field."
463
464 setMessageName (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
465 = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
466 setMessageName (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 8 -> (bs,xs))) messagename
467 = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum messagename) (B.drop 1 xs)])
468 setMessageName _ _ = error "setMessageName on CryptoMessage without message name field."
469-}
470
471#ifdef USE_lens
472messageName :: (Functor f, HasMessageName x) => (MessageName -> f MessageName) -> (x -> f x)
473messageName = lens getMessageName setMessageName
474#endif
475
476data KnownLossyness = KnownLossy | KnownLossless
477 deriving (Eq,Ord,Show,Enum)
478
479data MessageType = Msg Word8
480 | GrpMsg KnownLossyness MessageName
481 deriving (Eq,Show)
482
483class AsWord16 a where
484 toWord16 :: a -> Word16
485 fromWord16 :: Word16 -> a
486
487class AsWord64 a where
488 toWord64 :: a -> Word64
489 fromWord64 :: Word64 -> a
490
491
492fromEnum16 :: Enum a => a -> Word16
493fromEnum16 = fromIntegral . fromEnum
494
495fromEnum64 :: Enum a => a -> Word64
496fromEnum64 = fromIntegral . fromEnum
497
498
499-- MessageType, for our client keep it inside 16 bits
500-- but we should extend it to 32 or even 64 on the wire.
501-- Bits: 000000glxxxxxxxx, x = message id or extension specific, l = if extended, lossy/lossless, g = if extended, nongroup/group
502-- (at least one bit set in high byte means extended, if none but the g flag and possibly l flag, assume default grp extension)
503instance AsWord16 MessageType where
504 toWord16 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
505 toWord16 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum16 lsy) + fromIntegral (fromEnum8 msgName)
506 fromWord16 x | x < 256 = Msg (toEnum $ fromIntegral x)
507 fromWord16 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
508 fromWord16 x = error "Not clear how to convert Word16 to MessageType"
509
510instance AsWord64 MessageType where
511 toWord64 (Msg msgID) = fromIntegral (fromIntegral (fromEnum16 msgID) :: Word8)
512 toWord64 (GrpMsg lsy msgName) = 512 + 256 * (fromEnum64 lsy) + fromIntegral (fromEnum8 msgName)
513 fromWord64 x | x < 256 = Msg (toEnum $ fromIntegral x)
514 fromWord64 x | x < 1024, x .|. 0x0200 == 0x0200 = GrpMsg (toEnum8 ((x - 512) `div` 256)) (toEnum8 x)
515 fromWord64 x = error "Not clear how to convert Word64 to MessageType"
516
517#ifdef USE_lens
518word16 :: (Functor f, AsWord16 x) => (Word16 -> f Word16) -> (x -> f x)
519word16 = lens toWord16 (\_ x -> fromWord16 x)
520#endif
521
522instance Ord MessageType where
523 compare (Msg x) (Msg y) = compare x y
524 compare (GrpMsg lx x) (GrpMsg ly y) = let r1 = compare lx ly
525 in if r1==EQ then compare x y else r1
526 compare (Msg _) (GrpMsg _ _) = LT
527 compare (GrpMsg _ _) (Msg _) = GT
528
529class HasMessageType x where
530 getMessageType :: x -> MessageType
531 setMessageType :: x -> MessageType -> x
532
533{-
534instance HasMessageType CryptoMessage where
535 getMessageType (OneByte mid) = Msg mid
536 getMessageType (TwoByte mid _) = Msg mid
537 getMessageType m@(UpToN MESSAGE_GROUPCHAT _) = GrpMsg KnownLossless (getMessageName m)
538 getMessageType m@(UpToN LOSSY_GROUPCHAT _) = GrpMsg KnownLossy (getMessageName m)
539 getMessageType (UpToN mid _) = Msg mid
540
541 setMessageType (OneByte _ ) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT B.empty ) mname
542 setMessageType (TwoByte _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT (B.singleton x)) mname
543 setMessageType (OneByte _ ) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT B.empty ) mname
544 setMessageType (TwoByte _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT (B.singleton x)) mname
545 setMessageType (UpToN _ x) (GrpMsg KnownLossless mname) = setMessageName (UpToN MESSAGE_GROUPCHAT x) mname
546 setMessageType (UpToN _ x) (GrpMsg KnownLossy mname) = setMessageName (UpToN LOSSY_GROUPCHAT x) mname
547 setMessageType m (Msg mid) | Just (True,1) <- msgSizeParam mid = OneByte mid
548 setMessageType (OneByte mid0 ) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid 0
549 setMessageType (TwoByte mid0 x) (Msg mid) | Just (True,2) <- msgSizeParam mid = TwoByte mid x
550 setMessageType (UpToN mid0 x) (Msg mid) | Just (True,n) <- msgSizeParam mid = UpToN mid (sizedN n x)
551 setMessageType (OneByte mid0) (Msg mid) = UpToN mid B.empty
552 setMessageType (TwoByte mid0 x) (Msg mid) = UpToN mid (B.singleton x)
553 setMessageType (UpToN mid0 x) (Msg mid) = UpToN mid x
554-}
555
556{-
557instance HasMessageType CryptoData where
558 getMessageType (CryptoData { bufferData }) = getMessageType bufferData
559 setMessageType cd@(CryptoData { bufferData=bd }) typ = cd { bufferData=setMessageType bd typ }
560-}
561
562#ifdef USE_lens
563-- | This lens should always succeed on CryptoMessage
564messageType :: (Functor f, HasMessageType x) => (MessageType -> f MessageType) -> (x -> f x)
565messageType = lens getMessageType setMessageType
566#endif
567
568type MessageData = B.ByteString
569
570class HasMessageData x where
571 getMessageData :: x -> MessageData
572 setMessageData :: x -> MessageData -> x
573
574{-
575instance HasMessageData CryptoMessage where
576 getMessageData (UpToN (fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
577 getMessageData (UpToN (fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (_,mdata))) = mdata
578 getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x09,peerinfos)))) = peerinfos
579 -- getMessageData on 0x62:0a is equivalent to getTitle but without decoding the utf8
580 getMessageData (UpToN (fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 2 -> (_,B.uncons -> Just (0x0a,title)))) = title
581 getMessageData _ = error "getMessageData on CryptoMessage without message data field."
582
583 setMessageData (UpToN xE@(fromEnum -> 0x63) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- MESSAGE_GROUPCHAT
584 = UpToN xE (B.concat [bs,messagedata])
585 setMessageData (UpToN xE@(fromEnum -> 0xC7) (sizedAtLeastN 9 -> B.splitAt 9 -> (bs,xs))) messagedata -- LOSSY_GROUPCHAT
586 = UpToN xE (B.concat [bs,messagedata])
587 setMessageData (UpToN xE@(fromEnum -> 0x62) (sizedAtLeastN 3 -> B.splitAt 3 -> (bs,xs))) peerinfosOrTitle -- peer/title response packets
588 = UpToN xE (B.concat [bs,peerinfosOrTitle])
589 setMessageData _ _ = error "setMessageData on CryptoMessage without message data field."
590-}
591
592#ifdef USE_lens
593messageData :: (Functor f, HasMessageData x) => (MessageData -> f MessageData) -> (x -> f x)
594messageData = lens getMessageData setMessageData
595#endif
596
597class HasTitle x where
598 getTitle :: x -> Text
599 setTitle :: x -> Text -> x
600
601{-
602instance HasTitle CryptoMessage where
603 getTitle (UpToN xE bs)
604 | DIRECT_GROUPCHAT {-0x62-} <- xE,
605 (_,0x0a,mdata) <- splitByteAt 2 bs = decodeUtf8 mdata
606 | isIndirectGrpChat xE,
607 let (_,nmb,mdata) = splitByteAt 8 bs
608 nm = toEnum (fromIntegral nmb),
609 GroupchatTitleChange <- nm = decodeUtf8 mdata
610 getTitle _ = error "getTitle on CryptoMessage without title field."
611
612 setTitle (UpToN xE bs) msgdta
613 | DIRECT_GROUPCHAT {-0x62-} <- xE
614 = let (pre,_,_) = splitByteAt 2 bs
615 nm = 0x0a
616 in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
617 | isIndirectGrpChat xE
618 = let (pre,_,_) = splitByteAt 8 bs
619 nm = fromIntegral $ fromEnum GroupchatTitleChange
620 in UpToN xE (pre <> B.cons nm (encodeUtf8 msgdta))
621 setTitle _ _ = error "setTitle on CryptoMessage without title field."
622-}
623
624#ifdef USE_lens
625title :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
626title = lens getTitle setTitle
627#endif
628
629class HasMessage x where
630 getMessage :: x -> Text
631 setMessage :: x -> Text -> x
632
633splitByteAt :: Int -> ByteString -> (ByteString,Word8,ByteString)
634splitByteAt n bs = (fixed,w8,bs')
635 where
636 (fixed,B.uncons -> Just (w8,bs')) = B.splitAt n $ sizedAtLeastN (n+1) bs
637
638{-
639instance HasMessage CryptoMessage where
640 getMessage (UpToN xE bs)
641 | MESSAGE <- xE = T.decodeUtf8 bs
642 | isIndirectGrpChat xE = T.decodeUtf8 mdata where (_,_,mdata) = splitByteAt 8 bs
643 getMessage _ = error "getMessage on CryptoMessage without message field."
644
645 setMessage (UpToN xE bs) message
646 | MESSAGE <- xE
647 = UpToN xE $ T.encodeUtf8 message
648 | isIndirectGrpChat xE
649 = let (pre8,nm0,xs) = splitByteAt 8 bs
650 nm = if nm0 == 0 then 0x40 else nm0
651 prefix x = pre8 <> B.cons nm x
652 in UpToN xE $ prefix $ T.encodeUtf8 message
653 setMessage _ _ = error "setMessage on CryptoMessage without message field."
654-}
655
656#ifdef USE_lens
657message :: (Functor f, HasMessage x) => (Text -> f Text) -> (x -> f x)
658message = lens getMessage setMessage
659#endif
660
661class HasName x where
662 getName :: x -> Text
663 setName :: x -> Text -> x
664
665
666{-
667instance HasName CryptoMessage where
668 -- Only MESSAGE_GROUPCHAT:NameChange has Name field
669 getName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (_,B.uncons -> Just (toEnum . fromIntegral -> NameChange,mdata)))) | isIndirectGrpChat xE = decodeUtf8 mdata
670 getName _ = error "getName on CryptoMessage without name field."
671
672 -- If its not NameChange, this setter will set it to NameChange
673 setName (UpToN xE (sizedAtLeastN 4 -> B.splitAt 3 -> (bs,B.uncons -> Just (_,xs)))) name
674 | isIndirectGrpChat xE = UpToN xE (B.concat [bs,B.cons (fromIntegral $ fromEnum NameChange) (encodeUtf8 name)])
675 setName _ _ = error "setName on CryptoMessage without name field."
676-}
677
678#ifdef USE_lens
679name :: (Functor f, HasTitle x) => (Text -> f Text) -> (x -> f x)
680name = lens getTitle setTitle
681#endif
682
683data PeerInfo
684 = PeerInfo
685 { piPeerNum :: PeerNumber
686 , piUserKey :: PublicKey
687 , piDHTKey :: PublicKey
688 , piName :: ByteString -- byte-prefix for length
689 } deriving (Eq,Show)
690
691instance HasPeerNumber PeerInfo where
692 getPeerNumber = piPeerNum
693 setPeerNumber x n = x { piPeerNum = n }
694
695instance Serialize PeerInfo where
696 get = do
697 w16 <- get
698 ukey <- getPublicKey
699 dkey <- getPublicKey
700 w8 <- get :: Get Word8
701 PeerInfo w16 ukey dkey <$> getBytes (fromIntegral w8)
702
703 put (PeerInfo w16 ukey dkey bs) = do
704 put w16
705 putPublicKey ukey
706 putPublicKey dkey
707 let sz :: Word8
708 sz = case B.length bs of
709 n | n <= 255 -> fromIntegral n
710 | otherwise -> 255
711 put sz
712 putByteString $ B.take (fromIntegral sz) bs
713
714
715{-
716-- |
717-- default constructor, handy for formations such as:
718--
719-- > userStatus .~ Busy $ msg USERSTATUS
720--
721msg :: MessageID -> CryptoMessage
722msg mid | Just (True,0) <- msgSizeParam mid = OneByte mid
723 | Just (True,1) <- msgSizeParam mid = TwoByte mid 0
724 | Just (False,_) <- msgSizeParam mid = UpToN mid B.empty
725 | otherwise = UpToN mid B.empty
726-}
727
728{-
729leaveMsg, peerQueryMsg :: Serialize a => a -> CryptoMessage
730leaveMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x01)
731peerQueryMsg groupnum = UpToN DIRECT_GROUPCHAT (B.snoc (S.encode groupnum) 0x08)
732-}
733
734{-
735-- | Returns if the given message is of fixed(OneByte/TwoByte) size, as well as
736-- the maximum allowed size for the message Payload (message minus id)
737-- Or Nothing if unknown/unimplemented.
738msgSizeParam :: MessageID -> Maybe (Bool,Int)
739msgSizeParam ONLINE = Just (True ,0)
740msgSizeParam OFFLINE = Just (True ,0)
741msgSizeParam USERSTATUS = Just (True ,1)
742msgSizeParam TYPING = Just (True ,1)
743msgSizeParam NICKNAME = Just (False,128)
744msgSizeParam STATUSMESSAGE = Just (False,1007)
745msgSizeParam MESSAGE = Just (False,1372)
746msgSizeParam ACTION = Just (False,1372)
747msgSizeParam FILE_DATA = Just (False,1372)-- up to 1373
748msgSizeParam FILE_SENDREQUEST = Just (False,300) -- 1+1+4+8+32+max255 = up to 301
749msgSizeParam FILE_CONTROL = Just (False,7) -- 8 bytes if seek, otherwise 4
750msgSizeParam INVITE_GROUPCHAT = Just (False,38)
751msgSizeParam ONLINE_PACKET = Just (True ,35)
752msgSizeParam DIRECT_GROUPCHAT {-0x62-} = Nothing -- 1+2+1 thus Just (True,3) leave & peer-query, but variable in response packets
753msgSizeParam MESSAGE_GROUPCHAT {-0x63-} = Nothing -- variable
754msgSizeParam LOSSY_GROUPCHAT {-0xC7-} = Nothing -- variable
755msgSizeParam _ = Nothing
756-}
757
758isIndirectGrpChat :: Msg n t -> Bool
759isIndirectGrpChat MESSAGE_CONFERENCE = True
760isIndirectGrpChat LOSSY_CONFERENCE = True
761isIndirectGrpChat _ = False
762
763isKillPacket :: SomeMsg -> Bool
764isKillPacket (M KillPacket) = True
765isKillPacket _ = False
766
767isOFFLINE :: SomeMsg -> Bool
768isOFFLINE (M OFFLINE) = True
769isOFFLINE _ = False
770
771
772data MessageName = Ping -- 0x00
773 | MessageName0x01
774 | MessageName0x02
775 | MessageName0x03
776 | MessageName0x04
777 | MessageName0x05
778 | MessageName0x06
779 | MessageName0x07
780 | MessageName0x08
781 | MessageName0x09
782 | MessageName0x0a
783 | MessageName0x0b
784 | MessageName0x0c
785 | MessageName0x0d
786 | MessageName0x0e
787 | MessageName0x0f
788 | NewPeer -- 0x10
789 | KillPeer -- 0x11
790 | MessageName0x12
791 | MessageName0x13
792 | MessageName0x14
793 | MessageName0x15
794 | MessageName0x16
795 | MessageName0x17
796 | MessageName0x18
797 | MessageName0x19
798 | MessageName0x1a
799 | MessageName0x1b
800 | MessageName0x1c
801 | MessageName0x1d
802 | MessageName0x1e
803 | MessageName0x1f
804 | MessageName0x20
805 | MessageName0x21
806 | MessageName0x22
807 | MessageName0x23
808 | MessageName0x24
809 | MessageName0x25
810 | MessageName0x26
811 | MessageName0x27
812 | MessageName0x28
813 | MessageName0x29
814 | MessageName0x2a
815 | MessageName0x2b
816 | MessageName0x2c
817 | MessageName0x2d
818 | MessageName0x2e
819 | MessageName0x2f
820 | NameChange -- 0x30
821 | GroupchatTitleChange -- 0x31
822 | MessageName0x32
823 | MessageName0x33
824 | MessageName0x34
825 | MessageName0x35
826 | MessageName0x36
827 | MessageName0x37
828 | MessageName0x38
829 | MessageName0x39
830 | MessageName0x3a
831 | MessageName0x3b
832 | MessageName0x3c
833 | MessageName0x3d
834 | MessageName0x3e
835 | MessageName0x3f
836 | ChatMessage -- 0x40
837 | Action -- 0x41
838 | MessageName0x42
839 | MessageName0x43
840 | MessageName0x44
841 | MessageName0x45
842 | MessageName0x46
843 | MessageName0x47
844 | MessageName0x48
845 | MessageName0x49
846 | MessageName0x4a
847 | MessageName0x4b
848 | MessageName0x4c
849 | MessageName0x4d
850 | MessageName0x4e
851 | MessageName0x4f
852 | MessageName0x50
853 | MessageName0x51
854 | MessageName0x52
855 | MessageName0x53
856 | MessageName0x54
857 | MessageName0x55
858 | MessageName0x56
859 | MessageName0x57
860 | MessageName0x58
861 | MessageName0x59
862 | MessageName0x5a
863 | MessageName0x5b
864 | MessageName0x5c
865 | MessageName0x5d
866 | MessageName0x5e
867 | MessageName0x5f
868 | MessageName0x60
869 | MessageName0x61
870 | MessageName0x62
871 | MessageName0x63
872 | MessageName0x64
873 | MessageName0x65
874 | MessageName0x66
875 | MessageName0x67
876 | MessageName0x68
877 | MessageName0x69
878 | MessageName0x6a
879 | MessageName0x6b
880 | MessageName0x6c
881 | MessageName0x6d
882 | MessageName0x6e
883 | MessageName0x6f
884 | MessageName0x70
885 | MessageName0x71
886 | MessageName0x72
887 | MessageName0x73
888 | MessageName0x74
889 | MessageName0x75
890 | MessageName0x76
891 | MessageName0x77
892 | MessageName0x78
893 | MessageName0x79
894 | MessageName0x7a
895 | MessageName0x7b
896 | MessageName0x7c
897 | MessageName0x7d
898 | MessageName0x7e
899 | MessageName0x7f
900 | MessageName0x80
901 | MessageName0x81
902 | MessageName0x82
903 | MessageName0x83
904 | MessageName0x84
905 | MessageName0x85
906 | MessageName0x86
907 | MessageName0x87
908 | MessageName0x88
909 | MessageName0x89
910 | MessageName0x8a
911 | MessageName0x8b
912 | MessageName0x8c
913 | MessageName0x8d
914 | MessageName0x8e
915 | MessageName0x8f
916 | MessageName0x90
917 | MessageName0x91
918 | MessageName0x92
919 | MessageName0x93
920 | MessageName0x94
921 | MessageName0x95
922 | MessageName0x96
923 | MessageName0x97
924 | MessageName0x98
925 | MessageName0x99
926 | MessageName0x9a
927 | MessageName0x9b
928 | MessageName0x9c
929 | MessageName0x9d
930 | MessageName0x9e
931 | MessageName0x9f
932 | MessageName0xa0
933 | MessageName0xa1
934 | MessageName0xa2
935 | MessageName0xa3
936 | MessageName0xa4
937 | MessageName0xa5
938 | MessageName0xa6
939 | MessageName0xa7
940 | MessageName0xa8
941 | MessageName0xa9
942 | MessageName0xaa
943 | MessageName0xab
944 | MessageName0xac
945 | MessageName0xad
946 | MessageName0xae
947 | MessageName0xaf
948 | MessageName0xb0
949 | MessageName0xb1
950 | MessageName0xb2
951 | MessageName0xb3
952 | MessageName0xb4
953 | MessageName0xb5
954 | MessageName0xb6
955 | MessageName0xb7
956 | MessageName0xb8
957 | MessageName0xb9
958 | MessageName0xba
959 | MessageName0xbb
960 | MessageName0xbc
961 | MessageName0xbd
962 | MessageName0xbe
963 | MessageName0xbf
964 | MessageName0xc0
965 | MessageName0xc1
966 | MessageName0xc2
967 | MessageName0xc3
968 | MessageName0xc4
969 | MessageName0xc5
970 | MessageName0xc6
971 | MessageName0xc7
972 | MessageName0xc8
973 | MessageName0xc9
974 | MessageName0xca
975 | MessageName0xcb
976 | MessageName0xcc
977 | MessageName0xcd
978 | MessageName0xce
979 | MessageName0xcf
980 | MessageName0xd0
981 | MessageName0xd1
982 | MessageName0xd2
983 | MessageName0xd3
984 | MessageName0xd4
985 | MessageName0xd5
986 | MessageName0xd6
987 | MessageName0xd7
988 | MessageName0xd8
989 | MessageName0xd9
990 | MessageName0xda
991 | MessageName0xdb
992 | MessageName0xdc
993 | MessageName0xdd
994 | MessageName0xde
995 | MessageName0xdf
996 | MessageName0xe0
997 | MessageName0xe1
998 | MessageName0xe2
999 | MessageName0xe3
1000 | MessageName0xe4
1001 | MessageName0xe5
1002 | MessageName0xe6
1003 | MessageName0xe7
1004 | MessageName0xe8
1005 | MessageName0xe9
1006 | MessageName0xea
1007 | MessageName0xeb
1008 | MessageName0xec
1009 | MessageName0xed
1010 | MessageName0xee
1011 | MessageName0xef
1012 | MessageName0xf0
1013 | MessageName0xf1
1014 | MessageName0xf2
1015 | MessageName0xf3
1016 | MessageName0xf4
1017 | MessageName0xf5
1018 | MessageName0xf6
1019 | MessageName0xf7
1020 | MessageName0xf8
1021 | MessageName0xf9
1022 | MessageName0xfa
1023 | MessageName0xfb
1024 | MessageName0xfc
1025 | MessageName0xfd
1026 | MessageName0xfe
1027 | MessageName0xff
1028 deriving (Show,Eq,Ord,Enum,Bounded)
1029
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
deleted file mode 100644
index 1eec93b9..00000000
--- a/src/Network/Tox/DHT/Handlers.hs
+++ /dev/null
@@ -1,573 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE TupleSections #-}
6module Network.Tox.DHT.Handlers where
7
8import Debug.Trace
9import Network.Tox.DHT.Transport as DHTTransport
10import Network.QueryResponse as QR hiding (Client)
11import qualified Network.QueryResponse as QR (Client)
12import Crypto.Tox
13import Network.Kademlia.Search
14import qualified Data.Wrapper.PSQInt as Int
15import Network.Kademlia
16import Network.Kademlia.Bootstrap
17import Network.Address (WantIP (..), ipFamily, fromSockAddr, sockAddrPort)
18import qualified Network.Kademlia.Routing as R
19import Control.TriadCommittee
20import System.Global6
21import DPut
22import DebugTag
23
24import qualified Data.ByteArray as BA
25import qualified Data.ByteString.Char8 as C8
26import qualified Data.ByteString.Base16 as Base16
27import Control.Arrow
28import Control.Monad
29import Control.Concurrent.Lifted.Instrument
30import Control.Concurrent.STM
31import Data.Hashable
32import Data.Ord
33import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
34import Network.Socket
35import qualified Data.HashMap.Strict as HashMap
36 ;import Data.HashMap.Strict (HashMap)
37#if MIN_VERSION_iproute(1,7,4)
38import Data.IP hiding (fromSockAddr)
39#else
40import Data.IP
41#endif
42import Data.Maybe
43import Data.Serialize (Serialize)
44import Data.Word
45
46data TransactionId = TransactionId
47 { transactionKey :: Nonce8 -- ^ Used to lookup pending query.
48 , cryptoNonce :: Nonce24 -- ^ Used during the encryption layer.
49 }
50 deriving (Eq,Ord,Show)
51
52newtype PacketKind = PacketKind Word8
53 deriving (Eq, Ord, Serialize)
54
55pattern OnionRequest0Type = PacketKind 128 -- 0x80 Onion Request 0
56pattern OnionRequest1Type = PacketKind 129 -- 0x81 Onion Request 1
57pattern OnionRequest2Type = PacketKind 130 -- 0x82 Onion Request 2
58pattern AnnounceType = PacketKind 131 -- 0x83 Announce Request
59pattern AnnounceResponseType = PacketKind 132 -- 0x84 Announce Response
60
61pattern DataRequestType = PacketKind 133 -- 0x85 Onion Data Request (data to route request packet)
62pattern DataResponseType = PacketKind 134 -- 0x86 Onion Data Response (data to route response packet)
63-- 0x8c Onion Response 3
64-- 0x8d Onion Response 2
65pattern OnionResponse3Type = PacketKind 140 -- 0x8c Onion Response 3
66pattern OnionResponse2Type = PacketKind 141 -- 0x8d Onion Response 2
67pattern OnionResponse1Type = PacketKind 142 -- 0x8e Onion Response 1
68-- 0xf0 Bootstrap Info
69
70pattern DHTRequestType = PacketKind 32 -- 0x20 DHT Request
71
72pattern CookieRequestType = PacketKind 0x18
73pattern CookieResponseType = PacketKind 0x19
74
75pattern PingType = PacketKind 0 -- 0x00 Ping Request
76pattern PongType = PacketKind 1 -- 0x01 Ping Response
77pattern GetNodesType = PacketKind 2 -- 0x02 Nodes Request
78pattern SendNodesType = PacketKind 4 -- 0x04 Nodes Response
79
80
81instance Show PacketKind where
82 showsPrec d PingType = mappend "PingType"
83 showsPrec d PongType = mappend "PongType"
84 showsPrec d GetNodesType = mappend "GetNodesType"
85 showsPrec d SendNodesType = mappend "SendNodesType"
86 showsPrec d DHTRequestType = mappend "DHTRequestType"
87 showsPrec d OnionRequest0Type = mappend "OnionRequest0Type"
88 showsPrec d OnionResponse1Type = mappend "OnionResponse1Type"
89 showsPrec d OnionResponse3Type = mappend "OnionResponse3Type"
90 showsPrec d AnnounceType = mappend "AnnounceType"
91 showsPrec d AnnounceResponseType = mappend "AnnounceResponseType"
92 showsPrec d DataRequestType = mappend "DataRequestType"
93 showsPrec d DataResponseType = mappend "DataResponseType"
94 showsPrec d CookieRequestType = mappend "CookieRequestType"
95 showsPrec d CookieResponseType = mappend "CookieResponseType"
96 showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
97
98msgType :: ( Serialize (f DHTRequest)
99 , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
100 , Serialize (f SendNodes), Serialize (f GetNodes)
101 , Serialize (f Pong), Serialize (f Ping)
102 ) => DHTMessage f -> PacketKind
103msgType msg = PacketKind $ fst $ dhtMessageType msg
104
105classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message
106classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client)
107classify client msg = fromMaybe (IsUnknown "unknown")
108 $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg
109 where
110 go (DHTPing {}) = IsQuery PingType
111 go (DHTGetNodes {}) = IsQuery GetNodesType
112 go (DHTPong {}) = IsResponse
113 go (DHTSendNodes {}) = IsResponse
114 go (DHTCookieRequest {}) = IsQuery CookieRequestType
115 go (DHTCookie {}) = IsResponse
116 go (DHTDHTRequest {}) = IsQuery DHTRequestType
117
118data NodeInfoCallback = NodeInfoCallback
119 { interestingNodeId :: NodeId
120 , listenerId :: Int
121 , observedAddress :: POSIXTime -> NodeInfo -- Address and port for interestingNodeId
122 -> STM ()
123 , rumoredAddress :: POSIXTime -> SockAddr -- source of information
124 -> NodeInfo -- Address and port for interestingNodeId
125 -> STM ()
126 }
127
128data Routing = Routing
129 { tentativeId :: NodeInfo
130 , committee4 :: TriadCommittee NodeId SockAddr
131 , committee6 :: TriadCommittee NodeId SockAddr
132 , refresher4 :: BucketRefresher NodeId NodeInfo
133 , refresher6 :: BucketRefresher NodeId NodeInfo
134 , nodesOfInterest :: TVar (HashMap NodeId [NodeInfoCallback])
135 }
136
137registerNodeCallback :: Routing -> NodeInfoCallback -> STM ()
138registerNodeCallback Routing{nodesOfInterest} cb = do
139 cbm <- readTVar nodesOfInterest
140 let ns = fromMaybe [] $ HashMap.lookup (interestingNodeId cb) cbm
141 bs = filter nonMatching ns
142 where nonMatching n = (listenerId n /= listenerId cb)
143 writeTVar nodesOfInterest $ HashMap.insert (interestingNodeId cb)
144 (cb : bs)
145 cbm
146
147unregisterNodeCallback :: Int -> Routing -> NodeId -> STM ()
148unregisterNodeCallback callbackId Routing{nodesOfInterest} nid = do
149 cbm <- readTVar nodesOfInterest
150 let ns = fromMaybe [] $ HashMap.lookup nid cbm
151 bs = filter nonMatching ns
152 where nonMatching n = (listenerId n /= callbackId)
153 writeTVar nodesOfInterest
154 $ if null bs
155 then HashMap.delete nid cbm
156 else HashMap.insert nid bs cbm
157
158
159sched4 :: Routing -> TVar (Int.PSQ POSIXTime)
160sched4 Routing { refresher4 = BucketRefresher { refreshQueue } } = refreshQueue
161
162sched6 :: Routing -> TVar (Int.PSQ POSIXTime)
163sched6 Routing { refresher6 = BucketRefresher { refreshQueue } } = refreshQueue
164
165routing4 :: Routing -> TVar (R.BucketList NodeInfo)
166routing4 Routing { refresher4 = BucketRefresher { refreshBuckets } } = refreshBuckets
167
168routing6 :: Routing -> TVar (R.BucketList NodeInfo)
169routing6 Routing { refresher6 = BucketRefresher { refreshBuckets } } = refreshBuckets
170
171newRouting :: SockAddr -> TransportCrypto
172 -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv4 change
173 -> (TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()) -- ^ invoked on IPv6 change
174 -> IO (Client -> Routing)
175newRouting addr crypto update4 update6 = do
176 let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr)
177 tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr)
178 tentative_info = NodeInfo
179 { nodeId = key2id $ transportPublic crypto
180 , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr)
181 , nodePort = fromMaybe 0 $ sockAddrPort addr
182 }
183 tentative_info4 = tentative_info { nodeIP = tentative_ip4 }
184 tentative_info6 <-
185 maybe (tentative_info { nodeIP = tentative_ip6 })
186 (\ip6 -> tentative_info { nodeIP = IPv6 ip6 })
187 <$> case addr of
188 SockAddrInet {} -> return Nothing
189 _ -> global6
190 atomically $ do
191 -- We defer initializing the refreshSearch and refreshPing until we
192 -- have a client to send queries with.
193 let nullPing = const $ return False
194 nullSearch = Search
195 { searchSpace = toxSpace
196 , searchNodeAddress = nodeIP &&& nodePort
197 , searchQuery = Left $ \_ _ -> return Nothing
198 , searchAlpha = 1
199 , searchK = 2
200 }
201 tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 R.defaultBucketCount
202 tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 R.defaultBucketCount
203 refresher4 <- newBucketRefresher tbl4 nullSearch nullPing
204 refresher6 <- newBucketRefresher tbl6 nullSearch nullPing
205 committee4 <- newTriadCommittee (update4 tbl4) -- updateIPVote tbl4 addr4
206 committee6 <- newTriadCommittee (update6 tbl6) -- updateIPVote tbl6 addr6
207 cbvar <- newTVar HashMap.empty
208 return $ \client ->
209 -- Now we have a client, so tell the BucketRefresher how to search and ping.
210 let updIO r = updateRefresherIO (nodeSearch client cbvar) (ping client) r
211 in Routing { tentativeId = tentative_info
212 , committee4 = committee4
213 , committee6 = committee6
214 , refresher4 = updIO refresher4
215 , refresher6 = updIO refresher6
216 , nodesOfInterest = cbvar
217 }
218
219
220-- TODO: This should cover more cases
221isLocal :: IP -> Bool
222isLocal (IPv6 ip6) = (ip6 == toEnum 0)
223isLocal (IPv4 ip4) = (ip4 == toEnum 0)
224
225isGlobal :: IP -> Bool
226isGlobal = not . isLocal
227
228prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
229prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
230
231toxSpace :: R.KademliaSpace NodeId NodeInfo
232toxSpace = R.KademliaSpace
233 { R.kademliaLocation = nodeId
234 , R.kademliaTestBit = testNodeIdBit
235 , R.kademliaXor = xorNodeId
236 , R.kademliaSample = sampleNodeId
237 }
238
239
240pingH :: NodeInfo -> Ping -> IO Pong
241pingH _ Ping = return Pong
242
243getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
244getNodesH routing addr (GetNodes nid) = do
245 let preferred = prefer4or6 addr Nothing
246
247 (append4,append6) <- atomically $ do
248 ni4 <- R.thisNode <$> readTVar (routing4 routing)
249 ni6 <- R.thisNode <$> readTVar (routing6 routing)
250 return $ case ipFamily (nodeIP addr) of
251 Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
252 Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
253 _ -> (id, id)
254 ks <- go append4 $ routing4 routing
255 ks6 <- go append6 $ routing6 routing
256 let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
257 Want_IP4 -> (ks,ks6)
258 Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
259 return $ SendNodes
260 $ if null ns2 then ns1
261 else take 4 (take 3 ns1 ++ ns2)
262 where
263 go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var)
264
265 k = 4
266
267createCookie :: TransportCrypto -> NodeInfo -> PublicKey -> IO (Cookie Encrypted)
268createCookie crypto ni remoteUserKey = do
269 (n24,sym) <- atomically $ do
270 n24 <- transportNewNonce crypto
271 sym <- transportSymmetric crypto
272 return (n24,sym)
273 timestamp <- round . (* 1000000) <$> getPOSIXTime
274 let dta = encodePlain $ CookieData
275 { cookieTime = timestamp
276 , longTermKey = remoteUserKey
277 , dhtKey = id2key $ nodeId ni -- transportPublic crypto
278 }
279 edta = encryptSymmetric sym n24 dta
280 return $ Cookie n24 edta
281
282createCookieSTM :: POSIXTime -> TransportCrypto -> NodeInfo -> PublicKey -> STM (Cookie Encrypted)
283createCookieSTM now crypto ni remoteUserKey = do
284 let dmsg msg = trace msg (return ())
285 (n24,sym) <- do
286 n24 <- transportNewNonce crypto
287 sym <- transportSymmetric crypto
288 return (n24,sym)
289 let timestamp = round (now * 1000000)
290 let dta = encodePlain $ CookieData
291 { cookieTime = timestamp
292 , longTermKey = remoteUserKey
293 , dhtKey = id2key $ nodeId ni -- transportPublic crypto
294 }
295 edta = encryptSymmetric sym n24 dta
296 return $ Cookie n24 edta
297
298cookieRequestH :: TransportCrypto -> NodeInfo -> CookieRequest -> IO (Cookie Encrypted)
299cookieRequestH crypto ni (CookieRequest remoteUserKey) = do
300 dput XNetCrypto $ unlines
301 [ show (nodeAddr ni) ++ " --> request cookie: remoteUserKey=" ++ show (key2id remoteUserKey)
302 , show (nodeAddr ni) ++ " --> sender=" ++ show (nodeId ni) ]
303 x <- createCookie crypto ni remoteUserKey
304 dput XNetCrypto $ show (nodeAddr ni) ++ " <-- cookie " ++ show (key2id remoteUserKey)
305 return x
306
307lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message))
308lanDiscoveryH client _ ni = do
309 dput XLan $ show (nodeAddr ni) ++ " --> LanAnnounce " ++ show (nodeId ni)
310 forkIO $ do
311 myThreadId >>= flip labelThread "lan-discover-ping"
312 ping client ni
313 return ()
314 return Nothing
315
316type Message = DHTMessage ((,) Nonce8)
317
318type Client = QR.Client String PacketKind TransactionId NodeInfo Message
319
320
321wrapAsymm :: TransactionId -> NodeInfo -> NodeInfo -> (Nonce8 -> dta) -> Asymm dta
322wrapAsymm (TransactionId n8 n24) src dst dta = Asymm
323 { senderKey = id2key $ nodeId src
324 , asymmNonce = n24
325 , asymmData = dta n8
326 }
327
328serializer :: PacketKind
329 -> (Asymm (Nonce8,ping) -> Message)
330 -> (Message -> Maybe (Asymm (Nonce8,pong)))
331 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
332serializer pktkind mkping mkpong = MethodSerializer
333 { methodTimeout = \tid addr -> return (addr, 5000000)
334 , method = pktkind
335 -- wrapQuery :: tid -> addr -> addr -> qry -> x
336 , wrapQuery = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping)
337 -- unwrapResponse :: x -> b
338 , unwrapResponse = fmap (snd . asymmData) . mkpong
339 }
340
341
342unpong :: Message -> Maybe (Asymm (Nonce8,Pong))
343unpong (DHTPong asymm) = Just asymm
344unpong _ = Nothing
345
346ping :: Client -> NodeInfo -> IO Bool
347ping client addr = do
348 dput XPing $ show addr ++ " <-- ping"
349 reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
350 dput XPing $ show addr ++ " -pong-> " ++ show reply
351 maybe (return False) (\Pong -> return True) $ join reply
352
353
354saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
355saveCookieKey var saddr pk = do
356 cookiekeys <- readTVar var
357 case break (\(stored,_) -> stored == saddr) cookiekeys of
358 (xs,[]) -> writeTVar var $ (saddr, (1 ,pk)) : xs
359 (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c+1,pk)) : xs ++ ys
360 _ -> retry -- Wait for requests to this address
361 -- under a different key to time out
362 -- before we try this key.
363
364loseCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
365loseCookieKey var saddr pk = do
366 cookiekeys <- readTVar var
367 case break (\(stored,_) -> stored == saddr) cookiekeys of
368 (xs,(_,(1,stored)):ys) | stored == pk -> writeTVar var $ xs ++ ys
369 (xs,(_,(c,stored)):ys) | stored == pk -> writeTVar var $ (saddr, (c-1,pk)) : xs ++ ys
370 _ -> return () -- unreachable?
371
372
373cookieRequest :: TransportCrypto -> Client -> PublicKey -> NodeInfo -> IO (Maybe (Cookie Encrypted))
374cookieRequest crypto client localUserKey addr = do
375 let sockAddr = nodeAddr addr
376 nid = id2key $ nodeId addr
377 cookieSerializer
378 = MethodSerializer
379 { methodTimeout = \tid addr -> return (addr, 5000000)
380 , method = CookieRequestType
381 , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
382 , unwrapResponse = fmap snd . unCookie
383 }
384 cookieRequest = CookieRequest localUserKey
385 atomically $ saveCookieKey (pendingCookies crypto) sockAddr nid
386 dput XNetCrypto $ show addr ++ " <-- cookieRequest"
387 reply <- QR.sendQuery client cookieSerializer cookieRequest addr
388 atomically $ loseCookieKey (pendingCookies crypto) sockAddr nid
389 dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply
390 return $ join reply
391
392unCookie :: DHTMessage t -> Maybe (t (Cookie Encrypted))
393unCookie (DHTCookie n24 fcookie) = Just fcookie
394unCookie _ = Nothing
395
396unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
397unsendNodes (DHTSendNodes asymm) = Just asymm
398unsendNodes _ = Nothing
399
400unwrapNodes :: SendNodes -> ( [NodeInfo], [NodeInfo], Maybe () )
401unwrapNodes (SendNodes ns) = (ns,ns,Just ())
402
403data SendableQuery x a b = SendableQuery
404 { sendableSerializer :: MethodSerializer TransactionId NodeInfo Message PacketKind a (Maybe x)
405 , sendableQuery :: NodeId -> a
406 , sendableResult :: Maybe (Maybe x) -> IO b
407 }
408
409sendQ :: SendableQuery x a b
410 -> QR.Client err PacketKind TransactionId NodeInfo Message
411 -> NodeId
412 -> NodeInfo
413 -> IO b
414sendQ s client nid addr = do
415 reply <- QR.sendQuery client (sendableSerializer s) (sendableQuery s nid) addr
416 sendableResult s reply
417
418asyncQ :: SendableQuery x a b
419 -> QR.Client err PacketKind TransactionId NodeInfo Message
420 -> NodeId
421 -> NodeInfo
422 -> (b -> IO ())
423 -> IO ()
424asyncQ s client nid addr go = do
425 QR.asyncQuery client (sendableSerializer s) (sendableQuery s nid) addr
426 $ sendableResult s >=> go
427
428getNodesSendable :: TVar (HashMap NodeId [NodeInfoCallback])
429 -> NodeInfo
430 -> SendableQuery SendNodes GetNodes (Maybe ([NodeInfo], [NodeInfo], Maybe ()))
431getNodesSendable cbvar addr = SendableQuery (serializer GetNodesType DHTGetNodes unsendNodes)
432 GetNodes
433 go
434 where
435 go reply = do
436 forM_ (join reply) $ \(SendNodes ns) ->
437 forM_ ns $ \n -> do
438 now <- getPOSIXTime
439 atomically $ do
440 mcbs <- HashMap.lookup (nodeId n) <$> readTVar cbvar
441 forM_ mcbs $ \cbs -> do
442 forM_ cbs $ \cb -> do
443 rumoredAddress cb now (nodeAddr addr) n
444 return $ fmap unwrapNodes $ join reply
445
446getNodes :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
447getNodes client cbvar nid addr =
448 sendQ (getNodesSendable cbvar addr) client nid addr
449
450asyncGetNodes :: QR.Client err PacketKind TransactionId NodeInfo Message
451 -> TVar (HashMap NodeId [NodeInfoCallback])
452 -> NodeId
453 -> NodeInfo
454 -> (Maybe ([NodeInfo], [NodeInfo], Maybe ()) -> IO ())
455 -> IO ()
456asyncGetNodes client cbvar nid addr go =
457 asyncQ (getNodesSendable cbvar addr) client nid addr go
458
459updateRouting :: Client -> Routing
460 -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
461 -> NodeInfo
462 -> Message
463 -> IO ()
464updateRouting client routing orouter naddr msg
465 | PacketKind 0x21 <- msgType msg = -- dput XLan "(tox)updateRouting: ignoring lan discovery" -- ignore lan discovery
466 -- Ignore lan announcements until they reply to our ping.
467 -- We do this because the lan announce is not authenticated.
468 return ()
469 | otherwise = do
470 now <- getPOSIXTime
471 atomically $ do
472 m <- HashMap.lookup (nodeId naddr) <$> readTVar (nodesOfInterest routing)
473 forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do
474 when (interestingNodeId == nodeId naddr)
475 $ observedAddress now naddr
476 case prefer4or6 naddr Nothing of
477 Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
478 Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing)
479 Want_Both -> do dput XMisc "BUG:unreachable"
480 error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
481
482updateTable :: Client -> NodeInfo
483 -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
484 -> TriadCommittee NodeId SockAddr
485 -> BucketRefresher NodeId NodeInfo
486 -> IO ()
487updateTable client naddr orouter committee refresher = do
488 self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
489 -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr)
490 when (self /= naddr) $ do
491 -- TODO: IP address vote?
492 insertNode (toxKademlia client committee orouter refresher) naddr
493
494toxKademlia :: Client
495 -> TriadCommittee NodeId SockAddr
496 -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
497 -> BucketRefresher NodeId NodeInfo
498 -> Kademlia NodeId NodeInfo
499toxKademlia client committee orouter refresher
500 = Kademlia quietInsertions
501 toxSpace
502 (vanillaIO (refreshBuckets refresher) $ ping client)
503 { tblTransition = \tr -> do
504 io1 <- transitionCommittee committee tr
505 io2 <- touchBucket refresher tr -- toxSpace (15*60) var sched tr
506 -- hookBucketList toxSpace (refreshBuckets refresher) orouter tr
507 orouter (refreshBuckets refresher) tr
508 return $ do
509 io1 >> io2
510 {-
511 dput XMisc $ unwords
512 [ show (transitionedTo tr)
513 , show (transitioningNode tr)
514 ]
515 -}
516 return ()
517 }
518
519transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
520transitionCommittee committee (RoutingTransition ni Stranger) = do
521 delVote committee (nodeId ni)
522 return $ do
523 -- dput XMisc $ "delVote "++show (nodeId ni)
524 return ()
525transitionCommittee committee _ = return $ return ()
526
527type Handler = MethodHandler String TransactionId NodeInfo Message
528
529isPing :: (f Ping -> Ping) -> DHTMessage f -> Either String Ping
530isPing unpack (DHTPing a) = Right $ unpack $ asymmData a
531isPing _ _ = Left "Bad ping"
532
533mkPong :: TransactionId -> NodeInfo -> NodeInfo -> Pong -> DHTMessage ((,) Nonce8)
534mkPong tid src dst pong = DHTPong $ wrapAsymm tid src dst (, pong)
535
536isGetNodes :: (f GetNodes -> GetNodes) -> DHTMessage f -> Either String GetNodes
537isGetNodes unpack (DHTGetNodes a) = Right $ unpack $ asymmData a
538isGetNodes _ _ = Left "Bad GetNodes"
539
540mkSendNodes :: TransactionId -> NodeInfo -> NodeInfo -> SendNodes -> DHTMessage ((,) Nonce8)
541mkSendNodes tid src dst sendnodes = DHTSendNodes $ wrapAsymm tid src dst (, sendnodes)
542
543isCookieRequest :: (f CookieRequest -> CookieRequest) -> DHTMessage f -> Either String CookieRequest
544isCookieRequest unpack (DHTCookieRequest a) = Right $ unpack $ asymmData a
545isCookieRequest _ _ = Left "Bad cookie request"
546
547mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie Encrypted -> DHTMessage ((,) Nonce8)
548mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie)
549
550isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest
551isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a
552isDHTRequest _ _ = Left "Bad dht relay request"
553
554dhtRequestH :: NodeInfo -> DHTRequest -> IO ()
555dhtRequestH ni req = do
556 dput XMisc $ "Unhandled DHT Request: " ++ show req
557
558handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
559handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH
560handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing
561handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto
562handlers _ _ DHTRequestType = Just $ NoReply (isDHTRequest snd) $ dhtRequestH
563handlers _ _ typ = error $ "TODO DHT handlers " ++ show typ
564
565nodeSearch :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
566nodeSearch client cbvar = Search
567 { searchSpace = toxSpace
568 , searchNodeAddress = nodeIP &&& nodePort
569 , searchQuery = Right $ asyncGetNodes client cbvar
570 , searchAlpha = 8
571 , searchK = 16
572
573 }
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
deleted file mode 100644
index b9b63165..00000000
--- a/src/Network/Tox/DHT/Transport.hs
+++ /dev/null
@@ -1,460 +0,0 @@
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
12module Network.Tox.DHT.Transport
13 ( parseDHTAddr
14 , encodeDHTAddr
15 , forwardDHTRequests
16 , module Network.Tox.NodeId
17 , DHTMessage(..)
18 , Ping(..)
19 , Pong(..)
20 , GetNodes(..)
21 , SendNodes(..)
22 , DHTPublicKey(..)
23 , FriendRequest(..)
24 , NoSpam(..)
25 , CookieRequest(..)
26 , CookieResponse(..)
27 , Cookie(..)
28 , CookieData(..)
29 , DHTRequest
30 , mapMessage
31 , encrypt
32 , decrypt
33 , dhtMessageType
34 , asymNodeInfo
35 , putMessage -- Convenient for serializing DHTLanDiscovery
36 ) where
37
38import Network.Tox.NodeId
39import Crypto.Tox hiding (encrypt,decrypt)
40import qualified Crypto.Tox as ToxCrypto
41import Network.QueryResponse
42
43import Control.Applicative
44import Control.Arrow
45import Control.Concurrent.STM
46import Control.Monad
47import Data.Bool
48import qualified Data.ByteString as B
49 ;import Data.ByteString (ByteString)
50import Data.Functor.Contravariant
51import Data.Hashable
52import Data.Maybe
53import Data.Monoid
54import Data.Serialize as S
55import Data.Tuple
56import Data.Word
57import GHC.Generics
58import Network.Socket
59
60type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
61type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
62
63
64data DHTMessage (f :: * -> *)
65 = DHTPing (Asymm (f Ping))
66 | DHTPong (Asymm (f Pong))
67 | DHTGetNodes (Asymm (f GetNodes))
68 | DHTSendNodes (Asymm (f SendNodes))
69 | DHTCookieRequest (Asymm (f CookieRequest))
70 | DHTCookie Nonce24 (f (Cookie Encrypted))
71 | DHTDHTRequest PublicKey (Asymm (f DHTRequest))
72 | DHTLanDiscovery NodeId
73
74deriving instance ( Show (f (Cookie Encrypted))
75 , Show (f Ping)
76 , Show (f Pong)
77 , Show (f GetNodes)
78 , Show (f SendNodes)
79 , Show (f CookieRequest)
80 , Show (f DHTRequest)
81 ) => Show (DHTMessage f)
82
83mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b
84mapMessage f (DHTPing a) = Just $ f (asymmNonce a) (asymmData a)
85mapMessage f (DHTPong a) = Just $ f (asymmNonce a) (asymmData a)
86mapMessage f (DHTGetNodes a) = Just $ f (asymmNonce a) (asymmData a)
87mapMessage f (DHTSendNodes a) = Just $ f (asymmNonce a) (asymmData a)
88mapMessage f (DHTCookieRequest a) = Just $ f (asymmNonce a) (asymmData a)
89mapMessage f (DHTDHTRequest _ a) = Just $ f (asymmNonce a) (asymmData a)
90mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie
91mapMessage f (DHTLanDiscovery nid) = Nothing
92
93
94instance Sized Ping where size = ConstSize 1
95instance Sized Pong where size = ConstSize 1
96
97parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr))
98parseDHTAddr crypto (msg,saddr)
99 | Just (typ,bs) <- B.uncons msg
100 , let right = return $ Right (msg,saddr)
101 left = either (const right) (return . Left)
102 = case typ of
103 0x00 -> left $ direct bs saddr DHTPing
104 0x01 -> left $ direct bs saddr DHTPong
105 0x02 -> left $ direct bs saddr DHTGetNodes
106 0x04 -> left $ direct bs saddr DHTSendNodes
107 0x18 -> left $ direct bs saddr DHTCookieRequest
108 0x19 -> do
109 cs <- atomically $ readTVar (pendingCookies crypto)
110 let ni = fromMaybe (noReplyAddr saddr) $ do
111 (cnt,key) <- lookup saddr cs <|> listToMaybe (map snd cs)
112 either (const Nothing) Just $ nodeInfo (key2id key) saddr
113 left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni)
114 0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
115 0x21 -> left $ do
116 nid <- runGet get bs
117 ni <- nodeInfo nid saddr
118 return (DHTLanDiscovery nid, ni)
119 _ -> right
120
121encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr)
122encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni)
123
124dhtMessageType :: ( Serialize (f DHTRequest)
125 , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
126 , Serialize (f SendNodes), Serialize (f GetNodes)
127 , Serialize (f Pong), Serialize (f Ping)
128 ) => DHTMessage f -> (Word8, Put)
129dhtMessageType (DHTPing a) = (0x00, putAsymm a)
130dhtMessageType (DHTPong a) = (0x01, putAsymm a)
131dhtMessageType (DHTGetNodes a) = (0x02, putAsymm a)
132dhtMessageType (DHTSendNodes a) = (0x04, putAsymm a)
133dhtMessageType (DHTCookieRequest a) = (0x18, putAsymm a)
134dhtMessageType (DHTCookie n x) = (0x19, put n >> put x)
135dhtMessageType (DHTDHTRequest k a) = (0x20, putPublicKey k >> putAsymm a)
136dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid)
137
138putMessage :: DHTMessage Encrypted8 -> Put
139putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p
140
141getCookie :: Get (Nonce24, Encrypted8 (Cookie Encrypted))
142getCookie = get
143
144getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest))
145getDHTReqest = (,) <$> getPublicKey <*> getAsymm
146
147-- ## DHT Request packets
148--
149-- | Length | Contents |
150-- |:-------|:--------------------------|
151-- | `1` | `uint8_t` (0x20) |
152-- | `32` | receiver's DHT public key |
153-- ... ...
154
155
156getDHT :: Sized a => Get (Asymm (Encrypted8 a))
157getDHT = getAsymm
158
159
160-- Throws an error if called with a non-internet socket.
161direct :: Sized a => ByteString
162 -> SockAddr
163 -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8)
164 -> Either String (DHTMessage Encrypted8, NodeInfo)
165direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
166
167-- Throws an error if called with a non-internet socket.
168asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo
169asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr
170
171
172fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
173fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
174
175-- Throws an error if called with a non-internet socket.
176noReplyAddr :: SockAddr -> NodeInfo
177noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
178
179
180data DHTRequest
181 -- #### NAT ping request
182 --
183 -- Length Contents
184 -- :------- :-------------------------
185 -- `1` `uint8_t` (0xfe)
186 -- `1` `uint8_t` (0x00)
187 -- `8` `uint64_t` random number
188 = NATPing Nonce8
189 -- #### NAT ping response
190 --
191 -- Length Contents
192 -- :------- :-----------------------------------------------------------------
193 -- `1` `uint8_t` (0xfe)
194 -- `1` `uint8_t` (0x01)
195 -- `8` `uint64_t` random number (the same that was received in request)
196 | NATPong Nonce8
197 | DHTPK LongTermKeyWrap
198 -- From docs/Hardening_docs.txt
199 --
200 -- All hardening requests must contain exactly 384 bytes of data. (The data sent
201 -- must be padded with zeros if it is smaller than that.)
202 --
203 -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to
204 -- test.)][client_id(32 bytes) the id to query the node with.][padding]
205 --
206 -- packet id: CRYPTO_PACKET_HARDENING (48)
207 | Hardening -- TODO
208 deriving Show
209
210instance Sized DHTRequest where
211 size = VarSize $ \case
212 NATPing _ -> 10
213 NATPong _ -> 10
214 DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-}
215 + case size of
216 ConstSize n -> n
217 VarSize f -> f (wrapData wrap)
218 Hardening -> 1{-typ-} + 384
219
220instance Serialize DHTRequest where
221 get = do
222 tag <- get
223 case tag :: Word8 of
224 0xfe -> do
225 direction <- get
226 bool NATPong NATPing (direction==(0::Word8)) <$> get
227 0x9c -> DHTPK <$> get
228 0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING
229 _ -> fail ("unrecognized DHT request: "++show tag)
230 put (NATPing n) = put (0xfe00 :: Word16) >> put n
231 put (NATPong n) = put (0xfe01 :: Word16) >> put n
232 put (DHTPK pk) = put (0x9c :: Word8) >> put pk
233 put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO
234
235-- DHT public key packet:
236-- (As Onion data packet?)
237--
238-- | Length | Contents |
239-- |:------------|:------------------------------------|
240-- | `1` | `uint8_t` (0x9c) |
241-- | `8` | `uint64_t` `no_replay` |
242-- | `32` | Our DHT public key |
243-- | `[39, 204]` | Maximum of 4 nodes in packed format |
244data DHTPublicKey = DHTPublicKey
245 { dhtpkNonce :: Word64 -- ^ The `no_replay` number is protection if
246 -- someone tries to replay an older packet and
247 -- should be set to an always increasing number.
248 -- It is 8 bytes so you should set a high
249 -- resolution monotonic time as the value.
250 , dhtpk :: PublicKey -- dht public key
251 , dhtpkNodes :: SendNodes -- other reachable nodes
252 }
253 deriving (Eq, Show)
254
255
256-- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto)
257-- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes]
258data FriendRequest = FriendRequest
259 { friendNoSpam :: Word32
260 , friendRequestText :: ByteString -- UTF8
261 }
262 deriving (Eq, Ord, Show)
263
264
265-- When sent as a DHT request packet (this is the data sent in the DHT request
266-- packet):
267--
268-- Length Contents
269-- :--------- :-------------------------------
270-- `1` `uint8_t` (0x9c)
271-- `32` Long term public key of sender
272-- `24` Nonce
273-- variable Encrypted payload
274data LongTermKeyWrap = LongTermKeyWrap
275 { wrapLongTermKey :: PublicKey
276 , wrapNonce :: Nonce24
277 , wrapData :: Encrypted DHTPublicKey
278 }
279 deriving Show
280
281instance Serialize LongTermKeyWrap where
282 get = LongTermKeyWrap <$> getPublicKey <*> get <*> get
283 put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta
284
285
286instance Sized DHTPublicKey where
287 -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size.
288 -- WARNING: Serialize instance does not include this byte FIXME
289 size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of
290 ConstSize nodes -> nodes
291 VarSize sznodes -> sznodes nodes
292
293instance Sized Word32 where size = ConstSize 4
294
295-- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte
296-- where the DHTPublicKey type does include its tag.
297instance Sized FriendRequest where
298 size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length)
299
300instance Serialize DHTPublicKey where
301 -- TODO: This should agree with Sized instance.
302 get = DHTPublicKey <$> get <*> getPublicKey <*> get
303 put (DHTPublicKey nonce key nodes) = do
304 put nonce
305 putPublicKey key
306 put nodes
307
308instance Serialize FriendRequest where
309 get = FriendRequest <$> get <*> (remaining >>= getBytes)
310 put (FriendRequest nospam txt) = put nospam >> putByteString txt
311
312newtype GetNodes = GetNodes NodeId
313 deriving (Eq,Ord,Show,Read,S.Serialize)
314
315instance Sized GetNodes where
316 size = ConstSize 32 -- TODO This right?
317
318newtype SendNodes = SendNodes [NodeInfo]
319 deriving (Eq,Ord,Show,Read)
320
321instance Sized SendNodes where
322 size = VarSize $ \(SendNodes ns) -> case size of
323 ConstSize nodeFormatSize -> nodeFormatSize * length ns
324 VarSize nsize -> sum $ map nsize ns
325
326instance S.Serialize SendNodes where
327 get = do
328 cnt <- S.get :: S.Get Word8
329 ns <- sequence $ replicate (fromIntegral cnt) S.get
330 return $ SendNodes ns
331
332 put (SendNodes ns) = do
333 let ns' = take 4 ns
334 S.put (fromIntegral (length ns') :: Word8)
335 mapM_ S.put ns'
336
337data Ping = Ping deriving Show
338data Pong = Pong deriving Show
339
340instance S.Serialize Ping where
341 get = do w8 <- S.get
342 if (w8 :: Word8) /= 0
343 then fail "Malformed ping."
344 else return Ping
345 put Ping = S.put (0 :: Word8)
346
347instance S.Serialize Pong where
348 get = do w8 <- S.get
349 if (w8 :: Word8) /= 1
350 then fail "Malformed pong."
351 else return Pong
352 put Pong = S.put (1 :: Word8)
353
354newtype CookieRequest = CookieRequest PublicKey
355 deriving (Eq, Show)
356newtype CookieResponse = CookieResponse (Cookie Encrypted)
357 deriving (Eq, Show)
358
359data Cookie (f :: * -> *) = Cookie Nonce24 (f CookieData)
360
361deriving instance Eq (f CookieData) => Eq (Cookie f)
362deriving instance Ord (f CookieData) => Ord (Cookie f)
363deriving instance Show (f CookieData) => Show (Cookie f)
364deriving instance Generic (f CookieData) => Generic (Cookie f)
365
366instance Hashable (Cookie Encrypted)
367
368instance Sized (Cookie Encrypted) where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
369
370instance Serialize (Cookie Encrypted) where
371 get = Cookie <$> get <*> get
372 put (Cookie nonce dta) = put nonce >> put dta
373
374data CookieData = CookieData -- 16 (mac)
375 { cookieTime :: Word64 -- 8
376 , longTermKey :: PublicKey -- 32
377 , dhtKey :: PublicKey -- + 32
378 } -- = 88 bytes when encrypted.
379 deriving (Show, Generic)
380
381instance Sized CookieData where
382 size = ConstSize 72
383
384instance Serialize CookieData where
385 get = CookieData <$> get <*> getPublicKey <*> getPublicKey
386 put (CookieData tm userkey dhtkey) = do
387 put tm
388 putPublicKey userkey
389 putPublicKey userkey
390
391instance Sized CookieRequest where
392 size = ConstSize 64 -- 32 byte key + 32 byte padding
393
394instance Serialize CookieRequest where
395 get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey
396 put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k
397
398forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
399forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
400 where
401 await' :: HandleHi a -> IO a
402 await' pass = awaitMessage dht $ \case
403 Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
404 -> do mni <- closeLookup target
405 -- Forward the message if the target is in our close list.
406 forM_ mni $ \ni -> sendMessage dht ni m
407 await' pass
408 m -> pass m
409
410encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo)
411encrypt crypto msg ni = do
412 let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain
413 m <- sequenceMessage $ transcode cipher msg
414 return (m, ni)
415
416encryptMessage :: Serialize a =>
417 TransportCrypto ->
418 PublicKey ->
419 Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a)
420encryptMessage crypto destKey n arg = do
421 let plain = encodePlain $ swap $ either id asymmData arg
422 secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n
423 return $ E8 $ ToxCrypto.encrypt secret plain
424
425decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo))
426decrypt crypto msg ni = do
427 let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c
428 msg' <- sequenceMessage $ transcode decipher msg
429 return $ fmap (, ni) $ sequenceMessage msg'
430
431decryptMessage :: Serialize x =>
432 TransportCrypto
433 -> Nonce24
434 -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x))
435 -> IO ((Either String ∘ ((,) Nonce8)) x)
436decryptMessage crypto n arg = do
437 let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg
438 plain8 = Composed . fmap swap . (>>= decodePlain)
439 secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n
440 return $ plain8 $ ToxCrypto.decrypt secret e
441
442sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
443sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym
444sequenceMessage (DHTPong asym) = fmap DHTPong $ sequenceA $ fmap uncomposed asym
445sequenceMessage (DHTGetNodes asym) = fmap DHTGetNodes $ sequenceA $ fmap uncomposed asym
446sequenceMessage (DHTSendNodes asym) = fmap DHTSendNodes $ sequenceA $ fmap uncomposed asym
447sequenceMessage (DHTCookieRequest asym) = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym
448sequenceMessage (DHTCookie n dta) = fmap (DHTCookie n) $ uncomposed dta
449sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym
450sequenceMessage (DHTLanDiscovery nid) = pure $ DHTLanDiscovery nid
451
452transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g
453transcode f (DHTPing asym) = DHTPing $ asym { asymmData = f (asymmNonce asym) (Right asym) }
454transcode f (DHTPong asym) = DHTPong $ asym { asymmData = f (asymmNonce asym) (Right asym) }
455transcode f (DHTGetNodes asym) = DHTGetNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) }
456transcode f (DHTSendNodes asym) = DHTSendNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) }
457transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { asymmData = f (asymmNonce asym) (Right asym) }
458transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta
459transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) }
460transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid
diff --git a/src/Network/Tox/Handshake.hs b/src/Network/Tox/Handshake.hs
deleted file mode 100644
index c48b7415..00000000
--- a/src/Network/Tox/Handshake.hs
+++ /dev/null
@@ -1,125 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeOperators #-}
7module Network.Tox.Handshake where
8
9import Control.Arrow
10import Control.Concurrent.STM
11import Control.Monad
12import Crypto.Hash
13import Crypto.Tox
14import Data.Functor.Identity
15import Data.Time.Clock.POSIX
16import Network.Tox.Crypto.Transport
17import Network.Tox.DHT.Handlers (createCookieSTM)
18import Network.Tox.DHT.Transport (Cookie (..), CookieData (..))
19import Network.Tox.NodeId
20#ifdef THREAD_DEBUG
21#else
22import Control.Concurrent
23import GHC.Conc (labelThread)
24#endif
25import DPut
26import DebugTag
27
28
29anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
30anyRight e [] f = return $ Left e
31anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)
32
33decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity))
34decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
35 (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto
36 <*> transportSymmetric crypto
37 let seckeys = map fst ukeys
38 now <- getPOSIXTime
39 -- dput XNetCrypto "decryptHandshake: trying the following keys:"
40 -- forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k)
41 fmap join . sequence $ do -- Either Monad
42 cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie
43 Right $ do -- IO Monad
44 decrypted <- anyRight "missing key" seckeys $ \key -> do
45 -- dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey)
46 -- dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24
47 secret <- lookupSharedSecret crypto key remotePubkey nonce24
48 let step1 = decrypt secret encrypted
49 case step1 of
50 Left s -> do
51 -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
52 return (Left s)
53 Right pln -> do
54 case decodePlain pln of
55 Left s -> do
56 -- dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
57 return (Left s)
58 Right x -> return (Right (key,x))
59 return $ do -- Either Monad
60 (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
61 left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15)
62 let hinit = hashInit
63 hctx = hashUpdate hinit n24
64 hctx' = hashUpdate hctx ecookie
65 digest = hashFinalize hctx'
66 left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest)
67 return ( key
68 , hshake { handshakeCookie = Cookie n24 (pure cd)
69 , handshakeData = pure hsdata
70 } )
71
72
73data HandshakeParams
74 = HParam
75 { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
76 , hpOtherCookie :: Cookie Encrypted
77 , hpTheirSessionKeyPublic :: Maybe PublicKey
78 , hpMySecretKey :: SecretKey
79 , hpCookieRemotePubkey :: PublicKey
80 , hpCookieRemoteDhtkey :: PublicKey
81 }
82
83newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData
84newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
85 let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp
86 hinit = hashInit
87 Cookie n24 encrypted = hpOtherCookie
88 hctx = hashUpdate hinit n24
89 hctx' = hashUpdate hctx encrypted
90 digest = hashFinalize hctx'
91 freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey
92 return HandshakeData
93 { baseNonce = basenonce
94 , sessionKey = mySessionPublic
95 , cookieHash = digest
96 , otherCookie = freshCookie
97 }
98
99toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
100toHandshakeParams (key,hs)
101 = let hd = runIdentity $ handshakeData hs
102 Cookie _ cd0 = handshakeCookie hs
103 CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0
104 in HParam { hpTheirBaseNonce = Just $ baseNonce hd
105 , hpOtherCookie = otherCookie hd
106 , hpTheirSessionKeyPublic = Just $ sessionKey hd
107 , hpMySecretKey = key
108 , hpCookieRemotePubkey = remotePublicKey
109 , hpCookieRemoteDhtkey = remoteDhtPublicKey
110 }
111
112encodeHandshake :: POSIXTime
113 -> TransportCrypto
114 -> SecretKey
115 -> PublicKey
116 -> Cookie Encrypted
117 -> HandshakeData
118 -> STM (Handshake Encrypted)
119encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do
120 n24 <- transportNewNonce crypto
121 state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them
122 return Handshake { handshakeCookie = otherCookie
123 , handshakeNonce = n24
124 , handshakeData = encrypt state $ encodePlain myhandshakeData
125 }
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs
deleted file mode 100644
index 9a9c893a..00000000
--- a/src/Network/Tox/NodeId.hs
+++ /dev/null
@@ -1,731 +0,0 @@
1{- LANGUAGE ApplicativeDo -}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DataKinds #-}
5{-# LANGUAGE DeriveDataTypeable #-}
6{-# LANGUAGE DeriveFunctor #-}
7{-# LANGUAGE DeriveTraversable #-}
8{-# LANGUAGE ExistentialQuantification #-}
9{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE GADTs #-}
11{-# LANGUAGE GeneralizedNewtypeDeriving #-}
12{-# LANGUAGE KindSignatures #-}
13{-# LANGUAGE LambdaCase #-}
14{-# LANGUAGE PatternSynonyms #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16{-# LANGUAGE StandaloneDeriving #-}
17{-# LANGUAGE TupleSections #-}
18{- LANGUAGE TypeApplications -}
19module Network.Tox.NodeId
20 ( NodeInfo(..)
21 , NodeId
22 , nodeInfo
23 , nodeAddr
24 , zeroID
25 , key2id
26 , id2key
27 , getIP
28 , xorNodeId
29 , testNodeIdBit
30 , sampleNodeId
31 , NoSpam(..)
32 , NoSpamId(..)
33 , noSpamIdToHex
34 , parseNoSpamId
35 , nospam64
36 , nospam16
37 , verifyChecksum
38 , ToxContact(..)
39 , ToxProgress(..)
40 , parseToken32
41 , showToken32
42 ) where
43
44import Control.Applicative
45import Control.Arrow
46import Control.Monad
47#ifdef CRYPTONITE_BACKPORT
48import Crypto.Error.Types (CryptoFailable (..),
49 throwCryptoError)
50#else
51import Crypto.Error
52#endif
53
54import Crypto.PubKey.Curve25519
55import qualified Data.Aeson as JSON
56 ;import Data.Aeson (FromJSON, ToJSON, (.=))
57import Data.Bits.ByteString ()
58import qualified Data.ByteArray as BA
59 ;import Data.ByteArray as BA (ByteArrayAccess)
60import qualified Data.ByteString as B
61 ;import Data.ByteString (ByteString)
62import qualified Data.ByteString.Base16 as Base16
63import qualified Data.ByteString.Base64 as Base64
64import qualified Data.ByteString.Char8 as C8
65import Data.Char
66import Data.Data
67import Data.Hashable
68#if MIN_VERSION_iproute(1,7,4)
69import Data.IP hiding (fromSockAddr)
70#else
71import Data.IP
72#endif
73import Data.List
74import Data.Maybe
75import Data.Serialize as S
76import Data.Word
77import Foreign.Storable
78import GHC.TypeLits
79import Network.Address hiding (nodePort)
80import System.IO.Unsafe (unsafeDupablePerformIO)
81import qualified Text.ParserCombinators.ReadP as RP
82import Text.Read hiding (get)
83import Data.Bits
84import Crypto.Tox
85import Foreign.Ptr
86import Data.Function
87import System.Endian
88import qualified Data.Text as Text
89 ;import Data.Text (Text)
90import Util (splitJID)
91
92-- | perform io for hashes that do allocation and ffi.
93-- unsafeDupablePerformIO is used when possible as the
94-- computation is pure and the output is directly linked
95-- to the input. we also do not modify anything after it has
96-- been returned to the user.
97unsafeDoIO :: IO a -> a
98#if __GLASGOW_HASKELL__ > 704
99unsafeDoIO = unsafeDupablePerformIO
100#else
101unsafeDoIO = unsafePerformIO
102#endif
103
104unpackPublicKey :: ByteArrayAccess bs => bs -> [Word64]
105unpackPublicKey bs = loop 0
106 where loop i
107 | i == (BA.length bs `div` 8) = []
108 | otherwise =
109 let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i)
110 in v : loop (i+1)
111
112packPublicKey :: BA.ByteArray bs => [Word64] -> bs
113packPublicKey ws = BA.allocAndFreeze (8 * length ws) $
114 flip fix ws $ \loop ys ptr -> case ys of
115 [] -> return ()
116 x:xs -> do poke ptr (toBE64 x)
117 loop xs (plusPtr ptr 8)
118{-# NOINLINE packPublicKey #-}
119
120-- We represent the node id redundantly in two formats. The [Word64] format is
121-- convenient for short-circuiting xor/distance comparisons. The PublicKey
122-- format is convenient for encryption.
123data NodeId = NodeId [Word64] !(Maybe PublicKey)
124 deriving Data
125
126instance Data PublicKey where
127 -- Data a => (forall d b . Data d => c (d -> b) -> d -> c b) -> (forall g . g -> c g) -> a -> c a
128 gfoldl f z txt = z (throwCryptoError . publicKey) `f` (BA.convert txt :: ByteString)
129 toConstr _ = error "Crypto.PubKey.Curve25519.toConstr"
130 gunfold _ _ = error "Crypto.PubKey.Curve25519.gunfold"
131#if MIN_VERSION_base(4,2,0)
132 dataTypeOf _ = mkNoRepType "Crypto.PubKey.Curve25519.PublicKey"
133#else
134 dataTypeOf _ = mkNorepType "Crypto.PubKey.Curve25519.PublicKey"
135#endif
136
137
138instance Eq NodeId where
139 (NodeId ws _) == (NodeId xs _)
140 = ws == xs
141
142instance Ord NodeId where
143 compare (NodeId ws _) (NodeId xs _) = compare ws xs
144
145instance Sized NodeId where size = ConstSize 32
146
147key2id :: PublicKey -> NodeId
148key2id k = NodeId (unpackPublicKey k) (Just k)
149
150bs2id :: ByteString -> NodeId
151bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs
152
153id2key :: NodeId -> PublicKey
154id2key (NodeId ws (Just key)) = key
155id2key (NodeId key Nothing) = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes)
156
157zeroKey :: PublicKey
158zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0
159
160zeroID :: NodeId
161zeroID = NodeId (replicate 4 0) (Just zeroKey)
162
163-- | Convert to and from a Base64 variant that uses .- instead of +/.
164nmtoken64 :: Bool -> Char -> Char
165nmtoken64 False '.' = '+'
166nmtoken64 False '-' = '/'
167nmtoken64 True '+' = '.'
168nmtoken64 True '/' = '-'
169nmtoken64 _ c = c
170
171-- | Parse 43-digit base64 token into 32-byte bytestring.
172parseToken32 :: String -> Either String ByteString
173parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str)
174
175-- | Encode 32-byte bytestring as 43-digit base64 token.
176showToken32 :: ByteArrayAccess bin => bin -> String
177showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs
178
179instance Read NodeId where
180 readsPrec _ str
181 | (bs,_) <- Base16.decode (C8.pack $ take 64 str)
182 , CryptoPassed pub <- publicKey bs -- B.length bs == 32
183 = [ (key2id pub, drop (2 * B.length bs) str) ]
184 | Right bs <- parseToken32 str
185 , CryptoPassed pub <- publicKey bs -- B.length bs == 32
186 = [ (key2id pub, drop 43 str) ]
187 | otherwise = []
188
189instance Show NodeId where
190 show nid = showToken32 $ id2key nid
191
192instance S.Serialize NodeId where
193 get = key2id <$> getPublicKey
194 put nid = putPublicKey $ id2key nid
195
196instance Hashable NodeId where
197 hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws)
198
199testNodeIdBit :: NodeId -> Word -> Bool
200testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available.
201 | fromIntegral i < 256 -- 256 bits
202 , (q, r) <- quotRem (fromIntegral i) 64
203 = testBit (ws !! q) (63 - r)
204 | otherwise = False
205
206xorNodeId :: NodeId -> NodeId -> NodeId
207xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing
208
209sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId
210sampleNodeId gen (NodeId self k) (q,m,b)
211 | q <= 0 = bs2id <$> gen 32
212 | q >= 32 = pure (NodeId self k)
213 | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend?
214 bw = shiftL (fromIntegral b) (8*(7-r))
215 mw = bw - 1 :: Word64
216 (hd, t0 : _) = splitAt (qw-1) self
217 h = xor bw (complement mw .&. t0)
218 = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs ->
219 let (w:ws) = unpackPublicKey bs
220 in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing
221
222data NodeInfo = NodeInfo
223 { nodeId :: NodeId
224 , nodeIP :: IP
225 , nodePort :: PortNumber
226 }
227 deriving (Eq,Ord)
228
229nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
230nodeInfo nid saddr
231 | Just ip <- fromSockAddr saddr
232 , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
233 | otherwise = Left "Address family not supported."
234
235
236instance ToJSON NodeInfo where
237 toJSON (NodeInfo nid (IPv4 ip) port)
238 = JSON.object [ "public_key" .= show nid
239 , "ipv4" .= show ip
240 , "port" .= (fromIntegral port :: Int)
241 ]
242 toJSON (NodeInfo nid (IPv6 ip6) port)
243 | Just ip <- un4map ip6
244 = JSON.object [ "public_key" .= show nid
245 , "ipv4" .= show ip
246 , "port" .= (fromIntegral port :: Int)
247 ]
248 | otherwise
249 = JSON.object [ "public_key" .= show nid
250 , "ipv6" .= show ip6
251 , "port" .= (fromIntegral port :: Int)
252 ]
253instance FromJSON NodeInfo where
254 parseJSON (JSON.Object v) = do
255 nidstr <- v JSON..: "public_key"
256 ip6str <- v JSON..:? "ipv6"
257 ip4str <- v JSON..:? "ipv4"
258 portnum <- v JSON..: "port"
259 ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
260 <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
261 let (bs,_) = Base16.decode (C8.pack nidstr)
262 enid = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
263 idbs <- (guard (B.length bs == 32) >> return bs)
264 <|> either fail (return . B.drop 1) enid
265 return $ NodeInfo (bs2id idbs) ip (fromIntegral (portnum :: Word16))
266
267getIP :: Word8 -> S.Get IP
268getIP 0x02 = IPv4 <$> S.get
269getIP 0x0a = IPv6 <$> S.get
270getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
271getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
272getIP x = fail ("unsupported address family ("++show x++")")
273
274instance Sized NodeInfo where
275 size = VarSize $ \(NodeInfo nid ip port) ->
276 case ip of
277 IPv4 _ -> 39 -- 35 + 4 = 1 + 4 + 2 + 32
278 IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32
279
280instance S.Serialize NodeInfo where
281 get = do
282 addrfam <- S.get :: S.Get Word8
283 let fallback = do -- FIXME: Handle unrecognized address families.
284 IPv6 <$> S.get
285 return $ IPv6 (read "::" :: IPv6)
286 ip <- getIP addrfam <|> fallback
287 port <- S.get :: S.Get PortNumber
288 nid <- S.get
289 return $ NodeInfo nid ip port
290
291 put (NodeInfo nid ip port) = do
292 case ip of
293 IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
294 IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
295 S.put port
296 S.put nid
297
298hexdigit :: Char -> Bool
299hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
300
301b64digit :: Char -> Bool
302b64digit '.' = True
303b64digit '+' = True
304b64digit '-' = True
305b64digit '/' = True
306b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z')
307
308ip_w_port :: Int -> RP.ReadP (IP, PortNumber)
309ip_w_port i = do
310 ip <- RP.between (RP.char '[') (RP.char ']')
311 (IPv6 <$> RP.readS_to_P (readsPrec i))
312 RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
313 _ <- RP.char ':'
314 port <- toEnum <$> RP.readS_to_P (readsPrec i)
315 return (ip, port)
316
317
318instance Read NodeInfo where
319 readsPrec i = RP.readP_to_S $ do
320 RP.skipSpaces
321 let n = 43 -- characters in node id.
322 parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
323 RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char])))
324 nodeidAt = do (is64,hexhash) <-
325 fmap (True,) (sequence $ replicate n (RP.satisfy b64digit))
326 RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit))
327 RP.char '@' RP.+++ RP.satisfy isSpace
328 addrstr <- parseAddr
329 nid <- if is64
330 then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of
331 Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs)
332 _ -> fail "Bad node id."
333 else case Base16.decode $ C8.pack hexhash of
334 (bs,rem) | B.length bs == 32 && B.null rem -> return (bs2id bs)
335 _ -> fail "Bad node id."
336 return (nid,addrstr)
337 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
338 (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of
339 [] -> fail "Bad address."
340 ((ip,port),_):_ -> return (ip,port)
341 return $ NodeInfo nid ip port
342
343-- The Hashable instance depends only on the IP address and port number.
344--
345-- TODO: Why is the node id excluded?
346instance Hashable NodeInfo where
347 hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
348 {-# INLINE hashWithSalt #-}
349
350
351instance Show NodeInfo where
352 showsPrec _ (NodeInfo nid ip port) =
353 shows nid . ('@' :) . showsip . (':' :) . shows port
354 where
355 showsip
356 | IPv4 ip4 <- ip = shows ip4
357 | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
358 | otherwise = ('[' :) . shows ip . (']' :)
359
360
361
362
363{-
364type NodeId = PubKey
365
366pattern NodeId bs = PubKey bs
367
368-- TODO: This should probably be represented by Curve25519.PublicKey, but
369-- ByteString has more instances...
370newtype PubKey = PubKey ByteString
371 deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable)
372
373instance Serialize PubKey where
374 get = PubKey <$> getBytes 32
375 put (PubKey bs) = putByteString bs
376
377instance Show PubKey where
378 show (PubKey bs) = C8.unpack $ Base16.encode bs
379
380instance FiniteBits PubKey where
381 finiteBitSize _ = 256
382
383instance Read PubKey where
384 readsPrec _ str
385 | (bs, xs) <- Base16.decode $ C8.pack str
386 , B.length bs == 32
387 = [ (PubKey bs, drop 64 str) ]
388 | otherwise = []
389
390
391
392
393data NodeInfo = NodeInfo
394 { nodeId :: NodeId
395 , nodeIP :: IP
396 , nodePort :: PortNumber
397 }
398 deriving (Eq,Ord,Data)
399
400instance Data PortNumber where
401 dataTypeOf _ = mkNoRepType "PortNumber"
402 toConstr _ = error "PortNumber.toConstr"
403 gunfold _ _ = error "PortNumber.gunfold"
404
405instance ToJSON NodeInfo where
406 toJSON (NodeInfo nid (IPv4 ip) port)
407 = JSON.object [ "public_key" .= show nid
408 , "ipv4" .= show ip
409 , "port" .= (fromIntegral port :: Int)
410 ]
411 toJSON (NodeInfo nid (IPv6 ip6) port)
412 | Just ip <- un4map ip6
413 = JSON.object [ "public_key" .= show nid
414 , "ipv4" .= show ip
415 , "port" .= (fromIntegral port :: Int)
416 ]
417 | otherwise
418 = JSON.object [ "public_key" .= show nid
419 , "ipv6" .= show ip6
420 , "port" .= (fromIntegral port :: Int)
421 ]
422instance FromJSON NodeInfo where
423 parseJSON (JSON.Object v) = do
424 nidstr <- v JSON..: "public_key"
425 ip6str <- v JSON..:? "ipv6"
426 ip4str <- v JSON..:? "ipv4"
427 portnum <- v JSON..: "port"
428 ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
429 <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
430 let (bs,_) = Base16.decode (C8.pack nidstr)
431 guard (B.length bs == 32)
432 return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))
433
434getIP :: Word8 -> S.Get IP
435getIP 0x02 = IPv4 <$> S.get
436getIP 0x0a = IPv6 <$> S.get
437getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
438getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
439getIP x = fail ("unsupported address family ("++show x++")")
440
441instance S.Serialize NodeInfo where
442 get = do
443 addrfam <- S.get :: S.Get Word8
444 ip <- getIP addrfam
445 port <- S.get :: S.Get PortNumber
446 nid <- S.get
447 return $ NodeInfo nid ip port
448
449 put (NodeInfo nid ip port) = do
450 case ip of
451 IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
452 IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
453 S.put port
454 S.put nid
455
456-- node format:
457-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
458-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
459-- [port (in network byte order), length=2 bytes]
460-- [char array (node_id), length=32 bytes]
461--
462
463
464hexdigit :: Char -> Bool
465hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
466
467instance Read NodeInfo where
468 readsPrec i = RP.readP_to_S $ do
469 RP.skipSpaces
470 let n = 64 -- characters in node id.
471 parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
472 RP.+++ RP.munch (not . isSpace)
473 nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
474 RP.char '@' RP.+++ RP.satisfy isSpace
475 addrstr <- parseAddr
476 nid <- case Base16.decode $ C8.pack hexhash of
477 (bs,_) | B.length bs==32 -> return (PubKey bs)
478 _ -> fail "Bad node id."
479 return (nid,addrstr)
480 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
481 let raddr = do
482 ip <- RP.between (RP.char '[') (RP.char ']')
483 (IPv6 <$> RP.readS_to_P (readsPrec i))
484 RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
485 _ <- RP.char ':'
486 port <- toEnum <$> RP.readS_to_P (readsPrec i)
487 return (ip, port)
488
489 (ip,port) <- case RP.readP_to_S raddr addrstr of
490 [] -> fail "Bad address."
491 ((ip,port),_):_ -> return (ip,port)
492 return $ NodeInfo nid ip port
493
494
495-- The Hashable instance depends only on the IP address and port number.
496instance Hashable NodeInfo where
497 hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
498 {-# INLINE hashWithSalt #-}
499
500
501instance Show NodeInfo where
502 showsPrec _ (NodeInfo nid ip port) =
503 shows nid . ('@' :) . showsip . (':' :) . shows port
504 where
505 showsip
506 | IPv4 ip4 <- ip = shows ip4
507 | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
508 | otherwise = ('[' :) . shows ip . (']' :)
509
510nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
511nodeInfo nid saddr
512 | Just ip <- fromSockAddr saddr
513 , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
514 | otherwise = Left "Address family not supported."
515
516zeroID :: NodeId
517zeroID = PubKey $ B.replicate 32 0
518
519-}
520
521nodeAddr :: NodeInfo -> SockAddr
522nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
523
524
525newtype ForwardPath (n::Nat) = ForwardPath ByteString
526 deriving (Eq, Ord,Data)
527
528{-
529class KnownNat n => OnionPacket n where
530 mkOnion :: ReturnPath n -> Packet -> Packet
531instance OnionPacket 0 where mkOnion _ = id
532instance OnionPacket 3 where mkOnion = OnionResponse3
533-}
534
535data NoSpam = NoSpam !Word32 !(Maybe Word16)
536 deriving (Eq,Ord,Show)
537
538instance Serialize NoSpam where
539 get = NoSpam <$> get <*> get
540 put (NoSpam w32 w16) = do
541 put w32
542 put w16
543
544-- Utilizes Data.Serialize format for Word32 nospam and Word16 checksum.
545instance Read NoSpam where
546 readsPrec d s = case break isSpace s of
547 ('$':ws ,rs) | (length ws == 8) -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws
548 ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws
549 _ -> []
550
551base64decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
552base64decode rs getter s =
553 either fail (\a -> return (a,rs))
554 $ runGet getter
555 =<< Base64.decode (C8.pack $ map (nmtoken64 False) s)
556
557base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1)
558base16decode rs getter s =
559 either fail (\a -> return (a,rs))
560 $ runGet getter
561 $ fst
562 $ Base16.decode (C8.pack s)
563
564verifyChecksum :: PublicKey -> Word16 -> Either String ()
565verifyChecksum _ _ = return () -- TODO
566
567data NoSpamId = NoSpamId NoSpam PublicKey
568 deriving (Eq,Ord)
569
570noSpamIdToHex :: NoSpamId -> String
571noSpamIdToHex (NoSpamId nspam pub) = C8.unpack (Base16.encode $ BA.convert pub)
572 ++ nospam16 nspam
573
574nospam16 :: NoSpam -> String
575nospam16 (NoSpam w32 Nothing) = n ++ "????"
576 where n = take 8 $ nospam16 (NoSpam w32 (Just 0))
577nospam16 (NoSpam w32 (Just w16)) = C8.unpack $ Base16.encode $ runPut $ do
578 put w32
579 put w16
580
581nospam64 :: NoSpam -> String
582nospam64 (NoSpam w32 Nothing) = n ++ "???"
583 where n = take 5 $ nospam64 (NoSpam w32 (Just 0))
584nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do
585 put w32
586 put w16
587
588instance Show NoSpamId where
589 show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox"
590
591instance Read NoSpamId where
592 readsPrec d s = either fail id $ do
593 (jid,xs) <- Right $ break isSpace s
594 nsid <- parseNoSpamId $ Text.pack jid
595 return [(nsid,xs)]
596
597parseNoSpamHex :: Text -> Either String NoSpamId
598parseNoSpamHex hex = Right $ NoSpamId (read $ "0x"++nospamsum) (id2key $ read hkey)
599 where
600 (hkey,nospamsum) = splitAt 64 $ Text.unpack hex
601
602parseNoSpamId :: Text -> Either String NoSpamId
603parseNoSpamId spec | Text.length spec == 76
604 , Text.all isHexDigit spec = parseNoSpamHex spec
605 | otherwise = parseNoSpamJID spec
606
607parseNoSpamJID :: Text -> Either String NoSpamId
608parseNoSpamJID jid = do
609 (u,h) <- maybe (Left "Invalid JID.") Right
610 $ let (mu,h,_) = splitJID jid
611 in fmap (, h) mu
612 base64 <- case splitAt 43 $ Text.unpack h of
613 (base64,".tox") -> Right base64
614 _ -> Left "Hostname should be 43 base64 digits followed by .tox."
615 pub <- id2key <$> readEither base64
616 let ustr = Text.unpack u
617 case ustr of
618 '$' : b64digits -> solveBase64NoSpamID b64digits pub
619 '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits)
620 return $ NoSpamId nospam pub
621 _ -> Left "Missing nospam."
622
623solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId
624solveBase64NoSpamID b64digits pub = do
625 NoSpam nospam mx <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits
626 maybe (const $ Left "missing checksum") (flip ($)) mx $ \x -> do
627 let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
628 nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
629 sum = x `xor` nlo `xor` nhi `xor` xorsum pub
630 -- Find any question mark indices.
631 qs = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7]
632 -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles.
633 ns = filter (\case; (_,0) -> False; _ -> True)
634 $ zip [0..7]
635 $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum
636 -- Represent the nospam value as a Word64
637 n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64
638
639 -- q=0 1 2 3 4 5 6 7
640 -- 012 345 670 123 456 701 234 567
641 nibblePlace n q = case mod (n - 3 * q) 8 of
642 p | p < 3 -> Just (q,p)
643 _ -> Nothing
644
645 solve [] !ac = Right ac
646 solve ((n,b):ns) !ac = do
647 -- Find nibble p of question-digit q that corresponds to nibble n.
648 (q,p) <- maybe (Left "Unsolvable nospam.") Right
649 $ foldr (<|>) Nothing $ map (nibblePlace n) qs
650 let bitpos = q * 6 + p * 2
651 ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos
652 solve ns ac'
653 n64' <- solve ns n64
654 let nospam' = fromIntegral (n64' `shiftR` 32)
655 cksum' = fromIntegral (n64' `shiftR` 16)
656 return $ NoSpamId (NoSpam nospam' (Just cksum')) pub
657
658-- | This type indicates a roster-link relationship between a local toxid and a
659-- remote toxid. Note that these toxids are represented as the type 'NodeId'
660-- even though they are long-term keys rather than the public keys of Tox DHT
661-- nodes.
662data ToxContact = ToxContact NodeId{-me-} NodeId{-them-}
663 deriving (Eq,Ord)
664
665instance Show ToxContact where show = show . showToxContact_
666
667showToxContact_ :: ToxContact -> String
668showToxContact_ (ToxContact me them) = show me ++ ":" ++ show them
669
670-- | This type indicates the progress of a tox encrypted friend link
671-- connection. Two scenarios are illustrated below. The parenthesis show the
672-- current 'G.Status' 'ToxProgress' of the session.
673--
674--
675-- Perfect handshake scenario:
676--
677-- Peer 1 Peer 2
678-- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie)
679-- Cookie request ->
680-- <- Cookie response
681-- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie)
682-- Handshake packet ->
683-- * accepts connection
684-- (InProgress AwaitingSessionPacket)
685-- <- Handshake packet
686-- *accepts connection
687-- (InProgress AwaitingSessionPacket)
688-- Encrypted packet -> <- Encrypted packet
689-- *confirms connection *confirms connection
690-- (Established) (Established)
691--
692-- Connection successful.
693--
694-- Encrypted packets -> <- Encrypted packets
695--
696--
697--
698--
699-- More realistic handshake scenario:
700-- Peer 1 Peer 2
701-- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie)
702-- Cookie request -> *packet lost*
703-- Cookie request ->
704-- <- Cookie response
705-- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie)
706--
707-- *Peer 2 randomly starts new connection to peer 1
708-- (InProgress AcquiringCookie)
709-- <- Cookie request
710-- Cookie response ->
711-- (InProgress AwaitingHandshake)
712--
713-- Handshake packet -> <- Handshake packet
714-- *accepts connection * accepts connection
715-- (InProgress AwaitingSessionPacket) (InProgress AwaitingSessionPacket)
716--
717-- Encrypted packet -> <- Encrypted packet
718-- *confirms connection *confirms connection
719-- (Established) (Established)
720--
721-- Connection successful.
722--
723-- Encrypted packets -> <- Encrypted packets
724data ToxProgress
725 = AwaitingDHTKey -- ^ Waiting to receive their DHT key.
726 | AcquiringIPAddress -- ^ Searching DHT to obtain their node's IP & port.
727 | AcquiringCookie -- ^ Attempting to obtain a cookie.
728 | AwaitingHandshake -- ^ Waiting to receive a handshake.
729 | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed".
730 deriving (Eq,Ord,Enum,Show)
731
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
deleted file mode 100644
index f44dd79c..00000000
--- a/src/Network/Tox/Onion/Handlers.hs
+++ /dev/null
@@ -1,369 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE PatternSynonyms #-}
4module Network.Tox.Onion.Handlers where
5
6import Network.Kademlia.Search
7import Network.Tox.DHT.Transport
8import Network.Tox.DHT.Handlers hiding (Message,Client)
9import Network.Tox.Onion.Transport
10import Network.QueryResponse as QR hiding (Client)
11import qualified Network.QueryResponse as QR (Client)
12import Crypto.Tox
13import qualified Data.Wrapper.PSQ as PSQ
14 ;import Data.Wrapper.PSQ (PSQ,pattern (:->))
15import Control.Arrow
16
17import Data.Function
18import qualified Data.MinMaxPSQ as MinMaxPSQ
19 ;import Data.MinMaxPSQ (MinMaxPSQ')
20import Network.BitTorrent.DHT.Token as Token
21
22import Control.Exception hiding (Handler)
23import Control.Monad
24#ifdef THREAD_DEBUG
25import Control.Concurrent.Lifted.Instrument
26#else
27import Control.Concurrent
28import GHC.Conc (labelThread)
29#endif
30import Control.Concurrent.STM
31import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
32import Network.Socket
33#if MIN_VERSION_iproute(1,7,4)
34import Data.IP hiding (fromSockAddr)
35#else
36import Data.IP
37#endif
38import Data.Maybe
39import Data.Functor.Identity
40import DPut
41import DebugTag
42
43type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
44type Message = OnionMessage Identity
45
46classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message
47classify msg = go msg
48 where
49 go (OnionAnnounce announce) = IsQuery AnnounceType
50 $ TransactionId (snd $ runIdentity $ asymmData announce)
51 (asymmNonce announce)
52 go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
53 go (OnionToRoute {}) = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
54 go (OnionToRouteResponse {}) = IsResponse (TransactionId (Nonce8 0) (Nonce24 zeros24))
55
56-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
57-- some secret bytes generated when the instance is created, the current time
58-- divided by a 20 second timeout, the public key of the requester and the source
59-- ip/port that the packet was received from. Since the ip/port that the packet
60-- was received from is in the `ping_id`, the announce packets being sent with a
61-- ping id must be sent using the same path as the packet that we received the
62-- `ping_id` from or announcing will fail.
63--
64-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
65-- time (20 to 40 seconds) for a peer to announce himself while taking in count
66-- all the possible delays with some extra seconds.
67announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
68announceH routing toks keydb oaddr req = do
69 case () of
70 _ | announcePingId req == zeros32
71 -> go False
72
73 _ -> let Nonce32 bs = announcePingId req
74 tok = fromPaddedByteString 32 bs
75 in checkToken toks (onionNodeInfo oaddr) tok >>= go
76 `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e)
77 where
78 go withTok = do
79 let naddr = onionNodeInfo oaddr
80 ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
81 tm <- getPOSIXTime
82
83 let storing = case oaddr of
84 OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
85 _ -> Nothing
86 dput XAnnounce $ unlines [ "announceH: nodeId = " ++ show (nodeId naddr)
87 , " announceSeeking = " ++ show (announceSeeking req)
88 , " withTok = " ++ show withTok
89 , " storing = " ++ maybe "False" (const "True") storing
90 ]
91 record <- atomically $ do
92 forM_ storing $ \retpath -> when withTok $ do
93 let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
94 -- Note: The following distance calculation assumes that
95 -- our nodeid doesn't change and is the same for both
96 -- routing4 and routing6.
97 d = xorNodeId (nodeId (tentativeId routing))
98 (announceSeeking req)
99 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
100 ks <- readTVar keydb
101 return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
102 newtok <- maybe (return $ zeros32)
103 (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
104 storing
105 let k = case record of
106 Nothing -> NotStored newtok
107 Just _ | isJust storing -> Acknowledged newtok
108 Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
109 let response = AnnounceResponse k ns
110 dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response]
111 return response
112
113dataToRouteH ::
114 TVar AnnouncedKeys
115 -> Transport err (OnionDestination r) (OnionMessage f)
116 -> addr
117 -> OnionMessage f
118 -> IO ()
119dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do
120 let k = key2id pub
121 dput XOnion $ "dataToRouteH "++ show k
122 mb <- atomically $ do
123 ks <- readTVar keydb
124 forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
125 writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
126 return rpath
127 dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb)
128 forM_ mb $ \rpath -> do
129 -- forward
130 dput XOnion $ "dataToRouteH sendMessage"
131 sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm
132 dput XOnion $ "Forwarding data-to-route -->"++show k
133
134type NodeDistance = NodeId
135
136data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
137
138toOnionDestination :: AnnouncedRoute -> OnionDestination r
139toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
140
141-- |
142-- The type 'NodeId' was originally made for the DHT key, but here
143-- we reuse it for user keys (public key/real key).
144--
145-- To find someone using their user (public) key, you search for it on
146-- kademlia. At each iteration of the search, you get a response with
147-- closest known nodes(DHT keys) to the key you are searching for.
148--
149-- To do an 'Announce' so your friends can find you, you do a search to
150-- find the closest nodes to your own user(public) key. At those nodes,
151-- you store a route back to yourself (using Announce message) so your
152-- friends can contact you. This means each node needs to store the
153-- saved routes, and that is the purpose of the 'AnnouncedKeys' data
154-- structure.
155--
156data AnnouncedKeys = AnnouncedKeys
157 { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-}))
158 , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute))
159 -- ^ PSQ using NodeId(user/public key) as Key
160 -- and using 'NodeDistance' as priority.
161 -- (smaller number is higher priority)
162 --
163 -- Keeping in a MinMaxPSQ will help us later when we want to make the structure
164 -- bounded. (We simply throw away the most NodeDistant keys.
165 }
166
167
168insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
169insertKey tm pub toxpath d keydb = AnnouncedKeys
170 { keyByAge = PSQ.insert pub tm (keyByAge keydb)
171 , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
172 Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
173 Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb)
174 }
175
176-- | Forks a thread to garbage-collect old key announcements. Keys may be
177-- discarded after 5 minutes.
178forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId
179forkAnnouncedKeysGC db = forkIO $ do
180 myThreadId >>= flip labelThread "gc:toxids"
181 fix $ \loop -> do
182 cutoff <- getPOSIXTime
183 threadDelay 300000000 -- 300 seconds
184 join $ atomically $ do
185 fix $ \gc -> do
186 keys <- readTVar db
187 case PSQ.minView (keyByAge keys) of
188 Nothing -> return loop
189 Just (pub :-> tm,kba')
190 | tm > cutoff -> return loop
191 | otherwise -> do writeTVar db keys
192 { keyByAge = kba'
193 , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys)
194 }
195 gc
196
197areq :: Message -> Either String AnnounceRequest
198areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
199areq _ = Left "Unexpected non-announce OnionMessage"
200
201handlers :: Transport err (OnionDestination r) Message
202 -> Routing
203 -> TVar SessionTokens
204 -> TVar AnnouncedKeys
205 -> PacketKind
206 -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
207handlers net routing toks keydb AnnounceType
208 = Just
209 $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
210 $ announceH routing toks keydb
211handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
212
213
214toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
215 -> TransportCrypto
216 -> Client r
217 -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
218toxidSearch getTimeout crypto client = Search
219 { searchSpace = toxSpace
220 , searchNodeAddress = nodeIP &&& nodePort
221 , searchQuery = Right $ asyncGetRendezvous getTimeout crypto client
222 , searchAlpha = 3
223 , searchK = 6
224 }
225
226announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
227 -> MethodSerializer
228 TransactionId
229 (OnionDestination r)
230 (OnionMessage Identity)
231 PacketKind
232 AnnounceRequest
233 (Maybe AnnounceResponse)
234announceSerializer getTimeout = MethodSerializer
235 { methodTimeout = getTimeout
236 , method = AnnounceType
237 , wrapQuery = \(TransactionId n8 n24) src dst req ->
238 -- :: tid -> addr -> addr -> a -> OnionMessage Identity
239 OnionAnnounce $ Asymm
240 { -- The public key is our real long term public key if we want to
241 -- announce ourselves, a temporary one if we are searching for
242 -- friends.
243 senderKey = onionKey src
244 , asymmNonce = n24
245 , asymmData = Identity (req, n8)
246 }
247 , unwrapResponse = \case -- :: OnionMessage Identity -> b
248 OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
249 _ -> Nothing
250 }
251
252unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
253unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
254 = case is_stored of
255 NotStored n32 -> ( ns , [] , Just n32)
256 SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing )
257 Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
258
259-- TODO Announce key to announce peers.
260--
261-- Announce Peers are only put in the 8 closest peers array if they respond
262-- to an announce request. If the peers fail to respond to 3 announce
263-- requests they are deemed timed out and removed.
264--
265-- ...
266--
267-- For this reason, after the peer is announced successfully for 17 seconds,
268-- announce packets are sent aggressively every 3 seconds to each known close
269-- peer (in the list of 8 peers) to search aggressively for peers that know
270-- the peer we are searching for.
271
272-- TODO
273-- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will
274-- aggressively reannounce itself and search for friends as if it was just
275-- started.
276
277
278sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
279 -> Client r
280 -> AnnounceRequest
281 -> OnionDestination r
282 -> (NodeInfo -> AnnounceResponse -> t)
283 -> IO (Maybe t)
284sendOnion getTimeout client req oaddr unwrap =
285 -- Four tries and then we tap out.
286 flip fix 4 $ \loop n -> do
287 mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
288 forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
289 maybe (if n>0 then loop $! n - 1 else return Nothing)
290 (return . Just . unwrap (onionNodeInfo oaddr))
291 $ join mb
292
293asyncOnion :: (TransactionId
294 -> OnionDestination r -> STM (OnionDestination r, Int))
295 -> QR.Client
296 err
297 PacketKind
298 TransactionId
299 (OnionDestination r)
300 (OnionMessage Identity)
301 -> AnnounceRequest
302 -> OnionDestination r
303 -> (NodeInfo -> AnnounceResponse -> a)
304 -> (Maybe a -> IO ())
305 -> IO ()
306asyncOnion getTimeout client req oaddr unwrap go =
307 -- Four tries and then we tap out.
308 flip fix 4 $ \loop n -> do
309 QR.asyncQuery client (announceSerializer getTimeout) req oaddr
310 $ \mb -> do
311 forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
312 maybe (if n>0 then loop $! n - 1 else go Nothing)
313 (go . Just . unwrap (onionNodeInfo oaddr))
314 $ join mb
315
316
317-- | Lookup the secret counterpart for a given alias key.
318getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
319 -> TransportCrypto
320 -> Client r
321 -> NodeId
322 -> NodeInfo
323 -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32))
324getRendezvous getTimeout crypto client nid ni = do
325 asel <- atomically $ selectAlias crypto nid
326 let oaddr = OnionDestination asel ni Nothing
327 rkey = case asel of
328 SearchingAlias -> Nothing
329 _ -> Just $ key2id $ rendezvousPublic crypto
330 sendOnion getTimeout client
331 (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
332 oaddr
333 (unwrapAnnounceResponse rkey)
334
335asyncGetRendezvous
336 :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
337 -> TransportCrypto
338 -> Client r
339 -> NodeId
340 -> NodeInfo
341 -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ())
342 -> IO ()
343asyncGetRendezvous getTimeout crypto client nid ni go = do
344 asel <- atomically $ selectAlias crypto nid
345 let oaddr = OnionDestination asel ni Nothing
346 rkey = case asel of
347 SearchingAlias -> Nothing
348 _ -> Just $ key2id $ rendezvousPublic crypto
349 asyncOnion getTimeout client
350 (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
351 oaddr
352 (unwrapAnnounceResponse rkey)
353 go
354
355putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
356 -> TransportCrypto
357 -> Client r
358 -> PublicKey
359 -> Nonce32
360 -> NodeInfo
361 -> IO (Maybe (Rendezvous, AnnounceResponse))
362putRendezvous getTimeout crypto client pubkey nonce32 ni = do
363 let longTermKey = key2id pubkey
364 rkey = rendezvousPublic crypto
365 rendezvousKey = key2id rkey
366 asel <- atomically $ selectAlias crypto longTermKey
367 let oaddr = OnionDestination asel ni Nothing
368 sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr
369 $ \ni resp -> (Rendezvous rkey ni, resp)
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
deleted file mode 100644
index e746c414..00000000
--- a/src/Network/Tox/Onion/Transport.hs
+++ /dev/null
@@ -1,119 +0,0 @@
1module Network.Tox.Onion.Transport
2 ( parseOnionAddr
3 , encodeOnionAddr
4 , parseDataToRoute
5 , encodeDataToRoute
6 , forwardOnions
7 , AliasSelector(..)
8 , OnionDestination(..)
9 , OnionMessage(..)
10 , Rendezvous(..)
11 , DataToRoute(..)
12 , OnionData(..)
13 , AnnouncedRendezvous(..)
14 , AnnounceResponse(..)
15 , AnnounceRequest(..)
16 , Forwarding(..)
17 , ReturnPath(..)
18 , OnionRequest(..)
19 , OnionResponse(..)
20 , Addressed(..)
21 , UDPTransport
22 , KeyRecord(..)
23 , encrypt
24 , decrypt
25 , peelSymmetric
26 , OnionRoute(..)
27 , N0
28 , N1
29 , N2
30 , N3
31 , onionKey
32 , onionAliasSelector
33 , selectAlias
34 , RouteId(..)
35 , routeId
36 , putRequest
37 , wrapForRoute
38 , wrapSymmetric
39 , wrapOnion
40 , wrapOnionPure
41 ) where
42
43import Data.ByteString (ByteString)
44import Data.Serialize
45import Network.Socket
46
47import Crypto.Tox hiding (encrypt,decrypt)
48import qualified Data.Tox.Relay as TCP
49import Data.Tox.Onion
50import Network.Tox.NodeId
51
52{-
53encodeOnionAddr :: TransportCrypto
54 -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
55 -> (OnionMessage Encrypted,OnionDestination RouteId)
56 -> IO (Maybe (ByteString, SockAddr))
57-}
58encodeOnionAddr :: TransportCrypto
59 -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute))
60 -> (OnionMessage Encrypted, OnionDestination RouteId)
61 -> IO (Maybe
62 (Either (TCP.RelayPacket, TCP.NodeInfo) (ByteString, SockAddr)))
63encodeOnionAddr crypto _ (msg,OnionToOwner ni p) =
64 return $ Just $ Right ( runPut $ putResponse (OnionResponse p msg)
65 , nodeAddr ni )
66encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do
67 encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) )
68 -- dput XMisc $ "ONION encode missing routeid"
69 -- return Nothing
70encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do
71 let go route = do
72 mreq <- wrapForRoute crypto msg ni route
73 case mreq of
74 Right req -> return $ Right ( runPut $ putRequest req , nodeAddr $ routeNodeA route)
75 Left o | Just port <- routeRelayPort route
76 -> return $ Left ( o, TCP.NodeInfo (routeNodeA route) port)
77 m <- {-# SCC "encodeOnionAddr.getRoute" #-} getRoute ni rid
78 x <- {-# SCC "encodeOnionAddr.wrapForRoute" #-} mapM go m
79 return x
80
81-- wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0)
82wrapForRoute :: TransportCrypto
83 -> OnionMessage Encrypted
84 -> NodeInfo
85 -> OnionRoute
86 -> IO (Either TCP.RelayPacket (OnionRequest N0))
87wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort=Nothing} = do
88 -- We needn't use the same nonce value here, but I think it is safe to do so.
89 let nonce = msgNonce msg
90 fwd <- wrapOnion crypto (routeAliasA r)
91 nonce
92 (id2key . nodeId $ routeNodeA r)
93 (nodeAddr $ routeNodeB r)
94 =<< wrapOnion crypto (routeAliasB r)
95 nonce
96 (id2key . nodeId $ routeNodeB r)
97 (nodeAddr $ routeNodeC r)
98 =<< wrapOnion crypto (routeAliasC r)
99 nonce
100 (id2key . nodeId $ routeNodeC r)
101 (nodeAddr ni)
102 (NotForwarded msg)
103 return $ Right OnionRequest
104 { onionNonce = nonce
105 , onionForward = fwd
106 , pathFromOwner = NoReturnPath
107 }
108wrapForRoute crypto msg ni r@OnionRoute{routeRelayPort = Just tcpport} = do
109 let nonce = msgNonce msg
110 fwd <- wrapOnion crypto (routeAliasB r)
111 nonce
112 (id2key . nodeId $ routeNodeB r)
113 (nodeAddr $ routeNodeC r)
114 =<< wrapOnion crypto (routeAliasC r)
115 nonce
116 (id2key . nodeId $ routeNodeC r)
117 (nodeAddr ni)
118 (NotForwarded msg)
119 return $ Left $ TCP.OnionPacket nonce $ Addressed (nodeAddr $ routeNodeB r) fwd
diff --git a/src/Network/Tox/Relay.hs b/src/Network/Tox/Relay.hs
deleted file mode 100644
index 2842fcc2..00000000
--- a/src/Network/Tox/Relay.hs
+++ /dev/null
@@ -1,235 +0,0 @@
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Network.Tox.Relay (tcpRelay) where
5
6import Control.Concurrent.MVar
7import Control.Concurrent.STM
8import Control.Exception
9import Control.Monad
10import qualified Data.ByteString as B
11import Data.Function
12import Data.Functor.Identity
13import qualified Data.IntMap as IntMap
14 ;import Data.IntMap (IntMap)
15import qualified Data.Map as Map
16 ;import Data.Map (Map)
17import Data.Serialize
18import Data.Word
19import Network.Socket (SockAddr)
20import System.IO
21import System.IO.Error
22import System.Timeout
23
24import Crypto.Tox
25import qualified Data.IntervalSet as IntSet
26 ;import Data.IntervalSet (IntSet)
27import Data.Tox.Relay
28import Network.Address (getBindAddress)
29import Network.SocketLike
30import Network.StreamServer
31import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
32
33
34
35hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
36hGetPrefixed h = do
37 mlen <- runGet getWord16be <$> B.hGet h 2
38 -- We treat parse-fail the same as EOF.
39 fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len)
40
41hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x)
42hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF.
43 where
44 ConstSize len = size :: Size x
45
46data RelaySession = RelaySession
47 { indexPool :: IntSet -- ^ Ints that are either solicited or associated.
48 , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated.
49 , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to.
50 }
51
52freshSession :: RelaySession
53freshSession = RelaySession
54 { indexPool = IntSet.empty
55 , solicited = Map.empty
56 , associated = IntMap.empty
57 }
58
59disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
60 -> PublicKey
61 -> IO ()
62disconnect cons who = join $ atomically $ do
63 Map.lookup who <$> readTVar cons
64 >>= \case
65 Nothing -> return $ return ()
66 Just (_,session) -> do
67 modifyTVar' cons $ Map.delete who
68 RelaySession { associated = cs } <- readTVar session
69 return $ let notifyPeer i send = ((send DisconnectNotification) >>)
70 in IntMap.foldrWithKey notifyPeer (return ()) cs
71
72relaySession :: TransportCrypto
73 -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
74 -> (SockAddr -> OnionRequest N1 -> IO ())
75 -> sock
76 -> Int
77 -> Handle
78 -> IO ()
79relaySession crypto cons sendOnion _ conid h = do
80 -- atomically $ modifyTVar' cons $ IntMap.insert conid h
81
82 -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h
83
84 (hGetSized h >>=) $ mapM_ $ \helloE -> do
85
86 let me = transportSecret crypto
87 them = helloFrom helloE
88
89 noncef <- lookupNonceFunction crypto me them
90 let mhello = decryptPayload (noncef $ helloNonce helloE) helloE
91 forM_ mhello $ \hello -> do
92 let _ = hello :: Hello Identity
93
94 (me',welcome) <- atomically $ do
95 skey <- transportNewKey crypto
96 dta <- HelloData (toPublic skey) <$> transportNewNonce crypto
97 w24 <- transportNewNonce crypto
98 return (skey, Welcome w24 $ pure dta)
99
100 B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
101
102 noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
103 in lookupNonceFunction crypto me' them'
104
105 let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h
106 base = sessionBaseNonce $ runIdentity $ helloData hello
107
108 -- You get 3 seconds to send a session packet.
109 mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base)
110 forM_ mpkt0 $ \pkt0 -> do
111
112 disconnect cons (helloFrom hello)
113 (sendPacket,session) <- do
114 session <- atomically $ newTVar freshSession
115 sendPacket <- do
116 v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
117 return $ \p -> do
118 case p of
119 DisconnectNotification con -> atomically $ do
120 modifyTVar' session $ \s -> s
121 { indexPool = maybe id IntSet.delete (c2key con) (indexPool s)
122 , associated = maybe id IntMap.delete (c2key con) (associated s)
123 }
124 _ -> return ()
125 n24 <- takeMVar v
126 let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket)
127 do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16)
128 B.hPut h bs
129 `catchIOError` \_ -> return ()
130 putMVar v (incrementNonce24 n24)
131 atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session)
132 return (sendPacket,session)
133
134 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
135
136 flip fix (incrementNonce24 base) $ \loop n24 -> do
137 m <- readPacket n24
138 forM_ m $ \p -> do
139 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
140 loop (incrementNonce24 n24)
141 `finally`
142 disconnect cons (helloFrom hello)
143
144handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
145 -> Int
146 -> PublicKey
147 -> TransportCrypto
148 -> (SockAddr -> OnionRequest N1 -> IO ())
149 -> (RelayPacket -> IO ())
150 -> TVar RelaySession
151 -> RelayPacket
152 -> IO ()
153handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
154 RoutingRequest them -> join $ atomically $ do
155 mySession <- readTVar session
156 mi <- case Map.lookup them (solicited mySession) of
157 Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do
158 if -120 <= i && i <= 119
159 then do
160 writeTVar session mySession
161 { indexPool = IntSet.insert i (indexPool mySession)
162 , solicited = Map.insert them i (solicited mySession)
163 }
164 return $ Just i
165 else return Nothing -- No more slots available.
166 Just i -> return $ Just i
167 notifyConnect <- fmap (join . join) $ forM mi $ \i -> do
168 mp <- Map.lookup them <$> readTVar cons
169 forM mp $ \(sendToThem,peer) -> do
170 theirSession <- readTVar peer
171 forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do
172 let sendToThem' f = sendToThem $ f $ key2c reserved_id
173 sendToMe' f = sendToMe $ f $ key2c i
174 writeTVar peer theirSession
175 { solicited = Map.delete me (solicited theirSession)
176 , associated = IntMap.insert reserved_id sendToMe' (associated theirSession)
177 }
178 writeTVar session mySession
179 { solicited = Map.delete them (solicited mySession)
180 , associated = IntMap.insert i sendToThem' (associated mySession)
181 }
182 return $ do sendToThem' ConnectNotification
183 sendToMe' ConnectNotification
184 return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them
185 sequence_ notifyConnect
186
187 RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid. Do we care?
188
189 OOBSend them bs -> do
190 m <- atomically $ Map.lookup them <$> readTVar cons
191 forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs
192
193 RelayData bs con -> join $ atomically $ do
194 -- Data: Data packets can only be sent and received if the
195 -- corresponding connection_id is connection (a Connect notification
196 -- has been received from it) if the server receives a Data packet for
197 -- a non connected or existent connection it will discard it.
198 mySession <- readTVar session
199 return $ sequence_ $ do
200 i <- c2key con
201 sendToThem' <- IntMap.lookup i $ associated mySession
202 return $ sendToThem' $ RelayData bs
203
204 OnionPacket n24 (Addressed addr req) -> do
205 rpath <- atomically $ do
206 sym <- transportSymmetric crypto
207 n <- transportNewNonce crypto
208 return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath
209 sendOnion addr $ OnionRequest n24 req rpath
210
211 _ -> return ()
212
213
214sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO ()
215sendTCP_ st addr x = join $ atomically
216 $ IntMap.lookup addr <$> readTVar st >>= \case
217 Nothing -> return $ return ()
218 Just send -> return $ send $ OnionPacketResponse x
219
220tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ())
221tcpRelay udp_addr sendOnion = do
222 crypto <- newCrypto
223 cons <- newTVarIO Map.empty
224 clients <- newTVarIO IntMap.empty
225 b443 <- getBindAddress "443" True
226 b80 <- getBindAddress "80" True
227 b33445 <- getBindAddress "33445" True
228 bany <- getBindAddress "" True
229 h <- streamServer ServerConfig
230 { serverWarn = hPutStrLn stderr
231 , serverSession = relaySession crypto cons sendOnion
232 }
233 [b443,b80,udp_addr,b33445,bany]
234 return (h,sendTCP_ clients)
235
diff --git a/src/Network/Tox/Session.hs b/src/Network/Tox/Session.hs
deleted file mode 100644
index 189967fa..00000000
--- a/src/Network/Tox/Session.hs
+++ /dev/null
@@ -1,243 +0,0 @@
1-- | This module implements the lossless Tox session protocol.
2{-# LANGUAGE TupleSections #-}
3module Network.Tox.Session
4 ( SessionParams(..)
5 , SessionKey
6 , Session(..)
7 , sTheirUserKey
8 , sClose
9 , handshakeH
10 ) where
11
12import Control.Concurrent.STM
13import Control.Monad
14import Control.Exception
15import Data.Dependent.Sum
16import Data.Functor.Identity
17import Data.Word
18import Network.Socket (SockAddr)
19
20import Crypto.Tox
21import Data.PacketBuffer (PacketInboundEvent (..))
22import Data.Tox.Msg
23import DPut
24import DebugTag
25import Network.Lossless
26import Network.QueryResponse
27import Network.SessionTransports
28import Network.Tox.Crypto.Transport
29import Network.Tox.DHT.Transport (Cookie (..), key2id, longTermKey)
30import Network.Tox.Handshake
31
32-- | Alias for 'SecretKey' to document that it is used as the temporary Tox
33-- session key corresponding to the 'PublicKey' we sent in the handshake.
34type SessionKey = SecretKey
35
36-- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to
37-- assign packets to sessions, and what to do with established sessions after
38-- they are made lossless by queuing packets and appending sequence numbers.
39data SessionParams = SessionParams
40 { -- | The database of secret keys necessary to encrypt handshake packets.
41 spCrypto :: TransportCrypto
42 -- | This is used to create sessions and dispatch packets to them.
43 , spSessions :: Sessions (CryptoPacket Encrypted)
44 -- | This method returns the session information corresponding to the
45 -- cookie pair for the remote address. If no handshake was sent, this
46 -- should send one immediately. It should return 'Nothing' if anything
47 -- goes wrong.
48 , spGetSentHandshake :: SecretKey -> SockAddr
49 -> Cookie Identity
50 -> Cookie Encrypted
51 -> IO (Maybe (SessionKey, HandshakeData))
52 -- | This method is invoked on each new session and is responsible for
53 -- launching any threads necessary to keep the session alive.
54 , spOnNewSession :: Session -> IO ()
55 }
56
57-- | After a session is established, this information is given to the
58-- 'spOnNewSession' callback.
59data Session = Session
60 { -- | This is the secret user (toxid) key that corresponds to the
61 -- local-end of this session.
62 sOurKey :: SecretKey
63 -- | The remote address for this session. (Not unique, see 'sSessionID').
64 , sTheirAddr :: SockAddr
65 -- | The information we sent in the handshake for this session.
66 , sSentHandshake :: HandshakeData
67 -- | The information we received in a handshake for this session.
68 , sReceivedHandshake :: Handshake Identity
69 -- | This method can be used to trigger packets to be re-sent given a
70 -- list of their sequence numbers. It should be used when the remote end
71 -- indicates they lost packets.
72 , sResendPackets :: [Word32] -> IO ()
73 -- | This list of sequence numbers should be periodically polled and if
74 -- it is not empty, we should request they re-send these packets. For
75 -- convenience, a lower bound for the numbers in the list is also
76 -- returned. Suggested polling interval: a few seconds.
77 , sMissingInbound :: IO ([Word32],Word32)
78 -- | A lossless transport for sending and receiving packets in this
79 -- session. It is up to the caller to spawn the await-loop to handle
80 -- inbound packets.
81 , sTransport :: Transport String () CryptoMessage
82 -- | A unique small integer that identifies this session for as long as
83 -- it is established.
84 , sSessionID :: Int
85 }
86
87-- | Helper to obtain the remote ToxID key from the locally-issued cookie
88-- associated with the session.
89sTheirUserKey :: Session -> PublicKey
90sTheirUserKey s = longTermKey $ runIdentity cookie
91 where
92 Cookie _ cookie = handshakeCookie (sReceivedHandshake s)
93
94-- | Helper to close the 'Transport' associated with a session.
95sClose :: Session -> IO ()
96sClose s = closeTransport (sTransport s)
97
98
99-- | Call this whenever a new handshake arrives so that a session is
100-- negotiated. It always returns Nothing which makes it convenient to use with
101-- 'Network.QueryResponse.addHandler'.
102handshakeH :: SessionParams
103 -> SockAddr
104 -> Handshake Encrypted
105 -> IO (Maybe a)
106handshakeH sp saddr handshake = do
107 decryptHandshake (spCrypto sp) handshake
108 >>= either (\err -> return ())
109 (uncurry $ plainHandshakeH sp saddr)
110 return Nothing
111
112
113plainHandshakeH :: SessionParams
114 -> SockAddr
115 -> SecretKey
116 -> Handshake Identity
117 -> IO ()
118plainHandshakeH sp saddr skey handshake = do
119 let hd = runIdentity $ handshakeData handshake
120 prelude = show saddr ++ " --> "
121 dput XNetCrypto $ unlines $ map (prelude ++)
122 [ "handshake: auth=" ++ show (handshakeCookie handshake)
123 , " : issuing=" ++ show (otherCookie hd)
124 , " : baseNonce=" ++ show (baseNonce hd)
125 ]
126 sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd)
127 -- TODO: this is always returning sent = Nothing
128 dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent)
129 forM_ sent $ \(hd_skey,hd_sent) -> do
130 sk <- SessionKeys (spCrypto sp)
131 hd_skey
132 (sessionKey hd)
133 <$> atomically (newTVar $ baseNonce hd)
134 <*> atomically (newTVar $ baseNonce hd_sent)
135 m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr
136 dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m
137 forM_ m $ \(sid, t) -> do
138 (t2,resend,getMissing)
139 <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp)
140 (\seqno p@(Pkt m :=> _) _ -> do
141 y <- encryptPacket sk $ bookKeeping seqno p
142 return OutgoingInfo
143 { oIsLossy = lossyness m == Lossy
144 , oEncoded = y
145 , oHandleException = Just $ \e -> do
146 dput XUnexpected $ unlines
147 [ "<-- " ++ show e
148 , "<-- while sending " ++ show (seqno,p) ]
149 throwIO e
150 })
151 ()
152 t
153 let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted)
154 _ = t2 :: Transport String () CryptoMessage
155 sendMessage t2 () $ (Pkt ONLINE ==> ())
156 spOnNewSession sp Session
157 { sOurKey = skey
158 , sTheirAddr = saddr
159 , sSentHandshake = hd_sent
160 , sReceivedHandshake = handshake
161 , sResendPackets = resend
162 , sMissingInbound = getMissing
163 , sTransport = t2
164 , sSessionID = sid
165 }
166 return ()
167
168
169-- | The per-session nonce and key state maintained by 'decryptPacket' and
170-- 'encryptPacket'.
171data SessionKeys = SessionKeys
172 { skCrypto :: TransportCrypto -- ^ Cache of shared-secrets.
173 , skMe :: SessionKey -- ^ My session key
174 , skThem :: PublicKey -- ^ Their session key
175 , skNonceIncoming :: TVar Nonce24 -- ^ +21845 when a threshold is reached.
176 , skNonceOutgoing :: TVar Nonce24 -- ^ +1 on every packet
177 }
178
179-- | Decrypt an inbound session packet and update the nonce for the next one.
180decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ()))
181decryptPacket sk saddr (CryptoPacket n16 ciphered) = do
182 (n24,δ) <- atomically $ do
183 n <- readTVar (skNonceIncoming sk)
184 let δ = n16 - nonce24ToWord16 n
185 return ( n `addtoNonce24` fromIntegral δ, δ )
186 secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
187 case decodePlain =<< decrypt secret ciphered of
188 Left e -> return Nothing
189 Right x -> do
190 when ( δ > 43690 )
191 $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845)
192
193 do let them = key2id $ skThem sk
194 CryptoData ack seqno _ = x
195 cm = decodeRawCryptoMsg x
196 dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)]
197
198 return $ Just ( CryptoPacket n16 (pure x), () )
199
200-- | Encrypt an outbound session packet and update the nonce for the next one.
201encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted)
202encryptPacket sk plain = do
203 n24 <- atomically $ do
204 n24 <- readTVar (skNonceOutgoing sk)
205 modifyTVar' (skNonceOutgoing sk) incrementNonce24
206 return n24
207 secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24
208 let ciphered = encrypt secret $ encodePlain $ plain
209
210 do let them = key2id $ skThem sk
211 CryptoData ack seqno cm = plain
212 dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)]
213
214 return $ CryptoPacket (nonce24ToWord16 n24) ciphered
215
216
217-- | Add sequence information to an outbound packet.
218--
219-- From spec.md:
220--
221-- Data in the encrypted packets:
222--
223-- [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)]
224-- [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)]
225-- [data]
226bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData
227bookKeeping (SequenceInfo seqno ack) m = CryptoData
228 { bufferStart = ack :: Word32
229 , bufferEnd = seqno :: Word32
230 , bufferData = m
231 }
232
233-- | Classify an inbound packet as lossy or lossless based on its id byte.
234checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage
235checkLossless cd@CryptoData{ bufferStart = ack
236 , bufferEnd = no
237 , bufferData = x } = tag no x' ack
238 where
239 x' = decodeRawCryptoMsg cd
240 tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy
241 _ -> PacketReceived
242
243
diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
deleted file mode 100644
index 13da804f..00000000
--- a/src/Network/Tox/TCP.hs
+++ /dev/null
@@ -1,313 +0,0 @@
1{-# LANGUAGE RecursiveDo #-}
2{-# LANGUAGE PartialTypeSignatures #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE FlexibleContexts #-}
5module Network.Tox.TCP
6 ( module Network.Tox.TCP
7 , NodeInfo(..)
8 ) where
9
10import Debug.Trace
11import Control.Arrow
12import Control.Concurrent
13import Control.Concurrent.STM
14import Control.Exception
15import Control.Monad
16import Crypto.Random
17import Data.Aeson (ToJSON(..),FromJSON(..))
18import qualified Data.Aeson as JSON
19import Data.Functor.Contravariant
20import Data.Functor.Identity
21import Data.Hashable
22import qualified Data.HashMap.Strict as HashMap
23import Data.IP
24import Data.Maybe
25import Data.Monoid
26import Data.Serialize
27import Data.Word
28import qualified Data.Vector as Vector
29import Network.Socket (SockAddr(..))
30import qualified Text.ParserCombinators.ReadP as RP
31import System.IO.Error
32import System.Timeout
33
34import ControlMaybe
35import Crypto.Tox
36import Data.ByteString (hPut,hGet,ByteString,length)
37import Data.TableMethods
38import Data.Tox.Relay
39import qualified Data.Word64Map
40import DebugTag
41import DPut
42import Network.Address (setPort,PortNumber,localhost4,fromSockAddr)
43import Network.Kademlia.Routing
44import Network.Kademlia.Search hiding (sendQuery)
45import Network.QueryResponse
46import Network.QueryResponse.TCP
47import Network.Tox.DHT.Handlers (toxSpace)
48import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
49import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
50import qualified Network.Tox.NodeId as UDP
51
52
53withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
54withSize f = case size of len -> f len
55
56
57type NodeId = UDP.NodeId
58
59-- example:
60-- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443}
61instance Show NodeInfo where
62 show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}"
63
64nodeId :: NodeInfo -> NodeId
65nodeId ni = UDP.nodeId $ udpNodeInfo ni
66
67nodeAddr :: NodeInfo -> SockAddr
68nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni
69
70nodeIP :: NodeInfo -> IP
71nodeIP ni = UDP.nodeIP $ udpNodeInfo ni
72
73tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) =>
74 TransportCrypto -> StreamHandshake NodeInfo x y
75tcpStream crypto = StreamHandshake
76 { streamHello = \addr h -> do
77 (skey, hello) <- atomically $ do
78 n24 <- transportNewNonce crypto
79 skey <- transportNewKey crypto
80 base24 <- transportNewNonce crypto
81 return $ (,) skey $ Hello $ Asymm
82 { senderKey = transportPublic crypto
83 , asymmNonce = n24
84 , asymmData = pure HelloData
85 { sessionPublicKey = toPublic $ skey
86 , sessionBaseNonce = base24
87 }
88 }
89 noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
90 dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
91 hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
92 welcomeE <- withSize $ fmap decode . hGet h . constSize
93 let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
94 nil = SessionProtocol
95 { streamGoodbye = return ()
96 , streamDecode = return Nothing
97 , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y
98 }
99 either (\_ -> return nil) id $ mwelcome <&> \welcome -> do
100 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
101 noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
102 nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
103 nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
104 let them = sessionPublicKey $ runIdentity $ welcomeData welcome
105 hvar <- newMVar h
106 return SessionProtocol
107 { streamGoodbye = do
108 dput XTCP $ "Closing " ++ show addr
109 return () -- No goodbye packet? Seems rude.
110 , streamDecode =
111 let go h = decode <$> hGet h 2 >>= \case
112 Left e -> do
113 dput XTCP $ "TCP: (" ++ show addr ++ ") Failed to get length: " ++ e
114 return Nothing
115 Right len -> do
116 decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case
117 Left e -> do
118 dput XTCP $ "TCP: Failed to decode packet."
119 return Nothing
120 Right x -> do
121 m24 <- timeout 1000000 (takeMVar nread)
122 fmap join $ forM m24 $ \n24 -> do
123 let r = decrypt (noncef' n24) x >>= decodePlain
124 putMVar nread (incrementNonce24 n24)
125 either (dput XTCP . ("TCP decryption: " ++))
126 (\x' -> do
127 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
128 return ())
129 r
130 return $ either (const Nothing) Just r
131 in bracket (takeMVar hvar) (putMVar hvar)
132 $ \h -> go h `catchIOError` \e -> do
133 dput XTCP $ "TCP exception: " ++ show e
134 return Nothing
135 , streamEncode = \y -> do
136 dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
137 n24 <- takeMVar nsend
138 dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
139 let bs = encode $ encrypt (noncef' n24) $ encodePlain y
140 ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
141 $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
142 `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
143 dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
144 putMVar nsend (incrementNonce24 n24)
145 dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y
146 }
147 , streamAddr = nodeAddr
148 }
149
150toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket)
151 , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) )
152toxTCP crypto = tcpTransport 30 (tcpStream crypto)
153
154tcpSpace :: KademliaSpace NodeId NodeInfo
155tcpSpace = contramap udpNodeInfo toxSpace
156
157{-
158nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
159nodeSearch tcp = Search
160 { searchSpace = tcpSpace
161 , searchNodeAddress = nodeIP &&& tcpPort
162 , searchQuery = getNodes tcp
163 }
164-}
165
166data TCPClient err tid = TCPClient
167 { tcpCrypto :: TransportCrypto
168 , tcpClient :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket)
169 , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo)
170 }
171
172{-
173getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
174getTCPNodes tcp seeking dst = do
175 r <- getUDPNodes' tcp seeking (udpNodeInfo dst)
176 let tcps (ns,_,mb) = (ns',ns',mb)
177 where ns' = do
178 n <- ns
179 [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ]
180 fmap join $ forM r $ \(ns,gw) -> do
181 let ts = tcps ns
182 {-
183 if nodeId gw == nodeId dst
184 then return $ Just ts
185 else do
186 forkIO $ void $ tcpPing (tcpClient tcp) dst
187 return $ Just ts
188 -}
189 forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp))
190 return $ Just ts
191-}
192
193getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
194getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst
195
196getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
197getUDPNodes' tcp seeking dst0 = do
198 mgateway <- atomically $ tcpGetGateway tcp dst0
199 fmap join $ forM mgateway $ \gateway -> do
200 (b,c,n24) <- atomically $ do
201 b <- transportNewKey (tcpCrypto tcp)
202 c <- transportNewKey (tcpCrypto tcp)
203 n24 <- transportNewNonce (tcpCrypto tcp)
204 return (b,c,n24)
205 let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway
206 then ( dst0 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }
207 , gateway { udpNodeInfo = (udpNodeInfo gateway)
208 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }})
209 else (dst0,gateway)
210 wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst)
211 wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway)
212 wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst)
213 let meth :: MethodSerializer
214 Nonce8
215 a -- NodeInfo
216 (Bool, RelayPacket)
217 PacketNumber
218 AnnounceRequest
219 (Either String AnnounceResponse)
220 meth = MethodSerializer
221 { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout
222 , method = OnionPacketID -- meth
223 , wrapQuery = \n8 src gateway x -> (,) True $
224 OnionPacket n24 $ Addressed (UDP.nodeAddr dst)
225 $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway')
226 $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst)
227 $ NotForwarded $ encryptPayload (wrap0 n24)
228 $ OnionAnnounce Asymm
229 { senderKey = transportPublic (tcpCrypto tcp)
230 , asymmNonce = n24
231 , asymmData = pure (x,n8)
232 }
233 , unwrapResponse = \case
234 (_,OnionPacketResponse (OnionAnnounceResponse _ n24' r))
235 -> decrypt (wrap0 n24') r >>= decodePlain
236 x -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x
237 }
238 r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway
239 forM r $ \response -> do
240 let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response
241 return ( (ns,ns, const () <$> mb), gateway )
242
243
244handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
245handleOOB k bs src dst = do
246 dput XMisc $ "TODO: handleOOB " ++ show src
247 return Nothing
248
249handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
250handle2route o src dst = do
251 dput XMisc $ "TODO: handle2route " ++ show src
252 return Nothing
253
254tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ())
255tcpPing client dst = do
256 dput XTCP $ "tcpPing " ++ show dst
257 sendQuery client meth () dst
258 where meth = MethodSerializer
259 { wrapQuery = \n8 src dst () -> (True,RelayPing n8)
260 , unwrapResponse = \_ -> ()
261 , methodTimeout = \n8 dst -> return (dst,5000000)
262 , method = PingPacket
263 }
264
265type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
266
267-- | Create a new TCP relay client. Because polymorphic existential record
268-- updates are currently hard with GHC, this function accepts parameters for
269-- generalizing the table-entry type for pending transactions. Safe trivial
270-- defaults are 'id' and 'tryPutMVar'. The resulting customized table state
271-- will be returned to the caller along with the new client.
272newClient :: TransportCrypto
273 -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query
274 -> (a -> RelayPacket -> IO void) -- ^ load mvar for query
275 -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
276 , TCPCache (SessionProtocol RelayPacket RelayPacket) )
277 , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket))
278newClient crypto store load = do
279 (tcpcache,net) <- toxTCP crypto
280 drg <- drgNew
281 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
282 return $ (,) (map_var,tcpcache) Client
283 { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
284 , clientDispatcher = DispatchMethods
285 { classifyInbound = (. snd) $ \case
286 RelayPing n -> IsQuery PingPacket n
287 RelayPong n -> IsResponse n
288 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
289 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
290 OOBRecv k bs -> IsUnsolicited $ handleOOB k bs
291 wut -> IsUnknown (show wut)
292 , lookupHandler = \case
293 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler
294 { methodParse = \case (_,RelayPing n8) -> Right ()
295 _ -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?"
296 , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8)
297 , methodAction = \src () -> dput XTCP $ "TCP pinged by "++show src
298 }
299 w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply
300 { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a
301 , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w
302 }
303 , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
304 $ first (either error Nonce8 . decode) . randomBytesGenerate 8
305 }
306 , clientErrorReporter = logErrors
307 , clientPending = map_var
308 , clientAddress = \_ -> return $ NodeInfo
309 { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0)
310 , tcpPort = 0
311 }
312 , clientResponseId = return
313 }
diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs
deleted file mode 100644
index 217d5b1d..00000000
--- a/src/Network/Tox/Transport.hs
+++ /dev/null
@@ -1,86 +0,0 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TypeOperators #-}
9module Network.Tox.Transport (toxTransport, RouteId) where
10
11import Network.QueryResponse
12import Crypto.Tox
13import Data.Tox.Relay as TCP
14import Network.Tox.DHT.Transport as UDP
15import Network.Tox.Onion.Transport
16import Network.Tox.Crypto.Transport
17import OnionRouter
18
19import Network.Socket
20
21toxTransport ::
22 TransportCrypto
23 -> OnionRouter
24 -> (PublicKey -> IO (Maybe UDP.NodeInfo))
25 -> UDPTransport
26 -> (TCP.NodeInfo -> RelayPacket -> IO ()) -- ^ TCP server-bound callback.
27 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP client-bound callback.
28 -> IO ( Transport String SockAddr (CryptoPacket Encrypted)
29 , Transport String UDP.NodeInfo (DHTMessage Encrypted8)
30 , Transport String (OnionDestination RouteId) (OnionMessage Encrypted)
31 , Transport String AnnouncedRendezvous (PublicKey,OnionData)
32 , Transport String SockAddr (Handshake Encrypted))
33toxTransport crypto orouter closeLookup udp tcp2server tcp2client = do
34 (netcrypto, udp0) <- partitionTransport parseCrypto encodeCrypto udp
35 (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr)
36 $ forwardOnions crypto udp0 tcp2client
37 (onion1,udp2) <- partitionAndForkTransport tcp2server
38 (parseOnionAddr $ lookupSender orouter)
39 (encodeOnionAddr crypto $ lookupRoute orouter)
40 udp1
41 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1
42 let handshakes = layerTransport parseHandshakes encodeHandshakes udp2
43 return ( netcrypto
44 , forwardDHTRequests crypto closeLookup dht
45 , onion
46 , dta
47 , handshakes
48 )
49
50
51-- instance (Sized a, Sized b) => Sized (a,b) where size = _todo
52
53
54-- Byte value Packet Kind Return address
55-- :----------- :--------------------
56-- `0x00` Ping Request DHTNode
57-- `0x01` Ping Response -
58-- `0x02` Nodes Request DHTNode
59-- `0x04` Nodes Response -
60-- `0x18` Cookie Request DHTNode, but without sending pubkey in response
61-- `0x19` Cookie Response - (no pubkey)
62--
63-- `0x21` LAN Discovery DHTNode (No reply, port 33445, trigger Nodes Request/Response)
64--
65-- `0x20` DHT Request DHTNode/-forward
66--
67-- `0x1a` Crypto Handshake CookieAddress
68--
69-- `0x1b` Crypto Data SessionAddress
70--
71-- `0x83` Announce Request OnionToOwner
72-- `0x84` Announce Response -
73-- `0x85` Onion Data Request OnionToOwner
74-- `0x86` Onion Data Response -
75--
76-- `0xf0` Bootstrap Info SockAddr?
77--
78-- `0x80` Onion Request 0 -forward
79-- `0x81` Onion Request 1 -forward
80-- `0x82` Onion Request 2 -forward
81-- `0x8c` Onion Response 3 -return
82-- `0x8d` Onion Response 2 -return
83-- `0x8e` Onion Response 1 -return
84
85
86
diff --git a/src/Network/UPNP.hs b/src/Network/UPNP.hs
deleted file mode 100644
index 01d222bf..00000000
--- a/src/Network/UPNP.hs
+++ /dev/null
@@ -1,40 +0,0 @@
1module Network.UPNP where
2
3import Data.Maybe
4import Network.Address (sockAddrPort)
5import Network.Socket
6import System.Directory
7import System.Process as Process
8import DPut
9import DebugTag
10
11protocols :: SocketType -> [String]
12protocols Stream = ["tcp"]
13protocols Datagram = ["udp"]
14protocols _ = ["udp","tcp"]
15
16upnpc :: FilePath
17upnpc = "/usr/bin/upnpc"
18
19-- | Invokes the miniupnpc command line program to request ports from a UPNP
20-- wifi router. Returns the process handle on success.
21requestPorts :: String -- ^ Description stored on router.
22 -> [(SocketType, SockAddr)] -- ^ Protocol-port pairs to request.
23 -> IO (Maybe ProcessHandle)
24requestPorts description binds = do
25 let requests = do
26 (stype,saddr) <- binds
27 proto <- protocols stype
28 port <- maybeToList (sockAddrPort saddr)
29 [ show port, proto ]
30 bail = return Nothing
31 case requests of
32 [] -> bail
33 _ -> do
34 gotMiniUPNPC <- doesFileExist upnpc
35 if gotMiniUPNPC then do
36 phandle <- spawnProcess upnpc $ "-e": description : "-r" : requests
37 return $ Just phandle
38 else do
39 dput XMisc $ "Warning: unable to find miniupnpc client at "++upnpc++"."
40 bail
diff --git a/src/StaticAssert.hs b/src/StaticAssert.hs
deleted file mode 100644
index d0784c97..00000000
--- a/src/StaticAssert.hs
+++ /dev/null
@@ -1,13 +0,0 @@
1module StaticAssert where
2
3import Network.Socket (htonl)
4import Language.Haskell.TH
5
6staticAssert :: Bool -> Q [Dec]
7staticAssert cond = case cond of
8 True -> return []
9 False -> fail "staticAssert failed"
10
11isLittleEndian :: Bool
12isLittleEndian = htonl 0x01000000 == 1
13
diff --git a/src/System/Global6.hs b/src/System/Global6.hs
deleted file mode 100644
index 38a90a59..00000000
--- a/src/System/Global6.hs
+++ /dev/null
@@ -1,53 +0,0 @@
1{-# LANGUAGE CPP #-}
2module System.Global6 where
3
4import Control.Monad
5import Control.Applicative
6#if MIN_VERSION_iproute(1,7,4)
7import Data.IP hiding (fromSockAddr)
8#else
9import Data.IP
10#endif
11import Data.List
12import Data.Maybe
13import System.Process
14import Text.Read
15
16parseIpAddr :: String -> Maybe IPv6
17parseIpAddr s = do
18 let ws = words s
19 (addr,bs) = splitAt 1 $ drop 1 $ dropWhile (/= "inet6") ws
20 guard ("global" `elem` bs)
21 addr <- listToMaybe addr
22 guard (not $ isPrefixOf "fd" addr)
23 guard (not $ isPrefixOf "fc" addr)
24 let (addr',slash) = break (=='/') addr
25 ip6 <- readMaybe addr'
26 return $ (ip6 :: IPv6)
27
28
29global6 :: IO (Maybe IPv6)
30global6 = do
31 addrs <- lines <$> readProcess "ip" ["-o","-6","addr"] ""
32 return $ foldr1 mplus $ map parseIpAddr addrs
33
34
35everyOther :: [a] -> [a]
36everyOther (x:_:xs) = x : everyOther xs
37everyOther xs = xs
38
39
40-- | Obtain all available IP broadcast addresses (in dotted quad or IPv6 colon
41-- format) as Strings.
42broadcastAddrs :: IO [String]
43broadcastAddrs = parseBroadcastAddrs <$> readProcess "ip" ["-o","addr"] ""
44
45parseBroadcastAddrs :: String -> [String]
46parseBroadcastAddrs ipoutput = brds
47 where
48 brds = mapMaybe getbrd as
49 assoclist ws = zip (everyOther ws) (everyOther $ drop 1 ws)
50 as = map (assoclist . drop 2 . words) $ lines ipoutput
51 getbrd alist = do
52 ip <- lookup "inet" alist <|> lookup "inet6" alist
53 lookup "brd" alist
diff --git a/src/Text/XXD.hs b/src/Text/XXD.hs
deleted file mode 100644
index 77606bfa..00000000
--- a/src/Text/XXD.hs
+++ /dev/null
@@ -1,48 +0,0 @@
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE ScopedTypeVariables #-}
3module Text.XXD (xxd, xxd2) where
4
5import Data.ByteArray (ByteArrayAccess)
6import qualified Data.ByteArray as BA
7import Data.Word
8import Data.Bits
9import Data.Char
10import Text.Printf
11
12nibble :: Word8 -> Char
13nibble b = intToDigit (fromIntegral (b .&. 0x0F))
14
15nibbles :: ByteArrayAccess ba => ba -> String
16nibbles xs = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte])
17 $ BA.unpack xs
18
19xxd0 :: (ByteArrayAccess ba) => (forall b. ByteArrayAccess b => b -> String) -> Int -> ba -> [String]
20xxd0 tr offset bs | BA.null bs = []
21xxd0 tr offset bs = printf "%03x: %s%s" offset (nibbles xs) (tr xs)
22 : xxd0 tr (offset + BA.length xs) bs'
23 where
24 (xs,bs') = splitAtView 16 bs
25
26splitAtView :: (ByteArrayAccess ba) => Int -> ba -> (BA.View ba, BA.View ba)
27splitAtView n bs = (BA.takeView bs n, BA.dropView bs n)
28
29xxd :: ByteArrayAccess a => Int -> a -> [String]
30xxd = xxd0 (const "")
31
32-- | like xxd, but also shows ascii
33xxd2 :: ByteArrayAccess a => Int -> a -> [String]
34xxd2 = xxd0 withAscii
35
36withAscii :: ByteArrayAccess a => a -> [Char]
37withAscii row = replicate (50 - 3 * BA.length row) ' ' ++ myunpack row
38 where
39 myunpack s = map word8tochar (BA.unpack s)
40 where word8tochar w | (w .&. 0x80 /= 0) = '.'
41 word8tochar w = let c = chr (fromIntegral w)
42 in if isPrint c then c else '.'
43
44{-
45main = do
46 bs <- B.getContents
47 mapM_ putStrLn $ xxd2 0 bs
48 -}
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 17:40:25 +0000