Keep a per-session selected user key state.

1 files changed, 23 insertions, 7 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 088e0c67..9e7f4582 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -159,8 +159,7 @@ data DHTAnnouncable nid = forall dta tok ni r.
     { announceParseData    :: String -> Either String dta
     , announceParseToken   :: dta -> String -> Either String tok
     , announceParseAddress :: String -> Either String ni
-    , announceSendData     :: Either (dta -> r -> IO (Maybe r)) -- TODO ( String {- search name -}
-                                                                --      , PublicKey {- me -} -> dta -> r -> IO ())
+    , announceSendData     :: Either ( String {- search name -} , PublicKey {- me -} -> dta -> r -> IO ())
                                      (dta -> tok -> Maybe ni -> IO (Maybe r))
     , announceInterval     :: POSIXTime
     , announceTarget       :: dta -> nid
@@ -383,6 +382,7 @@ data ConnectionManager = forall status k. ConnectionManager { typedManager :: Co
 
 data Session = Session
     { netname           :: String
+    , selectedKey       :: Maybe PublicKey
     , dhts              :: Map.Map String DHT
     , externalAddresses :: IO [SockAddr]
     , swarms            :: Mainline.SwarmsDatabase
@@ -433,6 +433,7 @@ clientSession s@Session{..} sock cnum h = do
         cmd0 action = exceptionsToClient h action >> clientSession s sock cnum h
         switchNetwork dest = do hPutClient h ("Network: "++dest)
                                 clientSession s{netname=dest} sock cnum h
+        switchKey key = clientSession s { selectedKey = key } sock cnum h
         strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack
             where
                 dropEnd (x,_) =
@@ -567,8 +568,10 @@ clientSession s@Session{..} sock cnum h = do
 
         ("k", s) | ""           <- strp s -> cmd0 $ do
                         ks <- atomically $ readTVar userkeys
-                        hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) ks
-                 | "gen"        <- strp s -> cmd0 $ do
+                        let spaces k | Just sel <- selectedKey, (sel == k) = " *"
+                                     | otherwise                           = "  "
+                        hPutClient h $ unlines $ map (\(_,k) -> mappend (spaces k) . show . Tox.key2id $ k) ks
+                 | "gen"        <- strp s -> do
                         secret <- generateSecretKey
                         let pubkey = toPublic secret
                         oldks <- atomically $ do
@@ -579,6 +582,7 @@ clientSession s@Session{..} sock cnum h = do
                         let asString = show . Tox.key2id
                         hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
                                                   ++ [mappend " *" . show . Tox.key2id $ pubkey]
+                        switchKey $ Just pubkey
                  | "secrets"    <- strp s -> cmd0 $ do
                         ks <- atomically $ readTVar userkeys
                         skey <- maybe (return Nothing) (atomically . dhtSecretKey)
@@ -586,10 +590,16 @@ clientSession s@Session{..} sock cnum h = do
                         hPutClient h . showReport $ map mkrow ks ++ case skey >>= encodeSecret of
                             Just x  -> [("",""),("dht-key:",B.unpack x)]
                             Nothing -> []
-                 -- TODO | ("sel":secs) <- words s -> select active key
+                 | ("sel",_:expr) <- break isSpace s -> do
+                         ks <- atomically $ map (show . Tox.key2id . snd) <$> readTVar userkeys
+                         case find (isInfixOf expr) ks of
+                            Just k -> do
+                                hPutClient h $ "Selected key: "++k
+                                switchKey $ Just $ Tox.id2key $ read k
+                            Nothing -> cmd0 $ hPutClient h "no match."
                  | ("add":secs) <- words s
                  , mbSecs <- map (decodeSecret . B.pack) secs
-                 , all isJust mbSecs -> cmd0 $ do
+                 , all isJust mbSecs -> do
                         let f (Just b) = b
                             f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
                         let toPair x = (x,toPublic x)
@@ -601,9 +611,10 @@ clientSession s@Session{..} sock cnum h = do
                             return oldks
                         hPutClient h $ unlines $ map (mappend "  " . show . Tox.key2id . snd) oldks
                                                   ++ map (mappend " *" . show . Tox.key2id .snd) pairs
+                        switchKey $ listToMaybe $ map snd pairs
                  | ("del":secs) <- words s
                  , mbSecs <- map (decodeSecret . B.pack) secs
-                 , all isJust mbSecs -> cmd0 $ do
+                 , all isJust mbSecs -> do
                         let f (Just b) = b
                             f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
                         let toPair x = (x,toPublic x)
@@ -613,6 +624,10 @@ clientSession s@Session{..} sock cnum h = do
                             forM pairs $ \(_,pk) -> Tox.delContactInfo roster pk
                             readTVar userkeys
                         hPutClient h . showReport $ map mkrow ks
+                        switchKey $ do
+                            k <- selectedKey
+                            guard $ k `notElem` map snd pairs
+                            Just k
 
         ("roster", s) -> cmd0 $ join $ atomically $ do
             dns <- dnsPresentation roster
@@ -1418,6 +1433,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
             return $ return ( userKeys (Tox.toxCryptoKeys tox), Tox.toxContactInfo tox, Tox.toxOnionRoutes tox )
         let session = clientSession0 $ Session
                 { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
+                , selectedKey       = Nothing
                 , dhts              = dhts  -- all DHTs
                 , signalQuit        = quitCommand
                 , swarms            = swarms