diff options
Diffstat (limited to 'examples')
-rw-r--r-- | examples/dhtd.hs | 38 |
1 files changed, 28 insertions, 10 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index fbfca86f..8fd1402d 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -23,6 +23,7 @@ import Control.Applicative | |||
23 | import Control.Concurrent.STM | 23 | import Control.Concurrent.STM |
24 | import Control.Exception | 24 | import Control.Exception |
25 | import Control.Monad | 25 | import Control.Monad |
26 | import Control.Monad.IO.Class (liftIO) | ||
26 | import Control.Monad.Trans.Control | 27 | import Control.Monad.Trans.Control |
27 | import Control.Monad.Trans.Resource (runResourceT) | 28 | import Control.Monad.Trans.Resource (runResourceT) |
28 | import Data.Bool | 29 | import Data.Bool |
@@ -988,11 +989,17 @@ noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r) | |||
988 | noArgPing f [] x = f x | 989 | noArgPing f [] x = f x |
989 | noArgPing _ _ _ = return Nothing | 990 | noArgPing _ _ _ = return Nothing |
990 | 991 | ||
991 | newXmmpSource :: Tox.NetCryptoSession -> IO (C.Source IO Tox.CryptoMessage) | 992 | newXmmpSource :: Tox.NetCryptoSession -> C.Source IO Tox.CryptoMessage |
992 | newXmmpSource = _todo | 993 | newXmmpSource sessions = do |
994 | v <- liftIO $ _todo sessions {- receive a fucking message -} | ||
995 | case v of | ||
996 | Nothing -> return () -- Nothing indicates EOF. | ||
997 | Just cryptomessage -> do C.yield cryptomessage | ||
998 | newXmmpSource sessions | ||
993 | 999 | ||
994 | newXmmpSink :: Tox.NetCryptoSession -> IO (C.Sink (Flush Tox.CryptoMessage) IO ()) | 1000 | newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO () |
995 | newXmmpSink = _todo | 1001 | newXmmpSink sessions = C.awaitForever $ \flush_cyptomessage -> do |
1002 | liftIO $ (_todo sessions {- send the fucking message -}) flush_cyptomessage | ||
996 | 1003 | ||
997 | -- | TODO | 1004 | -- | TODO |
998 | -- | 1005 | -- |
@@ -1000,9 +1007,20 @@ newXmmpSink = _todo | |||
1000 | -- XMPP roster. | 1007 | -- XMPP roster. |
1001 | toxman :: Tox.Tox -> ToxManager k | 1008 | toxman :: Tox.Tox -> ToxManager k |
1002 | toxman tox = ToxManager | 1009 | toxman tox = ToxManager |
1003 | { activateAccount = \k pubname seckey -> return () | 1010 | { activateAccount = \k pubname seckey -> do |
1004 | , deactivateAccount = \k pubname -> return () | 1011 | -- Schedule recuring announce. |
1005 | , setToxConnectionPolicy = \me them policy -> return () | 1012 | -- Schedule recuring search for all non-connected contacts. |
1013 | return () | ||
1014 | , deactivateAccount = \k pubname -> do | ||
1015 | -- If /k/ is the last reference: | ||
1016 | -- Stop recuring announce. | ||
1017 | -- If this is the last reference to a non-connected contact: | ||
1018 | -- Stop the recuring search for that contact | ||
1019 | return () | ||
1020 | , setToxConnectionPolicy = \me them policy -> | ||
1021 | case policy of | ||
1022 | TryingToConnect -> return () -- Add a contact. | ||
1023 | _ -> return () -- Remove contact. | ||
1006 | } | 1024 | } |
1007 | 1025 | ||
1008 | 1026 | ||
@@ -1325,9 +1343,9 @@ main = runResourceT $ liftBaseWith $ \resT -> do | |||
1325 | forM_ (take 1 taddrs) $ \addrTox -> do | 1343 | forM_ (take 1 taddrs) $ \addrTox -> do |
1326 | atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do | 1344 | atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do |
1327 | let Just pingMachine = Tox.ncPingMachine netcrypto | 1345 | let Just pingMachine = Tox.ncPingMachine netcrypto |
1328 | pingflag = readTVar (pingFlag pingMachine) | 1346 | pingflag = readTVar (pingFlag pingMachine) |
1329 | xmppSrc <- newXmmpSource netcrypto | 1347 | xmppSrc = newXmmpSource netcrypto |
1330 | xmppSink <- newXmmpSink netcrypto | 1348 | xmppSink = newXmmpSink netcrypto |
1331 | announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink | 1349 | announceToxXMPPClients (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink |
1332 | 1350 | ||
1333 | let dhts = Map.union btdhts toxdhts | 1351 | let dhts = Map.union btdhts toxdhts |