diff options
| -rw-r--r-- | examples/dhtd.hs | 98 |
1 files changed, 52 insertions, 46 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index b81e88b5..000583c5 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
| @@ -879,52 +879,7 @@ clientSession s@Session{..} sock cnum h = do | |||
| 879 | 879 | ||
| 880 | -- necrypto <FRIEND-TOXID> | 880 | -- necrypto <FRIEND-TOXID> |
| 881 | -- establish a netcrypto session with specified person | 881 | -- establish a netcrypto session with specified person |
| 882 | ("netcrypto", s) | 882 | ("netcrypto", s) -> cmd0 $ netcrypto (Map.lookup netname dhts) selectedKey h roster mbTox (strp s) |
| 883 | | Just DHT{..} <- Map.lookup netname dhts | ||
| 884 | -> cmd0 $ do | ||
| 885 | case selectedKey of | ||
| 886 | Nothing -> hPutClient h "No key is selected, see k command." | ||
| 887 | Just mypubkey -> do | ||
| 888 | let keystr = strp s | ||
| 889 | goParse = either | ||
| 890 | (\_ -> either (hPutClient h . ("Bad netcrypto target: "++)) | ||
| 891 | (goTarget . Left) | ||
| 892 | (readEither keystr)) -- attempt read as NodeInfo type | ||
| 893 | (goTarget . Right . Tox.id2key) | ||
| 894 | $ readEither keystr -- attempt read as NodeId type | ||
| 895 | goTarget (Left userkey_nodeinfo) = do | ||
| 896 | msec <- atomically $ do | ||
| 897 | fmap userSecret . HashMap.lookup (Tox.key2id mypubkey) <$> readTVar (accounts roster) | ||
| 898 | case mbTox of | ||
| 899 | Nothing -> hPutClient h "Requires Tox enabled." | ||
| 900 | Just tox-> do | ||
| 901 | case msec of | ||
| 902 | Nothing -> hPutClient h "Error getting secret key" | ||
| 903 | Just sec -> do | ||
| 904 | let their_pub = Tox.id2key $ Tox.nodeId userkey_nodeinfo | ||
| 905 | their_addr = Tox.nodeAddr userkey_nodeinfo | ||
| 906 | let acsVar = accounts (Tox.toxContactInfo tox) | ||
| 907 | acsmap <- atomically $ readTVar acsVar | ||
| 908 | case HashMap.lookup (Tox.key2id mypubkey) acsmap of | ||
| 909 | Nothing -> hPutClient h "Unable to find account for selected key" | ||
| 910 | Just account -> do | ||
| 911 | now <- getPOSIXTime | ||
| 912 | atomically $ setContactAddr now their_pub their_addr account | ||
| 913 | Tox.netCrypto tox sec their_pub | ||
| 914 | hPutClient h "Handshake sent" | ||
| 915 | goTarget (Right their_pub) = do | ||
| 916 | msec <- atomically $ do | ||
| 917 | ks <- map swap <$> myKeyPairs roster | ||
| 918 | return $ Data.List.lookup mypubkey ks | ||
| 919 | case mbTox of | ||
| 920 | Nothing -> hPutClient h "Requires Tox enabled." | ||
| 921 | Just tox-> do | ||
| 922 | case msec of | ||
| 923 | Nothing -> hPutClient h "Error getting secret key" | ||
| 924 | Just sec -> do | ||
| 925 | Tox.netCrypto tox sec their_pub | ||
| 926 | hPutClient h "Handshake sent" | ||
| 927 | goParse | ||
| 928 | ("g", s) | Just DHT{..} <- Map.lookup netname dhts | 883 | ("g", s) | Just DHT{..} <- Map.lookup netname dhts |
| 929 | -> cmd0 $ do | 884 | -> cmd0 $ do |
| 930 | -- arguments: method | 885 | -- arguments: method |
| @@ -1268,6 +1223,57 @@ clientSession s@Session{..} sock cnum h = do | |||
| 1268 | 1223 | ||
| 1269 | _ -> cmd0 $ hPutClient h "error." | 1224 | _ -> cmd0 $ hPutClient h "error." |
| 1270 | 1225 | ||
| 1226 | netcrypto | ||
| 1227 | :: Maybe DHT | ||
| 1228 | -> Maybe PublicKey | ||
| 1229 | -> ClientHandle | ||
| 1230 | -> ContactInfo extra1 | ||
| 1231 | -> Maybe (Tox.Tox extra2) | ||
| 1232 | -> String | ||
| 1233 | -> IO () | ||
| 1234 | netcrypto dht selectedKey h roster mbTox keystr | Just DHT{..} <- dht = do | ||
| 1235 | case selectedKey of | ||
| 1236 | Nothing -> hPutClient h "No key is selected, see k command." | ||
| 1237 | Just mypubkey -> do | ||
| 1238 | let goParse = either | ||
| 1239 | (\_ -> either (hPutClient h . ("Bad netcrypto target: "++)) | ||
| 1240 | (goTarget . Left) | ||
| 1241 | (readEither keystr)) -- attempt read as NodeInfo type | ||
| 1242 | (goTarget . Right . Tox.id2key) | ||
| 1243 | $ readEither keystr -- attempt read as NodeId type | ||
| 1244 | goTarget (Left userkey_nodeinfo) = do | ||
| 1245 | msec <- atomically $ do | ||
| 1246 | fmap userSecret . HashMap.lookup (Tox.key2id mypubkey) <$> readTVar (accounts roster) | ||
| 1247 | case mbTox of | ||
| 1248 | Nothing -> hPutClient h "Requires Tox enabled." | ||
| 1249 | Just tox-> do | ||
| 1250 | case msec of | ||
| 1251 | Nothing -> hPutClient h "Error getting secret key" | ||
| 1252 | Just sec -> do | ||
| 1253 | let their_pub = Tox.id2key $ Tox.nodeId userkey_nodeinfo | ||
| 1254 | their_addr = Tox.nodeAddr userkey_nodeinfo | ||
| 1255 | let acsVar = accounts (Tox.toxContactInfo tox) | ||
| 1256 | acsmap <- atomically $ readTVar acsVar | ||
| 1257 | case HashMap.lookup (Tox.key2id mypubkey) acsmap of | ||
| 1258 | Nothing -> hPutClient h "Unable to find account for selected key" | ||
| 1259 | Just account -> do | ||
| 1260 | now <- getPOSIXTime | ||
| 1261 | atomically $ setContactAddr now their_pub their_addr account | ||
| 1262 | Tox.netCrypto tox sec their_pub | ||
| 1263 | hPutClient h "Handshake sent" | ||
| 1264 | goTarget (Right their_pub) = do | ||
| 1265 | msec <- atomically $ do | ||
| 1266 | ks <- map swap <$> myKeyPairs roster | ||
| 1267 | return $ Data.List.lookup mypubkey ks | ||
| 1268 | case mbTox of | ||
| 1269 | Nothing -> hPutClient h "Requires Tox enabled." | ||
| 1270 | Just tox-> do | ||
| 1271 | case msec of | ||
| 1272 | Nothing -> hPutClient h "Error getting secret key" | ||
| 1273 | Just sec -> do | ||
| 1274 | Tox.netCrypto tox sec their_pub | ||
| 1275 | hPutClient h "Handshake sent" | ||
| 1276 | goParse | ||
| 1271 | 1277 | ||
| 1272 | readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr] | 1278 | readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr] |
| 1273 | readExternals nodeAddr vars = do | 1279 | readExternals nodeAddr vars = do |