From c7adc4afe5908753627d42386463604ce634de62 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Wed, 30 May 2018 00:43:09 +0000 Subject: Finish "session" and "netcrypto" todo stubs --- examples/dhtd.hs | 105 +++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 90 insertions(+), 15 deletions(-) (limited to 'examples/dhtd.hs') diff --git a/examples/dhtd.hs b/examples/dhtd.hs index ec6c89f1..74e08073 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -459,6 +459,19 @@ clientSession s@Session{..} sock cnum h = do case B.unsnoc x of Just (str,c) | isSpace c -> (str,False) _ -> (x,True) + let readHex :: (Read n, Integral n) => String -> Maybe n + readHex s = readMaybe ("0x" ++ s) + strToSession :: String -> IO (Either String Tox.NetCryptoSession) + strToSession idStr + = case readHex idStr of + Nothing -> return (Left "Unable to parse session id") + Just id -> do + sessions <- filter ((==id) . Tox.ncSessionId) + . concat + . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions)) + case sessions of + [] -> return (Left "Session not found") + (x:xs) -> return (Right x) let mkrow :: (SecretKey, PublicKey) -> (String,String) mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b)) mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__]) @@ -723,43 +736,105 @@ clientSession s@Session{..} sock cnum h = do -- send ONLINE packet to session N ("session", s) | (idStr,"online",unstripped) <- twoWords s , stripped <- strp unstripped - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, lookup session, call sendOnline" + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + Tox.sendOnline (Tox.toxCryptoKeys tox) session + hPutClient h "sent ONLINE" -- session online -- send OFFLINE packet to session N ("session", s) | (idStr,"offline",unstripped) <- twoWords s , stripped <- strp unstripped - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, lookup session, call sendOffline" + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + Tox.sendOffline (Tox.toxCryptoKeys tox) session + hPutClient h "sent OFFLINE" -- session kill -- send KILL packet to session N ("session", s) | (idStr,"kill",unstripped) <- twoWords s , stripped <- strp unstripped - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, lookup session, call sendKill" + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + Tox.sendKill (Tox.toxCryptoKeys tox) session + hPutClient h "sent KillPacket" -- session nick -- send NICK packet to session N, setting nick to NICKNAME ("session", s) | (idStr,"nick",unstripped) <- twoWords s , nick <- strp unstripped - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, lookup session, call setNick with crypto session and nick" + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + Tox.setNick (Tox.toxCryptoKeys tox) session (B.pack nick) + hPutClient h "sent NICKNAME" -- session status -- send USERSTATUS packet to session N, set status to STATUS ("session", s) | (idStr,"status",unstripped) <- twoWords s - , status <- strp unstripped - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, parse status, call setStatus" + , statusStr <- strp unstripped + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + case readMaybe statusStr of + Nothing -> hPutClient h "Unable to parse status" + Just status -> do + Tox.setStatus (Tox.toxCryptoKeys tox) session status + hPutClient h "sent USERSTATUS" -- session typing -- send TYPING packet to session N, set typing to TYPINGSTATUS ("session", s) | (idStr,"typing",unstripped) <- twoWords s , typingstatus <- strp unstripped - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, parse typing status, call setTyping" + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + case readMaybe typingstatus of + Nothing -> hPutClient h "Unable to parse status" + Just status -> do + Tox.setTyping (Tox.toxCryptoKeys tox) session status + hPutClient h "sent TYPINGSTATUS" -- session statusmsg -- send STATUSMESSAGE packet to session N, setting status message to MSG ("session", s) | (idStr,"statusmsg",statusmsg) <- twoWords s - -> cmd0 $ - hPutClient h "TODO: parse idStr to get sessionId, call setStatusMsg" + -> cmd0 $ do + lrSession <- strToSession idStr + case lrSession of + Left s -> hPutClient h s + Right session -> do + case mbTox of + Nothing -> hPutClient h "Requires Tox enabled." + Just tox-> do + Tox.setStatusMsg (Tox.toxCryptoKeys tox) session (B.pack statusmsg) + hPutClient h "sent STATUSMESSAGE" ("onion", s) -> cmd0 $ join $ atomically $ do rm <- readTVar $ routeMap onionRouter -- cgit v1.2.3