diff options
Diffstat (limited to 'src/Network')
-rw-r--r-- | src/Network/BitTorrent/DHT.hs | 1 | ||||
-rw-r--r-- | src/Network/BitTorrent/DHT/Query.hs | 18 | ||||
-rw-r--r-- | src/Network/DHT/Mainline.hs | 7 | ||||
-rw-r--r-- | src/Network/DHT/Tox.hs | 112 | ||||
-rw-r--r-- | src/Network/DHT/Types.hs | 93 | ||||
-rw-r--r-- | src/Network/DatagramServer.hs | 11 | ||||
-rw-r--r-- | src/Network/DatagramServer/Tox.hs | 125 | ||||
-rw-r--r-- | src/Network/KRPC/Method.hs | 73 |
8 files changed, 333 insertions, 107 deletions
diff --git a/src/Network/BitTorrent/DHT.hs b/src/Network/BitTorrent/DHT.hs index 2535c05c..b130e727 100644 --- a/src/Network/BitTorrent/DHT.hs +++ b/src/Network/BitTorrent/DHT.hs | |||
@@ -82,7 +82,6 @@ import Data.Bits | |||
82 | import Data.Default | 82 | import Data.Default |
83 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) | 83 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) |
84 | import Network.KRPC.Method | 84 | import Network.KRPC.Method |
85 | import Network.BitTorrent.DHT.Query (DataHandlers) | ||
86 | 85 | ||
87 | {----------------------------------------------------------------------- | 86 | {----------------------------------------------------------------------- |
88 | -- DHT types | 87 | -- DHT types |
diff --git a/src/Network/BitTorrent/DHT/Query.hs b/src/Network/BitTorrent/DHT/Query.hs index 60b772b3..003bb5b9 100644 --- a/src/Network/BitTorrent/DHT/Query.hs +++ b/src/Network/BitTorrent/DHT/Query.hs | |||
@@ -27,7 +27,6 @@ module Network.BitTorrent.DHT.Query | |||
27 | , getPeersH | 27 | , getPeersH |
28 | , announceH | 28 | , announceH |
29 | , defaultHandlers | 29 | , defaultHandlers |
30 | , DataHandlers | ||
31 | 30 | ||
32 | -- * Query | 31 | -- * Query |
33 | -- ** Basic | 32 | -- ** Basic |
@@ -89,6 +88,8 @@ import Text.PrettyPrint.HughesPJClass hiding ((<>),($$)) | |||
89 | import Data.Time | 88 | import Data.Time |
90 | import Data.Time.Clock.POSIX | 89 | import Data.Time.Clock.POSIX |
91 | import Data.Hashable (Hashable) | 90 | import Data.Hashable (Hashable) |
91 | import Data.Serialize | ||
92 | import Data.Hashable | ||
92 | 93 | ||
93 | import Network.DatagramServer as KRPC hiding (Options, def) | 94 | import Network.DatagramServer as KRPC hiding (Options, def) |
94 | import Network.KRPC.Method as KRPC | 95 | import Network.KRPC.Method as KRPC |
@@ -143,7 +144,7 @@ nodeHandler :: forall raw dht addr u t q r. | |||
143 | -> QueryMethod dht | 144 | -> QueryMethod dht |
144 | -> (NodeAddr addr -> q -> IO r) | 145 | -> (NodeAddr addr -> q -> IO r) |
145 | -> Handler IO dht raw | 146 | -> Handler IO dht raw |
146 | nodeHandler insertNode myNodeIdAccordingTo logm dta method action = handler method $ \ sockAddr msg -> do | 147 | nodeHandler insertNode myNodeIdAccordingTo logm dta method action = handler (\sockaddr -> myNodeIdAccordingTo (error "todo")) method $ \ sockAddr msg -> do |
147 | let remoteId = messageSender (msg :: dht (Query dht q)) resptype | 148 | let remoteId = messageSender (msg :: dht (Query dht q)) resptype |
148 | qextra = queryExtra qry | 149 | qextra = queryExtra qry |
149 | resptype = Proxy :: Proxy (Response dht r) | 150 | resptype = Proxy :: Proxy (Response dht r) |
@@ -229,14 +230,6 @@ kademliaHandlers logger = do | |||
229 | , handler (nameFindNodes dht) $ findNodeH getclosest | 230 | , handler (nameFindNodes dht) $ findNodeH getclosest |
230 | ] | 231 | ] |
231 | 232 | ||
232 | class DataHandlers raw dht where | ||
233 | dataHandlers :: | ||
234 | ( Ord ip , Hashable ip, Typeable ip, Serialize ip) => | ||
235 | (NodeId dht -> IO [NodeInfo dht ip ()]) | ||
236 | -> DHTData dht ip | ||
237 | -> [MethodHandler raw dht ip] | ||
238 | dataHandlers _ _ = [] | ||
239 | |||
240 | instance DataHandlers BValue KMessageOf where | 233 | instance DataHandlers BValue KMessageOf where |
241 | dataHandlers = bthandlers | 234 | dataHandlers = bthandlers |
242 | 235 | ||
@@ -256,11 +249,6 @@ bthandlers getclosest dta = | |||
256 | then Left <$> getclosest (toNodeId ih) | 249 | then Left <$> getclosest (toNodeId ih) |
257 | else return (Right ps) | 250 | else return (Right ps) |
258 | 251 | ||
259 | data MethodHandler raw dht ip = | ||
260 | forall a b. ( SerializableTo raw (Response dht b) | ||
261 | , SerializableTo raw (Query dht a) | ||
262 | , KRPC dht (Query dht a) (Response dht b) | ||
263 | ) => MethodHandler (QueryMethod dht) (NodeAddr ip -> a -> IO b) | ||
264 | 252 | ||
265 | -- | Includes all default query handlers. | 253 | -- | Includes all default query handlers. |
266 | defaultHandlers :: forall raw dht u ip. | 254 | defaultHandlers :: forall raw dht u ip. |
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs index 9af42a6d..bdf9e8b2 100644 --- a/src/Network/DHT/Mainline.hs +++ b/src/Network/DHT/Mainline.hs | |||
@@ -56,6 +56,8 @@ | |||
56 | -- <http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf> | 56 | -- <http://pdos.csail.mit.edu/~petar/papers/maymounkov-kademlia-lncs.pdf> |
57 | -- | 57 | -- |
58 | {-# LANGUAGE CPP #-} | 58 | {-# LANGUAGE CPP #-} |
59 | {-# LANGUAGE StandaloneDeriving #-} | ||
60 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
59 | {-# LANGUAGE DeriveDataTypeable #-} | 61 | {-# LANGUAGE DeriveDataTypeable #-} |
60 | {-# LANGUAGE FlexibleInstances #-} | 62 | {-# LANGUAGE FlexibleInstances #-} |
61 | {-# LANGUAGE MultiParamTypeClasses #-} | 63 | {-# LANGUAGE MultiParamTypeClasses #-} |
@@ -94,6 +96,7 @@ module Network.DHT.Mainline | |||
94 | , checkToken | 96 | , checkToken |
95 | ) where | 97 | ) where |
96 | 98 | ||
99 | import Data.String | ||
97 | import Control.Applicative | 100 | import Control.Applicative |
98 | import Data.Bool | 101 | import Data.Bool |
99 | #ifdef VERSION_bencoding | 102 | #ifdef VERSION_bencoding |
@@ -570,3 +573,7 @@ instance Kademlia KMessageOf where | |||
570 | initializeDHTData = TorrentData | 573 | initializeDHTData = TorrentData |
571 | <$> newTVarIO def | 574 | <$> newTVarIO def |
572 | <*> (newTVarIO =<< nullSessionTokens) | 575 | <*> (newTVarIO =<< nullSessionTokens) |
576 | |||
577 | deriving instance IsString (QueryMethod dht) => IsString (Method dht param result) | ||
578 | deriving instance BEncode (QueryMethod dht) => BEncode (Method dht param result) | ||
579 | |||
diff --git a/src/Network/DHT/Tox.hs b/src/Network/DHT/Tox.hs new file mode 100644 index 00000000..d6fc866f --- /dev/null +++ b/src/Network/DHT/Tox.hs | |||
@@ -0,0 +1,112 @@ | |||
1 | {-# LANGUAGE TypeFamilies #-} | ||
2 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} | ||
3 | module Network.DHT.Tox where | ||
4 | |||
5 | import Data.Serialize | ||
6 | import Data.Default | ||
7 | import Text.PrettyPrint.HughesPJClass | ||
8 | |||
9 | import Network.DHT.Types | ||
10 | import Network.DatagramServer.Types | ||
11 | import qualified Network.DatagramServer.Tox as Tox | ||
12 | import Network.KRPC.Method | ||
13 | import Data.Word | ||
14 | import Data.ByteString (ByteString) | ||
15 | import Data.IP | ||
16 | import Data.Bool | ||
17 | import Data.Maybe | ||
18 | import Control.Monad | ||
19 | import System.Random | ||
20 | |||
21 | instance Kademlia Tox.Message where | ||
22 | data DHTData Tox.Message ip = ToxData | ||
23 | namePing _ = Tox.Ping | ||
24 | nameFindNodes _ = Tox.GetNodes | ||
25 | initializeDHTData = return ToxData | ||
26 | |||
27 | instance Pretty (NodeId Tox.Message) where | ||
28 | pPrint (Tox.NodeId nid) = encodeHexDoc nid | ||
29 | |||
30 | instance Serialize (Query Tox.Message (Ping Tox.Message)) where | ||
31 | get = getToxPing False Network.DHT.Types.Query Tox.QueryNonce | ||
32 | put (Network.DHT.Types.Query extra Ping) = putToxPing False (Tox.qryNonce extra) | ||
33 | instance Serialize (Response Tox.Message (Ping Tox.Message)) where | ||
34 | get = getToxPing True Network.DHT.Types.Response Tox.ResponseNonce | ||
35 | put (Network.DHT.Types.Response extra Ping) = putToxPing True (Tox.rspNonce extra) | ||
36 | |||
37 | instance Serialize (Query Tox.Message (FindNode Tox.Message ip)) where | ||
38 | get = do | ||
39 | nid <- get | ||
40 | n8 <- get | ||
41 | return $ Network.DHT.Types.Query (Tox.QueryNonce n8) (FindNode nid) | ||
42 | put (Network.DHT.Types.Query (Tox.QueryNonce n8) (FindNode nid)) = do | ||
43 | put nid | ||
44 | put n8 | ||
45 | instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
46 | get = do | ||
47 | num <- get :: Get Word8 | ||
48 | when (num > 4) $ fail "Too many nodes in Tox get-nodes reply" | ||
49 | ns0 <- sequence $ replicate (fromIntegral num) (nodeFormatToNodeInfo <$> get) | ||
50 | -- TODO: Allow tcp and ipv6. For now filtering to udp ip4... | ||
51 | let ns = flip mapMaybe ns0 $ \(NodeInfo nid addr u) -> do | ||
52 | guard $ not u | ||
53 | ip4 <- fromAddr addr | ||
54 | return $ NodeInfo nid ip4 () | ||
55 | n8 <- get | ||
56 | return $ Network.DHT.Types.Response (Tox.ResponseNonce n8) $ NodeFound ns | ||
57 | put (Network.DHT.Types.Response (Tox.ResponseNonce n8) (NodeFound ns)) = do | ||
58 | put ( fromIntegral (length ns) :: Word8 ) | ||
59 | forM_ ns $ \(NodeInfo nid ip4 ()) -> do | ||
60 | put Tox.NodeFormat { nodePublicKey = nid | ||
61 | , nodeIsTCP = False | ||
62 | , nodeIP = IPv4 (nodeHost ip4) | ||
63 | , nodePort = nodePort ip4 | ||
64 | } | ||
65 | put n8 | ||
66 | |||
67 | instance KRPC Tox.Message (Query Tox.Message (FindNode Tox.Message IPv4)) | ||
68 | (Response Tox.Message (NodeFound Tox.Message IPv4)) where | ||
69 | method = Method Tox.GetNodes | ||
70 | validateExchange = validateToxExchange | ||
71 | makeQueryExtra _ _ _ _ = Tox.QueryNonce <$> randomIO | ||
72 | makeResponseExtra _ _ q _ = return $ Tox.ResponseNonce $ Tox.qryNonce $ queryExtra q | ||
73 | messageSender q _ = Tox.msgClient q | ||
74 | messageResponder _ r = Tox.msgClient r | ||
75 | |||
76 | instance KRPC Tox.Message (Query Tox.Message (Ping Tox.Message)) | ||
77 | (Response Tox.Message (Ping Tox.Message)) where | ||
78 | method = Method Tox.Ping | ||
79 | validateExchange = validateToxExchange | ||
80 | makeQueryExtra _ _ _ _ = Tox.QueryNonce <$> randomIO | ||
81 | makeResponseExtra _ _ q _ = return $ Tox.ResponseNonce $ Tox.qryNonce $ queryExtra q | ||
82 | messageSender q _ = Tox.msgClient q | ||
83 | messageResponder _ r = Tox.msgClient r | ||
84 | |||
85 | instance DataHandlers ByteString Tox.Message | ||
86 | |||
87 | instance Default Bool where def = False | ||
88 | |||
89 | getToxPing isPong c n = do | ||
90 | q'r <- get :: Get Word8 | ||
91 | when (bool 0 1 isPong /= q'r) $ | ||
92 | fail "Tox ping/pong parse fail." | ||
93 | n8 <- get :: Get Tox.Nonce8 | ||
94 | return $ c (n n8) Ping | ||
95 | |||
96 | putToxPing isPong n8 = do | ||
97 | put (bool 0 1 isPong :: Word8) | ||
98 | put n8 | ||
99 | |||
100 | validateToxExchange q r = qnonce == rnonce | ||
101 | where | ||
102 | qnonce = Tox.qryNonce . queryExtra . Tox.msgPayload $ q | ||
103 | rnonce = Tox.rspNonce . responseExtra . Tox.msgPayload $ r | ||
104 | |||
105 | |||
106 | nodeFormatToNodeInfo nf = NodeInfo nid addr u | ||
107 | where | ||
108 | u = Tox.nodeIsTCP nf | ||
109 | addr = NodeAddr (Tox.nodeIP nf) (Tox.nodePort nf) | ||
110 | nid = Tox.nodePublicKey nf | ||
111 | |||
112 | -- instance Default Bool where def = False | ||
diff --git a/src/Network/DHT/Types.hs b/src/Network/DHT/Types.hs index 47f98ebe..287d5680 100644 --- a/src/Network/DHT/Types.hs +++ b/src/Network/DHT/Types.hs | |||
@@ -1,3 +1,6 @@ | |||
1 | {-# LANGUAGE DefaultSignatures #-} | ||
2 | {-# LANGUAGE GADTs, MultiParamTypeClasses #-} | ||
3 | {-# LANGUAGE FunctionalDependencies #-} | ||
1 | {-# LANGUAGE TypeFamilies #-} | 4 | {-# LANGUAGE TypeFamilies #-} |
2 | {-# LANGUAGE ScopedTypeVariables #-} | 5 | {-# LANGUAGE ScopedTypeVariables #-} |
3 | {-# LANGUAGE StandaloneDeriving #-} | 6 | {-# LANGUAGE StandaloneDeriving #-} |
@@ -14,6 +17,11 @@ import Network.DatagramServer.Types | |||
14 | import Network.DHT.Routing | 17 | import Network.DHT.Routing |
15 | import Data.Typeable | 18 | import Data.Typeable |
16 | import GHC.Generics | 19 | import GHC.Generics |
20 | import Data.Serialize | ||
21 | import Data.Hashable | ||
22 | import Data.String | ||
23 | import Data.Monoid | ||
24 | import Data.Char | ||
17 | 25 | ||
18 | data TableParameters msg ip u = TableParameters | 26 | data TableParameters msg ip u = TableParameters |
19 | { maxBuckets :: Int | 27 | { maxBuckets :: Int |
@@ -81,3 +89,88 @@ class Kademlia dht where | |||
81 | namePing :: Proxy dht -> QueryMethod dht | 89 | namePing :: Proxy dht -> QueryMethod dht |
82 | nameFindNodes :: Proxy dht -> QueryMethod dht | 90 | nameFindNodes :: Proxy dht -> QueryMethod dht |
83 | initializeDHTData :: IO (DHTData dht ip) | 91 | initializeDHTData :: IO (DHTData dht ip) |
92 | data MethodHandler raw dht ip = | ||
93 | forall a b. ( SerializableTo raw (Response dht b) | ||
94 | , SerializableTo raw (Query dht a) | ||
95 | , KRPC dht (Query dht a) (Response dht b) | ||
96 | ) => MethodHandler (QueryMethod dht) (NodeAddr ip -> a -> IO b) | ||
97 | |||
98 | class DataHandlers raw dht where | ||
99 | dataHandlers :: | ||
100 | ( Ord ip , Hashable ip, Typeable ip, Serialize ip) => | ||
101 | (NodeId dht -> IO [NodeInfo dht ip ()]) | ||
102 | -> DHTData dht ip | ||
103 | -> [MethodHandler raw dht ip] | ||
104 | dataHandlers _ _ = [] | ||
105 | |||
106 | -- | Method datatype used to describe method name, parameters and | ||
107 | -- return values of procedure. Client use a method to /invoke/, server | ||
108 | -- /implements/ the method to make the actual work. | ||
109 | -- | ||
110 | -- We use the following fantom types to ensure type-safiety: | ||
111 | -- | ||
112 | -- * param: Type of method parameters. | ||
113 | -- | ||
114 | -- * result: Type of return value of the method. | ||
115 | -- | ||
116 | newtype Method dht param result = Method { methodName :: QueryMethod dht } | ||
117 | |||
118 | deriving instance Eq (QueryMethod dht) => Eq (Method dht param result) | ||
119 | deriving instance Ord (QueryMethod dht) => Ord (Method dht param result) | ||
120 | |||
121 | -- | Example: | ||
122 | -- | ||
123 | -- @show (Method \"concat\" :: [Int] Int) == \"concat :: [Int] -> Int\"@ | ||
124 | -- | ||
125 | instance (Show (QueryMethod dht), Typeable a, Typeable b) => Show (Method dht a b) where | ||
126 | showsPrec _ = showsMethod | ||
127 | |||
128 | showsMethod :: forall dht a b. ( Show (QueryMethod dht), Typeable a , Typeable b ) => Method dht a b -> ShowS | ||
129 | showsMethod (Method name) = | ||
130 | -- showString (BC.unpack name) <> | ||
131 | shows (show name) <> | ||
132 | showString " :: " <> | ||
133 | shows paramsTy <> | ||
134 | showString " -> " <> | ||
135 | shows valuesTy | ||
136 | where | ||
137 | impossible = error "KRPC.showsMethod: impossible" | ||
138 | paramsTy = typeOf (impossible :: a) | ||
139 | valuesTy = typeOf (impossible :: b) | ||
140 | |||
141 | -- | In order to perform or handle KRPC query you need to provide | ||
142 | -- corresponding 'KRPC' class. | ||
143 | -- | ||
144 | -- Example: | ||
145 | -- | ||
146 | -- @ | ||
147 | -- data Ping = Ping Text deriving BEncode | ||
148 | -- data Pong = Pong Text deriving BEncode | ||
149 | -- | ||
150 | -- instance 'KRPC' Ping Pong where | ||
151 | -- method = \"ping\" | ||
152 | -- @ | ||
153 | -- | ||
154 | class ( Typeable req, Typeable resp, Envelope dht) | ||
155 | => KRPC dht req resp | req -> resp, resp -> req where | ||
156 | |||
157 | -- | Method name. Default implementation uses lowercased @req@ | ||
158 | -- datatype name. | ||
159 | -- | ||
160 | method :: Method dht req resp | ||
161 | |||
162 | -- TODO add underscores | ||
163 | default method :: (IsString (QueryMethod dht), Typeable req) => Method dht req resp | ||
164 | method = Method $ fromString $ map toLower $ show $ typeOf hole | ||
165 | where | ||
166 | hole = error "krpc.method: impossible" :: req | ||
167 | |||
168 | |||
169 | validateExchange :: dht req -> dht resp -> Bool | ||
170 | validateExchange _ _ = True | ||
171 | |||
172 | makeQueryExtra :: DHTData dht ip -> NodeId dht -> Proxy req -> Proxy resp -> IO (QueryExtra dht) | ||
173 | makeResponseExtra :: DHTData dht ip -> NodeId dht -> req -> Proxy resp -> IO (ResponseExtra dht) | ||
174 | |||
175 | messageSender :: dht req -> Proxy resp -> NodeId dht | ||
176 | messageResponder :: Proxy req -> dht resp -> NodeId dht | ||
diff --git a/src/Network/DatagramServer.hs b/src/Network/DatagramServer.hs index bcf8b9af..55a26e58 100644 --- a/src/Network/DatagramServer.hs +++ b/src/Network/DatagramServer.hs | |||
@@ -451,14 +451,15 @@ prettyQF e = T.encodeUtf8 $ "handler fail while performing query: " | |||
451 | -- corresponding 'QueryFailure's. | 451 | -- corresponding 'QueryFailure's. |
452 | -- | 452 | -- |
453 | handler :: forall h a b msg raw. (Applicative h, Functor msg, WireFormat raw msg, SerializableTo raw a, SerializableTo raw b) | 453 | handler :: forall h a b msg raw. (Applicative h, Functor msg, WireFormat raw msg, SerializableTo raw a, SerializableTo raw b) |
454 | => QueryMethod msg -> (SockAddr -> msg a -> h b) -> Handler h msg raw | 454 | => (SockAddr -> h (NodeId msg)) -> QueryMethod msg -> (SockAddr -> msg a -> h b) -> Handler h msg raw |
455 | handler name body = (name, wrapper) | 455 | handler whoami name body = (name, wrapper) |
456 | where | 456 | where |
457 | wrapper :: SockAddr -> msg raw -> h (Either String (msg raw)) | 457 | wrapper :: SockAddr -> msg raw -> h (Either String (msg raw)) |
458 | wrapper addr args = | 458 | wrapper addr args = |
459 | case decodePayload args of | 459 | case decodePayload args of |
460 | Left e -> pure $ Left e | 460 | Left e -> pure $ Left e |
461 | Right a -> Right . encodePayload . buildReply (error "self node-id") addr args <$> body addr a | 461 | Right a -> do |
462 | (\me bs -> Right $ encodePayload $ buildReply me addr args bs) <$> whoami addr <*> body addr a | ||
462 | 463 | ||
463 | runHandler :: ( Envelope msg | 464 | runHandler :: ( Envelope msg |
464 | , Show (QueryMethod msg) | 465 | , Show (QueryMethod msg) |
@@ -528,8 +529,8 @@ handleQuery :: ( WireFormat raw msg | |||
528 | handleQuery mgr@Manager{..} hs meth raw q addr = void $ fork $ do | 529 | handleQuery mgr@Manager{..} hs meth raw q addr = void $ fork $ do |
529 | myThreadId >>= liftIO . flip labelThread "KRPC.handleQuery" | 530 | myThreadId >>= liftIO . flip labelThread "KRPC.handleQuery" |
530 | res <- dispatchHandler mgr hs meth q addr | 531 | res <- dispatchHandler mgr hs meth q addr |
532 | (me,ctx) <- serverState (error "TODO TOX ToxCipherContext 2 or () for Mainline") | ||
531 | let res' = either buildError Just res | 533 | let res' = either buildError Just res |
532 | ctx = error "TODO TOX ToxCipherContext 2 or () for Mainline" | ||
533 | dest = makeAddress (Right q) addr | 534 | dest = makeAddress (Right q) addr |
534 | resbs = fmap (\raw -> encodeHeaders ctx raw dest) res' :: Maybe BS.ByteString | 535 | resbs = fmap (\raw -> encodeHeaders ctx raw dest) res' :: Maybe BS.ByteString |
535 | -- TODO: Generalize this debug print. | 536 | -- TODO: Generalize this debug print. |
@@ -565,7 +566,7 @@ listener :: forall raw msg. | |||
565 | ) => Manager raw msg -> [Handler IO msg raw] -> Protocol raw msg -> IO () | 566 | ) => Manager raw msg -> [Handler IO msg raw] -> Protocol raw msg -> IO () |
566 | listener mgr@Manager{..} hs p = do | 567 | listener mgr@Manager{..} hs p = do |
567 | fix $ \again -> do | 568 | fix $ \again -> do |
568 | let ctx = error "TODO TOX ToxCipherContext or () for Mainline" | 569 | (me, ctx) <- serverState (error "TODO TOX ToxCipherContext or () for Mainline") |
569 | (bs, addr) <- liftIO $ do | 570 | (bs, addr) <- liftIO $ do |
570 | handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) | 571 | handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) |
571 | case parsePacket (msgProxy p) bs >>= \r -> (,) r <$> decodeHeaders ctx r of | 572 | case parsePacket (msgProxy p) bs >>= \r -> (,) r <$> decodeHeaders ctx r of |
diff --git a/src/Network/DatagramServer/Tox.hs b/src/Network/DatagramServer/Tox.hs index 5003f3a4..9d60d066 100644 --- a/src/Network/DatagramServer/Tox.hs +++ b/src/Network/DatagramServer/Tox.hs | |||
@@ -51,6 +51,10 @@ import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) | |||
51 | import qualified Data.ByteArray as BA | 51 | import qualified Data.ByteArray as BA |
52 | import Data.ByteArray ( Bytes, convert ) | 52 | import Data.ByteArray ( Bytes, convert ) |
53 | import Data.Monoid | 53 | import Data.Monoid |
54 | import System.Endian | ||
55 | import qualified Data.ByteString.Base16 as Base16 | ||
56 | import qualified Data.ByteString.Char8 as C8 | ||
57 | import qualified Data.ByteString.Char8 as C8 | ||
54 | 58 | ||
55 | 59 | ||
56 | type Key32 = Word256 -- 32 byte key | 60 | type Key32 = Word256 -- 32 byte key |
@@ -119,9 +123,14 @@ data Message a = Message | |||
119 | , msgNonce :: TransactionID Message | 123 | , msgNonce :: TransactionID Message |
120 | , msgPayload :: a | 124 | , msgPayload :: a |
121 | } | 125 | } |
122 | deriving (Show, Generic, Functor, Foldable, Traversable) | 126 | deriving (Eq, Show, Generic, Functor, Foldable, Traversable) |
123 | 127 | ||
124 | deriving instance Show (NodeId Message) -- TODO: print as hex | 128 | instance Show (NodeId Message) where |
129 | showsPrec d pubkey s = | ||
130 | "NodeId \"" ++ C8.unpack (Base16.encode $ convert pubkey) ++ '"':s | ||
131 | |||
132 | instance Show (TransactionID Message) where | ||
133 | showsPrec d nonce = mappend "TID " . quoted (mappend $ bin2hex nonce) | ||
125 | 134 | ||
126 | isQuery :: Message a -> Bool | 135 | isQuery :: Message a -> Bool |
127 | isQuery (Message { msgType = SendNodes }) = False | 136 | isQuery (Message { msgType = SendNodes }) = False |
@@ -231,13 +240,26 @@ data ToxCipherContext = ToxCipherContext | |||
231 | 240 | ||
232 | data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth | 241 | data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth |
233 | , cipheredBytes :: ByteString } | 242 | , cipheredBytes :: ByteString } |
243 | deriving Eq | ||
244 | |||
245 | quoted shows s = '"':shows ('"':s) | ||
246 | |||
247 | bin2hex :: ByteArrayAccess bs => bs -> String | ||
248 | bin2hex = C8.unpack . Base16.encode . convert | ||
249 | |||
250 | instance Show Ciphered where | ||
251 | showsPrec d (Ciphered (Poly1305.Auth mac) bytes) = | ||
252 | mappend "Ciphered (Auth " | ||
253 | . quoted (mappend $ bin2hex mac) | ||
254 | . (") " ++) | ||
255 | . quoted (mappend $ bin2hex bytes) | ||
234 | 256 | ||
235 | getMessage :: Get (Message Ciphered) | 257 | getMessage :: Get (Message Ciphered) |
236 | getMessage = do | 258 | getMessage = do |
237 | typ <- get | 259 | typ <- get |
238 | nid <- get | 260 | nid <- get |
239 | tid <- get | 261 | tid <- get |
240 | mac <- Poly1305.Auth . convert <$> getBytes 2 | 262 | mac <- Poly1305.Auth . convert <$> getBytes 16 |
241 | cnt <- remaining | 263 | cnt <- remaining |
242 | bs <- getBytes cnt | 264 | bs <- getBytes cnt |
243 | return Message { msgType = typ | 265 | return Message { msgType = typ |
@@ -254,11 +276,19 @@ putMessage (Message {..}) = do | |||
254 | putByteString (convert mac) | 276 | putByteString (convert mac) |
255 | putByteString bs | 277 | putByteString bs |
256 | 278 | ||
279 | -- XXX: assumes ByteArray is little-endian | ||
257 | id2key :: NodeId Message -> PublicKey | 280 | id2key :: NodeId Message -> PublicKey |
258 | id2key recipient = case publicKey recipient of | 281 | id2key recipient = case publicKey recipient of |
259 | CryptoPassed key -> key | 282 | CryptoPassed key -> key |
260 | CryptoFailed e -> error ("id2key: "++show e) | 283 | CryptoFailed e -> error ("id2key: "++show e) |
261 | 284 | ||
285 | -- XXX: S.decode is Big-endian | ||
286 | -- TODO: implement ByteArray instance, avoid S.decode | ||
287 | key2id :: PublicKey -> NodeId Message | ||
288 | key2id pk = case S.decode (BA.convert pk) of | ||
289 | Left _ -> error "key2id" | ||
290 | Right nid -> nid | ||
291 | |||
262 | 292 | ||
263 | zeros32 :: Bytes | 293 | zeros32 :: Bytes |
264 | zeros32 = BA.replicate 32 0 | 294 | zeros32 = BA.replicate 32 0 |
@@ -305,6 +335,11 @@ encipherAndHash hash crypt m = Ciphered a c | |||
305 | 335 | ||
306 | decipherAndAuth :: Poly1305.State -> XSalsa.State -> Ciphered -> Either String ByteString | 336 | decipherAndAuth :: Poly1305.State -> XSalsa.State -> Ciphered -> Either String ByteString |
307 | decipherAndAuth hash crypt (Ciphered mac c) | 337 | decipherAndAuth hash crypt (Ciphered mac c) |
338 | {- | ||
339 | | C8.length m /= C8.length c = Left $ "Unequal lengths: "++show (C8.length m, C8.length c) | ||
340 | -- | C8.length c /= 40 = Left $ "Unexpected c length: " ++ show (C8.length c, bin2hex c) | ||
341 | | otherwise = Right m | ||
342 | -} | ||
308 | | (a == mac) = Right m | 343 | | (a == mac) = Right m |
309 | | otherwise = Left "decipherAndAuth: auth fail" | 344 | | otherwise = Left "decipherAndAuth: auth fail" |
310 | where | 345 | where |
@@ -340,14 +375,16 @@ curve25519 = CurveFP (CurvePrime prime curvecommon) | |||
340 | 375 | ||
341 | instance Envelope Message where | 376 | instance Envelope Message where |
342 | newtype TransactionID Message = TID Nonce24 | 377 | newtype TransactionID Message = TID Nonce24 |
343 | deriving (Eq,Ord,Show,Serialize) -- Read | 378 | deriving (Eq,Ord) -- Read |
344 | 379 | ||
345 | newtype NodeId Message = NodeId Word256 | 380 | newtype NodeId Message = NodeId Word256 |
346 | deriving (Serialize, Eq, Ord, Bits, FiniteBits) | 381 | deriving (Eq, Ord, Bits, FiniteBits) |
347 | 382 | ||
348 | type QueryMethod Message = MessageType | 383 | type QueryMethod Message = MessageType |
349 | 384 | ||
350 | newtype QueryExtra Message = QueryNonce { qryNonce :: Nonce8 } | 385 | newtype QueryExtra Message = QueryNonce { qryNonce :: Nonce8 } |
386 | deriving (Eq, Ord, Show) | ||
387 | |||
351 | newtype ResponseExtra Message = ResponseNonce { rspNonce :: Nonce8 } | 388 | newtype ResponseExtra Message = ResponseNonce { rspNonce :: Nonce8 } |
352 | 389 | ||
353 | data PacketDestination Message = ToxAddr { toxID :: NodeId Message | 390 | data PacketDestination Message = ToxAddr { toxID :: NodeId Message |
@@ -381,23 +418,83 @@ instance Envelope Message where | |||
381 | $ S.decode $ Char8.pack (take 24 $ show cnt ++ repeat ' ') | 418 | $ S.decode $ Char8.pack (take 24 $ show cnt ++ repeat ' ') |
382 | 419 | ||
383 | 420 | ||
421 | {- | ||
422 | instance Serialize (TransactionID Message) where | ||
423 | get = do | ||
424 | lo <- getWord64le | ||
425 | mid <- getWord64le | ||
426 | hi <- getWord64le | ||
427 | return $ TID (LargeKey lo | ||
428 | (LargeKey mid hi)) | ||
429 | |||
430 | put (TID (LargeKey lo (LargeKey mid hi))) = do | ||
431 | putWord64le lo | ||
432 | putWord64le mid | ||
433 | putWord64le hi | ||
434 | |||
435 | instance Serialize (NodeId Message) where | ||
436 | get = do | ||
437 | lo <- getWord64le | ||
438 | mid <- getWord64le | ||
439 | hi <- getWord64le | ||
440 | highest <- getWord64le | ||
441 | return $ NodeId (LargeKey lo | ||
442 | (LargeKey mid | ||
443 | (LargeKey hi highest))) | ||
444 | put (NodeId (LargeKey lo (LargeKey mid (LargeKey hi highest)))) = do | ||
445 | putWord64le lo | ||
446 | putWord64le mid | ||
447 | putWord64le hi | ||
448 | putWord64le highest | ||
449 | |||
450 | -} | ||
451 | |||
452 | instance Serialize (TransactionID Message) where | ||
453 | get = do | ||
454 | hi <- getWord64be | ||
455 | mid <- getWord64be | ||
456 | lo <- getWord64be | ||
457 | return $ TID (LargeKey lo | ||
458 | (LargeKey mid hi)) | ||
459 | |||
460 | put (TID (LargeKey lo (LargeKey mid hi))) = do | ||
461 | putWord64be hi | ||
462 | putWord64be mid | ||
463 | putWord64be lo | ||
464 | |||
465 | instance Serialize (NodeId Message) where | ||
466 | get = do | ||
467 | highest <- getWord64be | ||
468 | hi <- getWord64be | ||
469 | mid <- getWord64be | ||
470 | lo <- getWord64be | ||
471 | return $ NodeId (LargeKey lo | ||
472 | (LargeKey mid | ||
473 | (LargeKey hi highest))) | ||
474 | put (NodeId (LargeKey lo (LargeKey mid (LargeKey hi highest)))) = do | ||
475 | putWord64be highest | ||
476 | putWord64be hi | ||
477 | putWord64be mid | ||
478 | putWord64be lo | ||
479 | |||
480 | |||
384 | staticAssert isLittleEndian -- assumed by 'withWord64Ptr' | 481 | staticAssert isLittleEndian -- assumed by 'withWord64Ptr' |
385 | 482 | ||
386 | with3Word64Ptr :: Nonce24 -> (Ptr Word64 -> IO a) -> IO a | 483 | with3Word64Ptr :: Nonce24 -> (Ptr Word64 -> IO a) -> IO a |
387 | with3Word64Ptr (LargeKey wlo (LargeKey wmid whi)) kont = | 484 | with3Word64Ptr (LargeKey wlo (LargeKey wmid whi)) kont = |
388 | allocaBytes (sizeOf wlo * 3) $ \p -> do | 485 | allocaBytes (sizeOf wlo * 3) $ \p -> do |
389 | pokeElemOff p 0 wlo | 486 | pokeElemOff p 2 $ toBE64 wlo |
390 | pokeElemOff p 1 wmid | 487 | pokeElemOff p 1 $ toBE64 wmid |
391 | pokeElemOff p 2 whi | 488 | pokeElemOff p 0 $ toBE64 whi |
392 | kont p | 489 | kont p |
393 | 490 | ||
394 | with4Word64Ptr :: Key32 -> (Ptr Word64 -> IO a) -> IO a | 491 | with4Word64Ptr :: Key32 -> (Ptr Word64 -> IO a) -> IO a |
395 | with4Word64Ptr (LargeKey wlo (LargeKey wmid (LargeKey whi whighest))) kont = | 492 | with4Word64Ptr (LargeKey wlo (LargeKey wmid (LargeKey whi whighest))) kont = |
396 | allocaBytes (sizeOf wlo * 4) $ \p -> do | 493 | allocaBytes (sizeOf wlo * 4) $ \p -> do |
397 | pokeElemOff p 0 wlo | 494 | pokeElemOff p 3 $ toBE64 wlo |
398 | pokeElemOff p 1 wmid | 495 | pokeElemOff p 2 $ toBE64 wmid |
399 | pokeElemOff p 2 whi | 496 | pokeElemOff p 1 $ toBE64 whi |
400 | pokeElemOff p 3 whighest | 497 | pokeElemOff p 0 $ toBE64 whighest |
401 | kont p | 498 | kont p |
402 | 499 | ||
403 | 500 | ||
@@ -440,13 +537,15 @@ instance WireFormat ByteString Message where | |||
440 | 537 | ||
441 | initializeServerState _ _ = do | 538 | initializeServerState _ _ = do |
442 | k <- generateSecretKey | 539 | k <- generateSecretKey |
540 | {- | ||
443 | nid <- withByteArray (toPublic k) $ \p -> do | 541 | nid <- withByteArray (toPublic k) $ \p -> do |
444 | wlo <- peekElemOff p 0 | 542 | wlo <- peekElemOff p 0 |
445 | wmid <- peekElemOff p 1 | 543 | wmid <- peekElemOff p 1 |
446 | whi <- peekElemOff p 2 | 544 | whi <- peekElemOff p 2 |
447 | whigest <- peekElemOff p 3 | 545 | whigest <- peekElemOff p 3 |
448 | return $ LargeKey wlo (LargeKey wmid (LargeKey whi whigest)) | 546 | return $ LargeKey wlo (LargeKey wmid (LargeKey whi whigest)) |
449 | return (NodeId nid, ToxCipherContext k) | 547 | -} |
548 | return (key2id $ toPublic k, ToxCipherContext k) | ||
450 | 549 | ||
451 | 550 | ||
452 | instance Read (NodeId Message) where readsPrec d s = map (\(w,xs) -> (NodeId w, xs)) $ decodeHex s | 551 | instance Read (NodeId Message) where readsPrec d s = map (\(w,xs) -> (NodeId w, xs)) $ decodeHex s |
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs index 4d2be86d..da69d14b 100644 --- a/src/Network/KRPC/Method.hs +++ b/src/Network/KRPC/Method.hs | |||
@@ -38,76 +38,3 @@ import Network.DatagramServer.Types | |||
38 | import Network.DHT.Types | 38 | import Network.DHT.Types |
39 | 39 | ||
40 | 40 | ||
41 | -- | Method datatype used to describe method name, parameters and | ||
42 | -- return values of procedure. Client use a method to /invoke/, server | ||
43 | -- /implements/ the method to make the actual work. | ||
44 | -- | ||
45 | -- We use the following fantom types to ensure type-safiety: | ||
46 | -- | ||
47 | -- * param: Type of method parameters. | ||
48 | -- | ||
49 | -- * result: Type of return value of the method. | ||
50 | -- | ||
51 | newtype Method dht param result = Method { methodName :: QueryMethod dht } | ||
52 | |||
53 | deriving instance Eq (QueryMethod dht) => Eq (Method dht param result) | ||
54 | deriving instance Ord (QueryMethod dht) => Ord (Method dht param result) | ||
55 | deriving instance IsString (QueryMethod dht) => IsString (Method dht param result) | ||
56 | deriving instance BEncode (QueryMethod dht) => BEncode (Method dht param result) | ||
57 | |||
58 | -- | Example: | ||
59 | -- | ||
60 | -- @show (Method \"concat\" :: [Int] Int) == \"concat :: [Int] -> Int\"@ | ||
61 | -- | ||
62 | instance (Show (QueryMethod dht), Typeable a, Typeable b) => Show (Method dht a b) where | ||
63 | showsPrec _ = showsMethod | ||
64 | |||
65 | showsMethod :: forall dht a b. ( Show (QueryMethod dht), Typeable a , Typeable b ) => Method dht a b -> ShowS | ||
66 | showsMethod (Method name) = | ||
67 | -- showString (BC.unpack name) <> | ||
68 | shows (show name) <> | ||
69 | showString " :: " <> | ||
70 | shows paramsTy <> | ||
71 | showString " -> " <> | ||
72 | shows valuesTy | ||
73 | where | ||
74 | impossible = error "KRPC.showsMethod: impossible" | ||
75 | paramsTy = typeOf (impossible :: a) | ||
76 | valuesTy = typeOf (impossible :: b) | ||
77 | |||
78 | -- | In order to perform or handle KRPC query you need to provide | ||
79 | -- corresponding 'KRPC' class. | ||
80 | -- | ||
81 | -- Example: | ||
82 | -- | ||
83 | -- @ | ||
84 | -- data Ping = Ping Text deriving BEncode | ||
85 | -- data Pong = Pong Text deriving BEncode | ||
86 | -- | ||
87 | -- instance 'KRPC' Ping Pong where | ||
88 | -- method = \"ping\" | ||
89 | -- @ | ||
90 | -- | ||
91 | class ( Typeable req, Typeable resp, Envelope dht) | ||
92 | => KRPC dht req resp | req -> resp, resp -> req where | ||
93 | |||
94 | -- | Method name. Default implementation uses lowercased @req@ | ||
95 | -- datatype name. | ||
96 | -- | ||
97 | method :: Method dht req resp | ||
98 | |||
99 | -- TODO add underscores | ||
100 | default method :: (IsString (QueryMethod dht), Typeable req) => Method dht req resp | ||
101 | method = Method $ fromString $ L.map toLower $ show $ typeOf hole | ||
102 | where | ||
103 | hole = error "krpc.method: impossible" :: req | ||
104 | |||
105 | |||
106 | validateExchange :: dht req -> dht resp -> Bool | ||
107 | validateExchange _ _ = True | ||
108 | |||
109 | makeQueryExtra :: DHTData dht ip -> NodeId dht -> Proxy req -> Proxy resp -> IO (QueryExtra dht) | ||
110 | makeResponseExtra :: DHTData dht ip -> NodeId dht -> req -> Proxy resp -> IO (ResponseExtra dht) | ||
111 | |||
112 | messageSender :: dht req -> Proxy resp -> NodeId dht | ||
113 | messageResponder :: Proxy req -> dht resp -> NodeId dht | ||