diff options
Diffstat (limited to 'examples/toxrelay.hs')
-rw-r--r-- | examples/toxrelay.hs | 37 |
1 files changed, 29 insertions, 8 deletions
diff --git a/examples/toxrelay.hs b/examples/toxrelay.hs index 60c2a44b..fdf0c011 100644 --- a/examples/toxrelay.hs +++ b/examples/toxrelay.hs | |||
@@ -15,6 +15,7 @@ import Crypto.Tox | |||
15 | import Data.Tox.Relay | 15 | import Data.Tox.Relay |
16 | import Network.StreamServer | 16 | import Network.StreamServer |
17 | import Network.Address (getBindAddress) | 17 | import Network.Address (getBindAddress) |
18 | import Network.Tox (newCrypto) | ||
18 | 19 | ||
19 | 20 | ||
20 | 21 | ||
@@ -28,18 +29,37 @@ hGetSized h = runGet get <$> B.hGet h len | |||
28 | where | 29 | where |
29 | ConstSize len = size :: Size x | 30 | ConstSize len = size :: Size x |
30 | 31 | ||
31 | relaySession :: TVar (IntMap Handle) -> (RelayPacket -> IO ()) -> sock -> Int -> Handle -> IO () | 32 | relaySession :: TransportCrypto -> TVar (IntMap Handle) -> (RelayPacket -> IO ()) -> sock -> Int -> Handle -> IO () |
32 | relaySession cons dispatch _ conid h = do | 33 | relaySession crypto cons dispatch _ conid h = do |
33 | atomically $ modifyTVar' cons $ IntMap.insert conid h | 34 | atomically $ modifyTVar' cons $ IntMap.insert conid h |
34 | mhello <- fmap (>>= decryptPayload _todo) $ hGetSized h | 35 | -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h |
35 | B.hPut h $ encode $ encryptPayload _todo $ Welcome _todo _todo | 36 | |
37 | (hGetSized h >>=) $ mapM_ $ \helloE -> do | ||
38 | |||
39 | let me = transportSecret crypto | ||
40 | them = helloFrom helloE | ||
41 | |||
42 | noncef <- lookupNonceFunction crypto me them | ||
43 | let mhello = decryptPayload (noncef $ helloNonce helloE) helloE | ||
44 | |||
36 | forM_ mhello $ \hello -> do | 45 | forM_ mhello $ \hello -> do |
46 | |||
47 | (me',welcome) <- atomically $ do | ||
48 | skey <- transportNewKey crypto | ||
49 | dta <- HelloData (toPublic skey) <$> transportNewNonce crypto | ||
50 | w24 <- transportNewNonce crypto | ||
51 | return (skey, Welcome w24 $ pure dta) | ||
52 | B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome | ||
53 | |||
54 | let them' = sessionPublicKey (runIdentity $ helloData hello) | ||
55 | noncef' <- lookupNonceFunction crypto me' them' | ||
56 | |||
37 | let _ = hello :: Hello Identity | 57 | let _ = hello :: Hello Identity |
38 | fix $ \loop -> do | 58 | flip fix (sessionBaseNonce $ runIdentity $ helloData hello) $ \loop n24 -> do |
39 | m <- (>>= decrypt _todo >=> decodePlain) <$> hGetPrefixed h | 59 | m <- (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h |
40 | forM_ m $ \p -> do | 60 | forM_ m $ \p -> do |
41 | dispatch p | 61 | dispatch p |
42 | loop | 62 | loop (incrementNonce24 n24) |
43 | `finally` | 63 | `finally` |
44 | atomically (modifyTVar' cons $ IntMap.delete conid) | 64 | atomically (modifyTVar' cons $ IntMap.delete conid) |
45 | 65 | ||
@@ -47,11 +67,12 @@ relaySession cons dispatch _ conid h = do | |||
47 | 67 | ||
48 | main :: IO () | 68 | main :: IO () |
49 | main = do | 69 | main = do |
70 | crypto <- newCrypto | ||
50 | cons <- newTVarIO IntMap.empty | 71 | cons <- newTVarIO IntMap.empty |
51 | a <- getBindAddress "33445" True | 72 | a <- getBindAddress "33445" True |
52 | h <- streamServer ServerConfig | 73 | h <- streamServer ServerConfig |
53 | { serverWarn = hPutStrLn stderr | 74 | { serverWarn = hPutStrLn stderr |
54 | , serverSession = relaySession cons print | 75 | , serverSession = relaySession crypto cons print |
55 | } | 76 | } |
56 | a | 77 | a |
57 | 78 | ||