diff options
-rw-r--r-- | dht/Presence/Presence.hs | 36 | ||||
-rw-r--r-- | dht/ToxManager.hs | 10 | ||||
-rw-r--r-- | dht/dht-client.cabal | 1 | ||||
-rw-r--r-- | dht/examples/dhtd.hs | 19 |
4 files changed, 27 insertions, 39 deletions
diff --git a/dht/Presence/Presence.hs b/dht/Presence/Presence.hs index dcc76c5b..926ee3c2 100644 --- a/dht/Presence/Presence.hs +++ b/dht/Presence/Presence.hs | |||
@@ -54,6 +54,7 @@ import Network.Tox.NodeId (key2id,parseNoSpamId,nospam64,NoSpamId(..),ToxProgres | |||
54 | import Crypto.Tox (decodeSecret) | 54 | import Crypto.Tox (decodeSecret) |
55 | import DPut | 55 | import DPut |
56 | import DebugTag | 56 | import DebugTag |
57 | import Codec.AsciiKey256 | ||
57 | 58 | ||
58 | {- | 59 | {- |
59 | isPeerKey :: ClientAddress -> Bool | 60 | isPeerKey :: ClientAddress -> Bool |
@@ -251,12 +252,12 @@ chooseResourceName state k (Remote addr) clientsNameForMe desired = do | |||
251 | flgs <- atomically $ newTVar 0 | 252 | flgs <- atomically $ newTVar 0 |
252 | profile <- fmap (fromMaybe ".") | 253 | profile <- fmap (fromMaybe ".") |
253 | $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) -> | 254 | $ forM ((,) <$> clientsNameForMe <*> toxManager state) $ \(wanted_profile0,toxman) -> |
254 | case splitLast4 wanted_profile0 of | 255 | case stripSuffix ".tox" wanted_profile0 of |
255 | ("*",".tox") -> do | 256 | Just "*" -> do |
256 | dput XMisc $ "TODO: Match single tox key profile or generate first." | 257 | dput XMisc $ "TODO: Match single tox key profile or generate first." |
257 | -- TODO: Match single tox key profile or generate first. | 258 | -- TODO: Match single tox key profile or generate first. |
258 | _todo | 259 | _todo |
259 | (pub,".tox") -> do | 260 | Just pub -> do |
260 | cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." "" | 261 | cdir <- ConfigFiles.configPath (L.fromChunks [Text.encodeUtf8 user]) "." "" |
261 | #if !MIN_VERSION_directory(1,2,5) | 262 | #if !MIN_VERSION_directory(1,2,5) |
262 | let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path | 263 | let listDirectory path = filter (`notElem` [".",".."]) <$> getDirectoryContents path |
@@ -361,7 +362,7 @@ rosterGetStuff what state k = forClient state k (return []) | |||
361 | PresenceState { server = sv } -> do | 362 | PresenceState { server = sv } -> do |
362 | let conns = manager state $ clientProfile client | 363 | let conns = manager state $ clientProfile client |
363 | -- Grok peers to associate with from the roster: | 364 | -- Grok peers to associate with from the roster: |
364 | let isTox = do (me , ".tox") <- Just $ splitLast4 (clientProfile client) | 365 | let isTox = do me <- stripSuffix ".tox" (clientProfile client) |
365 | return me | 366 | return me |
366 | noToxUsers (u,h,r) | 367 | noToxUsers (u,h,r) |
367 | | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r) | 368 | | Text.isSuffixOf ".tox" h = unsplitJID (Nothing,h,r) |
@@ -373,8 +374,9 @@ rosterGetStuff what state k = forClient state k (return []) | |||
373 | let policySetter = fromMaybe (Connection.setPolicy conns host) $ do | 374 | let policySetter = fromMaybe (Connection.setPolicy conns host) $ do |
374 | isTox | 375 | isTox |
375 | toxman <- toxManager state | 376 | toxman <- toxManager state |
376 | (them, ".tox") <- Just $ splitLast4 host | 377 | them <- stripSuffix ".tox" host |
377 | meid <- readMaybe $ Text.unpack $ Text.dropEnd 4 (clientProfile client) | 378 | prof <- stripSuffix ".tox" (clientProfile client) |
379 | meid <- readMaybe $ Text.unpack prof | ||
378 | themid <- readMaybe $ Text.unpack them | 380 | themid <- readMaybe $ Text.unpack them |
379 | return $ Connection.setPolicy (toxConnections toxman) | 381 | return $ Connection.setPolicy (toxConnections toxman) |
380 | (ToxContact meid themid) | 382 | (ToxContact meid themid) |
@@ -547,9 +549,9 @@ eofConn state saddr cdta = do | |||
547 | Right (k,_) -> do | 549 | Right (k,_) -> do |
548 | forClient state k (return ()) $ \client -> do | 550 | forClient state k (return ()) $ \client -> do |
549 | forM_ (toxManager state) $ \toxman -> do | 551 | forM_ (toxManager state) $ \toxman -> do |
550 | case splitLast4 (clientProfile client) of | 552 | case stripSuffix ".tox" (clientProfile client) of |
551 | (pub,".tox") -> deactivateAccount toxman k (clientProfile client) | 553 | Just pub -> deactivateAccount toxman k (clientProfile client) |
552 | _ -> return () | 554 | _ -> return () |
553 | stanza <- makePresenceStanza "jabber:server" Nothing Offline | 555 | stanza <- makePresenceStanza "jabber:server" Nothing Offline |
554 | informClientPresence state k stanza | 556 | informClientPresence state k stanza |
555 | atomically $ do | 557 | atomically $ do |
@@ -665,12 +667,12 @@ deliverMessage state fail msg = | |||
665 | -- In case the client sends us a lower-cased version of the base64 | 667 | -- In case the client sends us a lower-cased version of the base64 |
666 | -- tox key hostname, we resolve it by comparing it with roster entries. | 668 | -- tox key hostname, we resolve it by comparing it with roster entries. |
667 | xs <- getBuddiesAndSolicited state (clientProfile client) $ \case | 669 | xs <- getBuddiesAndSolicited state (clientProfile client) $ \case |
668 | rh | (_,".tox") <- splitLast4 rh | 670 | rh | Just _ <- stripSuffix ".tox" rh |
669 | , Text.toLower rh == Text.toLower th | 671 | , Text.toLower rh == Text.toLower th |
670 | -> return True | 672 | -> return True |
671 | _ -> return False | 673 | _ -> return False |
672 | fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do | 674 | fmap join $ forM (listToMaybe xs) $ \(_,rmu,_,h) -> do |
673 | let (them,_) = splitLast4 h | 675 | let them = fromMaybe h $ stripSuffix ".tox" h |
674 | maddr <- resolveToxPeer toxman me them | 676 | maddr <- resolveToxPeer toxman me them |
675 | let to' = unsplitJID (mu,h,rsc) | 677 | let to' = unsplitJID (mu,h,rsc) |
676 | return $ fmap (to',) maddr | 678 | return $ fmap (to',) maddr |
@@ -1168,21 +1170,19 @@ clientSubscriptionRequest state fail k stanza chan = do | |||
1168 | (connChan con) | 1170 | (connChan con) |
1169 | let policySetter = fromMaybe (Connection.setPolicy conns h) $ do | 1171 | let policySetter = fromMaybe (Connection.setPolicy conns h) $ do |
1170 | (toxman,_,_) <- weAreTox state client h | 1172 | (toxman,_,_) <- weAreTox state client h |
1171 | meid <- readMaybe $ Text.unpack $ case splitLast4 (clientProfile client) of | 1173 | meid <- readMaybe $ Text.unpack $ case stripSuffix ".tox" (clientProfile client) of |
1172 | (h,".tox") -> h | 1174 | Just h -> h |
1173 | _ -> clientProfile client | 1175 | _ -> clientProfile client |
1174 | themid <- readMaybe $ Text.unpack h | 1176 | themid <- readMaybe $ Text.unpack h |
1175 | Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid) | 1177 | Just $ Connection.setPolicy (toxConnections toxman) (ToxContact meid themid) |
1176 | -- Add peer if we are not already associated ... | 1178 | -- Add peer if we are not already associated ... |
1177 | policySetter Connection.TryingToConnect | 1179 | policySetter Connection.TryingToConnect |
1178 | 1180 | ||
1179 | splitLast4 h = Text.splitAt (Text.length h - 4) h | ||
1180 | |||
1181 | weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -}) | 1181 | weAreTox :: PresenceState stat -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -}) |
1182 | weAreTox state client h = do | 1182 | weAreTox state client h = do |
1183 | toxman <- toxManager state | 1183 | toxman <- toxManager state |
1184 | (me , ".tox") <- Just $ splitLast4 (clientProfile client) | 1184 | me <- stripSuffix ".tox" (clientProfile client) |
1185 | (them, ".tox") <- Just $ splitLast4 h | 1185 | them <- stripSuffix ".tox" h |
1186 | return (toxman,me,them) | 1186 | return (toxman,me,them) |
1187 | 1187 | ||
1188 | resolvedFromRoster | 1188 | resolvedFromRoster |
diff --git a/dht/ToxManager.hs b/dht/ToxManager.hs index 51567b27..408b12d2 100644 --- a/dht/ToxManager.hs +++ b/dht/ToxManager.hs | |||
@@ -9,6 +9,7 @@ module ToxManager where | |||
9 | import Announcer | 9 | import Announcer |
10 | import Announcer.Tox | 10 | import Announcer.Tox |
11 | import ClientState | 11 | import ClientState |
12 | import Codec.AsciiKey256 | ||
12 | import ConfigFiles | 13 | import ConfigFiles |
13 | import Control.Arrow | 14 | import Control.Arrow |
14 | import Control.Concurrent.STM | 15 | import Control.Concurrent.STM |
@@ -89,13 +90,6 @@ stringToKey_ s = let (xs,ys) = break (==':') s | |||
89 | them <- readMaybe (drop 1 ys) | 90 | them <- readMaybe (drop 1 ys) |
90 | return $ ToxContact me them | 91 | return $ ToxContact me them |
91 | 92 | ||
92 | dropExtension :: T.Text -> T.Text | ||
93 | dropExtension pubname = case T.dropWhileEnd (/='.') pubname of | ||
94 | x | T.null x -> pubname | ||
95 | | otherwise -> case T.dropEnd 1 pubname of | ||
96 | y | T.null y -> pubname -- Avoid changing "." to empty string. | ||
97 | | otherwise -> y | ||
98 | |||
99 | -- | | 93 | -- | |
100 | -- | 94 | -- |
101 | -- These hooks will be invoked in order to connect to *.tox hosts in a user's | 95 | -- These hooks will be invoked in order to connect to *.tox hosts in a user's |
@@ -146,7 +140,7 @@ toxman ssvar announcer toxbkts tox presence = ToxManager | |||
146 | , deactivateAccount = \k pubname -> do | 140 | , deactivateAccount = \k pubname -> do |
147 | dput XMan $ "toxman DECTIVATE (todo) 1 " ++ show pubname | 141 | dput XMan $ "toxman DECTIVATE (todo) 1 " ++ show pubname |
148 | let ContactInfo{ accounts } = Tox.toxContactInfo tox | 142 | let ContactInfo{ accounts } = Tox.toxContactInfo tox |
149 | mpubid = readMaybe $ T.unpack $ dropExtension pubname | 143 | mpubid = stripSuffix ".tox" pubname >>= readMaybe . T.unpack |
150 | bStopped <- fmap (fromMaybe Nothing) $ atomically $ do | 144 | bStopped <- fmap (fromMaybe Nothing) $ atomically $ do |
151 | forM mpubid $ \pubid -> do | 145 | forM mpubid $ \pubid -> do |
152 | refs <- do | 146 | refs <- do |
diff --git a/dht/dht-client.cabal b/dht/dht-client.cabal index 31f78bcf..c58aa82a 100644 --- a/dht/dht-client.cabal +++ b/dht/dht-client.cabal | |||
@@ -157,6 +157,7 @@ library | |||
157 | Network.Tox.AggregateSession | 157 | Network.Tox.AggregateSession |
158 | Network.Tox.Session | 158 | Network.Tox.Session |
159 | DebugTag | 159 | DebugTag |
160 | Codec.AsciiKey256 | ||
160 | Paths_dht_client | 161 | Paths_dht_client |
161 | 162 | ||
162 | build-depends: base | 163 | build-depends: base |
diff --git a/dht/examples/dhtd.hs b/dht/examples/dhtd.hs index 3e9f8ff5..adfe0d69 100644 --- a/dht/examples/dhtd.hs +++ b/dht/examples/dhtd.hs | |||
@@ -63,6 +63,7 @@ import System.Posix.Signals | |||
63 | import Announcer | 63 | import Announcer |
64 | import Announcer.Tox | 64 | import Announcer.Tox |
65 | import ToxManager | 65 | import ToxManager |
66 | import Codec.AsciiKey256 | ||
66 | import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) | 67 | import Crypto.Tox -- (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret, userKeys) |
67 | import DebugUtil | 68 | import DebugUtil |
68 | import Network.UPNP as UPNP | 69 | import Network.UPNP as UPNP |
@@ -1302,27 +1303,19 @@ onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do | |||
1302 | return () | 1303 | return () |
1303 | 1304 | ||
1304 | selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text | 1305 | selectManager :: Maybe (t -> ToxManager clientAddress) -> Manager Tcp.TCPStatus T.Text -> T.Text -> Manager Pending T.Text |
1305 | selectManager mtman tcp profile = case T.splitAt (T.length profile - 4) profile of | 1306 | selectManager mtman tcp profile = case stripSuffix ".tox" profile of |
1306 | (k,".tox") | Just tman <- mtman | 1307 | Just k | Just tman <- mtman |
1307 | -> let -- The following error call is safe because the toxConnections field | 1308 | -> let -- The following error call is safe because the toxConnections field |
1308 | -- does not make use of the PresenceState passed to tman. | 1309 | -- does not make use of the PresenceState passed to tman. |
1309 | tox = toxConnections $ tman $ error "PresenseState" | 1310 | tox = toxConnections $ tman $ error "PresenseState" |
1310 | tkey them = do | 1311 | tkey them0 = do |
1311 | me <- readMaybe (T.unpack k) | 1312 | me <- readMaybe (T.unpack k) |
1312 | them <- case T.splitAt 52 them of | 1313 | them <- stripSuffix ".tox" them0 >>= readMaybe . T.unpack |
1313 | (them0,".tox") -> readMaybe (T.unpack them0) | ||
1314 | _ -> case T.splitAt 43 them of | ||
1315 | (them0,".tox") -> readMaybe (T.unpack them0) | ||
1316 | _ -> Nothing | ||
1317 | return (Tox.ToxContact me them) | 1314 | return (Tox.ToxContact me them) |
1318 | in Manager | 1315 | in Manager |
1319 | { resolvePeer = \themhost -> do | 1316 | { resolvePeer = \themhost -> do |
1320 | r <- fromMaybe (return []) $ do | 1317 | r <- fromMaybe (return []) $ do |
1321 | themT <- case T.splitAt 52 themhost of | 1318 | themT <- stripSuffix ".tox" themhost |
1322 | (ts,".tox") -> Just ts | ||
1323 | _ -> case T.splitAt 43 themhost of | ||
1324 | (ts,".tox") -> Just ts | ||
1325 | _ -> Nothing | ||
1326 | them <- readMaybe $ T.unpack themT | 1319 | them <- readMaybe $ T.unpack themT |
1327 | me <- readMaybe $ T.unpack k | 1320 | me <- readMaybe $ T.unpack k |
1328 | let contact = Tox.ToxContact me them | 1321 | let contact = Tox.ToxContact me them |