summaryrefslogtreecommitdiff
path: root/src/Network/KRPC/Manager.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/KRPC/Manager.hs')
-rw-r--r--src/Network/KRPC/Manager.hs44
1 files changed, 18 insertions, 26 deletions
diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index f31a3cd6..efd59f32 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -84,7 +84,9 @@ import Network.Socket hiding (listen)
84import Network.Socket.ByteString as BS 84import Network.Socket.ByteString as BS
85import System.IO.Error 85import System.IO.Error
86import System.Timeout 86import System.Timeout
87#ifdef VERSION_bencoding
87import Network.DHT.Mainline 88import Network.DHT.Mainline
89#endif
88 90
89 91
90{----------------------------------------------------------------------- 92{-----------------------------------------------------------------------
@@ -268,15 +270,9 @@ data QueryFailure
268 270
269instance Exception QueryFailure 271instance Exception QueryFailure
270 272
271#ifdef VERSION_bencoding
272sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m ()
273sendMessage sock addr a = do
274 liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr
275#else
276sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m () 273sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m ()
277sendMessage sock addr a = do 274sendMessage sock addr a = do
278 liftIO $ sendManyTo sock [a] addr 275 liftIO $ sendManyTo sock [a] addr
279#endif
280 276
281genTransactionId :: TransactionCounter -> IO TransactionId 277genTransactionId :: TransactionCounter -> IO TransactionId
282genTransactionId ref = do 278genTransactionId ref = do
@@ -309,13 +305,8 @@ unregisterQuery cid ref = do
309 305
310 306
311-- (sendmsg EINVAL) 307-- (sendmsg EINVAL)
312#ifdef VERSION_bencoding 308sendQuery :: Socket -> SockAddr -> BC.ByteString -> IO ()
313sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO ()
314sendQuery sock addr q = handle sockError $ sendMessage sock addr q 309sendQuery sock addr q = handle sockError $ sendMessage sock addr q
315#else
316sendQuery :: Serialize a => Socket -> SockAddr -> a -> IO ()
317sendQuery sock addr q = handle sockError $ sendMessage sock addr (S.encode q)
318#endif
319 where 310 where
320 sockError :: IOError -> IO () 311 sockError :: IOError -> IO ()
321 sockError _ = throwIO SendFailed 312 sockError _ = throwIO SendFailed
@@ -351,12 +342,17 @@ queryK addr params kont = do
351 ares <- registerQuery (tid, addr) pendingCalls 342 ares <- registerQuery (tid, addr) pendingCalls
352 343
353#ifdef VERSION_bencoding 344#ifdef VERSION_bencoding
354 let q = KQuery (toBEncode params) (methodName queryMethod) tid 345 let q = Q (KQuery (toBEncode params) (methodName queryMethod) tid)
346 qb = encodePayload q :: KMessage
347 qbs = encodeHeaders () qb :: BC.ByteString
355#else 348#else
356 let q = Tox.Message (methodName queryMethod) cli tid params 349 let q = Tox.Message (methodName queryMethod) cli tid params
357 cli = error "TODO TOX client node id" 350 cli = error "TODO TOX client node id"
351 ctx = error "TODO TOX ToxCipherContext"
352 qb = encodePayload q :: Tox.Message BC.ByteString
353 qbs = encodeHeaders ctx qb :: BC.ByteString
358#endif 354#endif
359 sendQuery sock addr q 355 sendQuery sock addr qbs
360 `onException` unregisterQuery (tid, addr) pendingCalls 356 `onException` unregisterQuery (tid, addr) pendingCalls
361 357
362 timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do 358 timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do
@@ -463,14 +459,7 @@ runHandler h addr m = Lifted.catches wrapper failbacks
463 459
464 Right a -> do -- KQueryArgs 460 Right a -> do -- KQueryArgs
465 $(logDebugS) "handler.success" signature 461 $(logDebugS) "handler.success" signature
466#ifdef VERSION_bencoding
467 return $ Right a 462 return $ Right a
468#else
469 let cli = error "TODO TOX client node id"
470 messageid = error "TODO TOX message response id"
471 -- TODO: ReflectedIP addr ??
472 return $ Right $ Tox.Message messageid cli (queryId m) a
473#endif
474 463
475 failbacks = 464 failbacks =
476 [ E.Handler $ \ (e :: HandlerFailure) -> do 465 [ E.Handler $ \ (e :: HandlerFailure) -> do
@@ -528,16 +517,18 @@ handleQuery raw q addr = void $ fork $ do
528 Manager {..} <- getManager 517 Manager {..} <- getManager
529 res <- dispatchHandler q addr 518 res <- dispatchHandler q addr
530#ifdef VERSION_bencoding 519#ifdef VERSION_bencoding
531 let resbe = either toBEncode toBEncode res 520 let res' = either E id res
521 resbe = either toBEncode toBEncode res
532 $(logOther "q") $ T.unlines 522 $(logOther "q") $ T.unlines
533 [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw) 523 [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw)
534 , "==>" 524 , "==>"
535 , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe) 525 , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe)
536 ] 526 ]
537 sendMessage sock addr resbe 527 sendMessage sock addr $ encodeHeaders () res'
538#else 528#else
539 -- Errors not sent for Tox. 529 -- Errors not sent for Tox.
540 either (const $ return ()) (sendMessage sock addr . S.encode) res 530 let ctx = error "TODO TOX ToxCipherContext 2"
531 either (const $ return ()) (sendMessage sock addr . encodeHeaders ctx) res
541#endif 532#endif
542 533
543handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m () 534handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m ()
@@ -570,16 +561,17 @@ listener :: MonadKRPC h m => m ()
570listener = do 561listener = do
571 Manager {..} <- getManager 562 Manager {..} <- getManager
572 fix $ \again -> do 563 fix $ \again -> do
564 let ctx = error "TODO TOX ToxCipherContext 3"
573 (bs, addr) <- liftIO $ do 565 (bs, addr) <- liftIO $ do
574 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options) 566 handle exceptions $ BS.recvFrom sock (optMaxMsgSize options)
575#ifdef VERSION_bencoding 567#ifdef VERSION_bencoding
576 case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of 568 case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of
577#else 569#else
578 case return bs >>= \r -> (,) r <$> decode bs of 570 case return bs >>= \r -> (,) r <$> decodeHeaders ctx bs of
579#endif 571#endif
580 -- TODO ignore unknown messages at all? 572 -- TODO ignore unknown messages at all?
581#ifdef VERSION_bencoding 573#ifdef VERSION_bencoding
582 Left e -> liftIO $ sendMessage sock addr $ unknownMessage e 574 Left e -> liftIO $ sendMessage sock addr $ encodeHeaders () (E (unknownMessage e) :: KMessage)
583#else 575#else
584 Left _ -> return () -- TODO TOX send unknownMessage error 576 Left _ -> return () -- TODO TOX send unknownMessage error
585#endif 577#endif