diff options
Diffstat (limited to 'src/Network/KRPC/Manager.hs')
-rw-r--r-- | src/Network/KRPC/Manager.hs | 44 |
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) | |||
84 | import Network.Socket.ByteString as BS | 84 | import Network.Socket.ByteString as BS |
85 | import System.IO.Error | 85 | import System.IO.Error |
86 | import System.Timeout | 86 | import System.Timeout |
87 | #ifdef VERSION_bencoding | ||
87 | import Network.DHT.Mainline | 88 | import Network.DHT.Mainline |
89 | #endif | ||
88 | 90 | ||
89 | 91 | ||
90 | {----------------------------------------------------------------------- | 92 | {----------------------------------------------------------------------- |
@@ -268,15 +270,9 @@ data QueryFailure | |||
268 | 270 | ||
269 | instance Exception QueryFailure | 271 | instance Exception QueryFailure |
270 | 272 | ||
271 | #ifdef VERSION_bencoding | ||
272 | sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m () | ||
273 | sendMessage sock addr a = do | ||
274 | liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr | ||
275 | #else | ||
276 | sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m () | 273 | sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m () |
277 | sendMessage sock addr a = do | 274 | sendMessage sock addr a = do |
278 | liftIO $ sendManyTo sock [a] addr | 275 | liftIO $ sendManyTo sock [a] addr |
279 | #endif | ||
280 | 276 | ||
281 | genTransactionId :: TransactionCounter -> IO TransactionId | 277 | genTransactionId :: TransactionCounter -> IO TransactionId |
282 | genTransactionId ref = do | 278 | genTransactionId ref = do |
@@ -309,13 +305,8 @@ unregisterQuery cid ref = do | |||
309 | 305 | ||
310 | 306 | ||
311 | -- (sendmsg EINVAL) | 307 | -- (sendmsg EINVAL) |
312 | #ifdef VERSION_bencoding | 308 | sendQuery :: Socket -> SockAddr -> BC.ByteString -> IO () |
313 | sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO () | ||
314 | sendQuery sock addr q = handle sockError $ sendMessage sock addr q | 309 | sendQuery sock addr q = handle sockError $ sendMessage sock addr q |
315 | #else | ||
316 | sendQuery :: Serialize a => Socket -> SockAddr -> a -> IO () | ||
317 | sendQuery 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 | ||
543 | handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m () | 534 | handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m () |
@@ -570,16 +561,17 @@ listener :: MonadKRPC h m => m () | |||
570 | listener = do | 561 | listener = 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 |