summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/dhtd.hs57
-rw-r--r--src/Crypto/Tox.hs10
2 files changed, 59 insertions, 8 deletions
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 60019072..d23aca78 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -45,7 +45,7 @@ import Control.Concurrent.Lifted
45import GHC.Conc (labelThread) 45import GHC.Conc (labelThread)
46#endif 46#endif
47 47
48import Crypto.Tox (zeros32,SecretKey,PublicKey) 48import Crypto.Tox (zeros32,SecretKey,PublicKey, generateSecretKey, toPublic, encodeSecret, decodeSecret)
49import Network.UPNP as UPNP 49import Network.UPNP as UPNP
50import Network.Address hiding (NodeId, NodeInfo(..)) 50import Network.Address hiding (NodeId, NodeInfo(..))
51import Network.Kademlia.Search 51import Network.Kademlia.Search
@@ -58,6 +58,7 @@ import Network.Kademlia.Routing as R
58import Data.Aeson as J (ToJSON, FromJSON) 58import Data.Aeson as J (ToJSON, FromJSON)
59import qualified Data.Aeson as J 59import qualified Data.Aeson as J
60import qualified Data.ByteString.Lazy as L 60import qualified Data.ByteString.Lazy as L
61import qualified Data.ByteString.Char8 as B
61import Control.Concurrent.Tasks 62import Control.Concurrent.Tasks
62import System.IO.Error 63import System.IO.Error
63import qualified Data.Serialize as S 64import qualified Data.Serialize as S
@@ -283,7 +284,7 @@ data Session = Session
283 , externalAddresses :: IO [SockAddr] 284 , externalAddresses :: IO [SockAddr]
284 , swarms :: Mainline.SwarmsDatabase 285 , swarms :: Mainline.SwarmsDatabase
285 , toxkeys :: TVar Tox.AnnouncedKeys 286 , toxkeys :: TVar Tox.AnnouncedKeys
286 , keys :: TVar [(SecretKey,PublicKey)] 287 , userkeys :: TVar [(SecretKey,PublicKey)]
287 , signalQuit :: MVar () 288 , signalQuit :: MVar ()
288 } 289 }
289 290
@@ -295,6 +296,15 @@ clientSession s@Session{..} sock cnum h = do
295 cmd0 action = action >> clientSession s sock cnum h 296 cmd0 action = action >> clientSession s sock cnum h
296 switchNetwork dest = do hPutClient h ("Network: "++dest) 297 switchNetwork dest = do hPutClient h ("Network: "++dest)
297 clientSession s{netname=dest} sock cnum h 298 clientSession s{netname=dest} sock cnum h
299 strp = B.unpack . fst . until snd dropEnd . (,False) . B.dropWhile isSpace . B.pack
300 where
301 dropEnd (x,_) =
302 case B.unsnoc x of
303 Just (str,c) | isSpace c -> (str,False)
304 _ -> (x,True)
305 let mkrow :: (SecretKey, PublicKey) -> (String,String)
306 mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b))
307 mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__])
298 case (map toLower c,args) of 308 case (map toLower c,args) of
299 ("stop", _) -> do hPutClient h "Terminating DHT Daemon." 309 ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
300 hClose h 310 hClose h
@@ -368,9 +378,44 @@ clientSession s@Session{..} sock cnum h = do
368 let rs = [" ", show result] 378 let rs = [" ", show result]
369 hPutClient h $ unlines rs 379 hPutClient h $ unlines rs
370 Left er -> hPutClient h er 380 Left er -> hPutClient h er
371 ("k", "") -> cmd0 $ do 381 ("k", s) | "" <- strp s -> cmd0 $ do
372 ks <- atomically $ readTVar keys 382 ks <- atomically $ readTVar userkeys
373 hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) ks 383 hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) ks
384 | "gen" <- strp s -> cmd0 $ do
385 secret <- generateSecretKey
386 let pubkey = toPublic secret
387 oldks <- atomically $ do
388 ks <- readTVar userkeys
389 modifyTVar userkeys ((secret,pubkey):)
390 return ks
391 let asString = show . Tox.key2id
392 hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) oldks
393 ++ [mappend " *" . show . Tox.key2id $ pubkey]
394 | "secrets" <- strp s -> cmd0 $ do
395 ks <- atomically $ readTVar userkeys
396 hPutClient h . showReport $ map mkrow ks
397 | ("add":secs) <- words s
398 , mbSecs <- map (decodeSecret . B.pack) secs
399 , all isJust mbSecs -> cmd0 $ do
400 let f (Just b) = b
401 f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
402 let toPair x = (x,toPublic x)
403 pairs = map (toPair . f) mbSecs
404 oldks <- atomically $ readTVar userkeys
405 atomically $ modifyTVar userkeys (pairs ++)
406 hPutClient h $ unlines $ map (mappend " " . show . Tox.key2id . snd) oldks
407 ++ map (mappend " *" . show . Tox.key2id .snd) pairs
408 | ("del":secs) <- words s
409 , mbSecs <- map (decodeSecret . B.pack) secs
410 , all isJust mbSecs -> cmd0 $ do
411 let f (Just b) = b
412 f x = error (concat ["Assertion fail at ", __FILE__, ":", show __LINE__])
413 let toPair x = (x,toPublic x)
414 pairs = map (toPair . f) mbSecs
415 ks <- atomically $ do
416 modifyTVar userkeys (filter (`notElem` pairs) )
417 readTVar userkeys
418 hPutClient h . showReport $ map mkrow ks
374 ("g", s) | Just DHT{..} <- Map.lookup netname dhts 419 ("g", s) | Just DHT{..} <- Map.lookup netname dhts
375 -> cmd0 $ do 420 -> cmd0 $ do
376 -- arguments: method 421 -- arguments: method
@@ -628,12 +673,14 @@ main = do
628 673
629 waitForSignal <- do 674 waitForSignal <- do
630 signalQuit <- newEmptyMVar 675 signalQuit <- newEmptyMVar
676 userkeys0 <- atomically (newTVar [])
631 let session = clientSession $ Session 677 let session = clientSession $ Session
632 { netname = concat $ take 1 $ Map.keys dhts -- initial default DHT 678 { netname = concat $ take 1 $ Map.keys dhts -- initial default DHT
633 , dhts = dhts -- all DHTs 679 , dhts = dhts -- all DHTs
634 , signalQuit = signalQuit 680 , signalQuit = signalQuit
635 , swarms = swarms 681 , swarms = swarms
636 , toxkeys = keysdb 682 , toxkeys = keysdb
683 , userkeys = userkeys0
637 , externalAddresses = liftM2 (++) btips toxips 684 , externalAddresses = liftM2 (++) btips toxips
638 } 685 }
639 srv <- streamServer (withSession session) (SockAddrUnix "dht.sock") 686 srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs
index b84e5df6..d6f63f18 100644
--- a/src/Crypto/Tox.hs
+++ b/src/Crypto/Tox.hs
@@ -13,6 +13,7 @@ module Crypto.Tox
13 , getPublicKey 13 , getPublicKey
14 , putPublicKey 14 , putPublicKey
15 , SecretKey 15 , SecretKey
16 , generateSecretKey
16 , toPublic 17 , toPublic
17 , SymmetricKey(..) 18 , SymmetricKey(..)
18 , TransportCrypto(..) 19 , TransportCrypto(..)
@@ -359,7 +360,7 @@ getPublicKey = throwCryptoError . publicKey <$> S.getBytes 32
359putPublicKey :: PublicKey -> S.Put 360putPublicKey :: PublicKey -> S.Put
360putPublicKey bs = S.putByteString $ BA.convert bs 361putPublicKey bs = S.putByteString $ BA.convert bs
361 362
362encodeSecret :: BA.ByteArrayAccess bin => bin -> Maybe C8.ByteString 363encodeSecret :: SecretKey -> Maybe C8.ByteString
363encodeSecret k = do 364encodeSecret k = do
364 (a,bs) <- BA.uncons (BA.convert k) 365 (a,bs) <- BA.uncons (BA.convert k)
365 (cs,c) <- unsnoc bs 366 (cs,c) <- unsnoc bs
@@ -369,7 +370,7 @@ encodeSecret k = do
369 (ys,ds) = BA.splitAt 40 xs 370 (ys,ds) = BA.splitAt 40 xs
370 return $ BA.index ds 0 `BA.cons` ys `BA.snoc` BA.index ds 1 371 return $ BA.index ds 0 `BA.cons` ys `BA.snoc` BA.index ds 1
371 372
372decodeSecret :: C8.ByteString -> Maybe C8.ByteString 373decodeSecret :: C8.ByteString -> Maybe SecretKey
373decodeSecret k64 = do 374decodeSecret k64 = do
374 (ds0,ysds1) <- BA.uncons k64 375 (ds0,ysds1) <- BA.uncons k64
375 (ys,ds1) <- unsnoc ysds1 376 (ys,ds1) <- unsnoc ysds1
@@ -379,4 +380,7 @@ decodeSecret k64 = do
379 (cs,a') <- unsnoc csa 380 (cs,a') <- unsnoc csa
380 let a = shiftL (a' .&. 0x7c) 1 381 let a = shiftL (a' .&. 0x7c) 1
381 c = shiftR c' 4 .|. (shiftL a' 4 .&. 0x30) .|. 0x40 382 c = shiftR c' 4 .|. (shiftL a' 4 .&. 0x30) .|. 0x40
382 return $ a `BA.cons` (cs `BA.snoc` c) 383 let r = a `BA.cons` (cs `BA.snoc` c)
384 case secretKey r of
385 CryptoPassed x -> Just x
386 _ -> Nothing