From a217eb85309b2b9e148edb235a07d66dba92792d Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Sat, 28 Oct 2017 18:35:44 -0400
Subject: Allow cookie command to accept a user key argument.

---
 examples/dhtd.hs | 26 ++++++++++++++++++--------
 1 file changed, 18 insertions(+), 8 deletions(-)

(limited to 'examples/dhtd.hs')

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 3fb1c641..4de735bc 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -127,7 +127,7 @@ data DHTSearch nid ni = forall addr tok r. DHTSearch
     }
 
 data DHTPing ni = forall r. DHTPing
-    { pingQuery :: ni -> IO (Maybe r)
+    { pingQuery :: [String] -> ni -> IO (Maybe r)
     , pingShowResult :: r -> String
     }
 
@@ -202,7 +202,7 @@ pingNodes netname DHT{dhtPing} | Just DHTPing{pingQuery=ping} <- Map.lookup "pin
                          myThreadId >>= flip labelThread ("pinging."++fname)
                          putStrLn $ "Forked "++show fname
                          withTaskGroup ("withTaskGroup."++fname) 10 $ \g -> do
-                           mapM_ (\n -> forkTask g (show n) $ void $ ping n)
+                           mapM_ (\n -> forkTask g (show n) $ void $ ping [] n)
                                  (ns `asTypeOf` [])
                          putStrLn $ "Load finished "++show fname
                        return True
@@ -412,9 +412,10 @@ clientSession s@Session{..} sock cnum h = do
         (pinglike, s) | Just DHT{dhtPing} <- Map.lookup netname dhts
                       , Just DHTPing{ pingQuery=ping
                                     , pingShowResult=showr } <- Map.lookup pinglike dhtPing
+                      , ws@(_:_) <- words s
                     -> cmd0 $ do
-                        case readEither s of
-                          Right addr -> do result <- ping addr
+                        case readEither $ last ws of
+                          Right addr -> do result <- ping (init ws) addr
                                            let rs = [" ", maybe "Timeout." showr result]
                                            hPutClient h $ unlines rs
                           Left er -> hPutClient h er
@@ -644,6 +645,10 @@ parseArgs (arg:args) opts        = parseArgs args opts
                 . break (=='=') )
                 $ groupBy (const (/= ',')) arg
 
+noArgPing :: (x -> IO (Maybe r)) -> [String] -> x -> IO (Maybe r)
+noArgPing f [] x = f x
+noArgPing _ _  _ = return Nothing
+
 main :: IO ()
 main = do
     args <- getArgs
@@ -668,7 +673,7 @@ main = do
             let mainlineDHT bkts wantip = DHT
                     { dhtBuckets = bkts btR
                     , dhtPing    = Map.singleton "ping" $ DHTPing
-                                        { pingQuery = fmap (bool Nothing (Just ())) . Mainline.ping bt
+                                        { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt
                                         , pingShowResult = show
                                         }
                     , dhtQuery   = Map.fromList
@@ -736,11 +741,16 @@ main = do
                     { dhtBuckets = bkts (Tox.toxRouting tox)
                     , dhtPing    = Map.fromList
                                     [ ("ping", DHTPing
-                                            { pingQuery = fmap (bool Nothing (Just ())) . Tox.ping (Tox.toxDHT tox)
+                                            { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Tox.ping (Tox.toxDHT tox)
                                             , pingShowResult = show
                                             })
                                     , ("cookie", DHTPing
-                                            { pingQuery = Tox.cookieRequest (Tox.toxCryptoKeys tox) (Tox.toxDHT tox)
+                                            { pingQuery = \case
+                                                [keystr] | Just mykey <- readMaybe keystr
+                                                         -> Tox.cookieRequest (Tox.toxCryptoKeys tox)
+                                                                              (Tox.toxDHT tox)
+                                                                              (Tox.id2key mykey)
+                                                _        -> const $ return Nothing
                                             , pingShowResult = show
                                             })]
                     , dhtQuery   = Map.fromList
@@ -872,7 +882,7 @@ main = do
         let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni
             isNodesSearch Refl sch = sch
             ping = maybe (const $ return False)
-                         (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery)
+                         (\DHTPing{pingQuery} -> fmap (maybe False (const True)) . pingQuery [])
                          $ Map.lookup "ping" pings
         fork $ do
             myThreadId >>= flip labelThread ("bootstrap."++netname)
-- 
cgit v1.2.3