Moved persistence and generic dht api from main module to library.

4 files changed, 140 insertions, 105 deletions

diff --git a/dht-client.cabal b/dht-client.cabal
index 496c0f5a..a3bb64fc 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -83,6 +83,8 @@ library
                     Data.BEncode.Pretty
                     Control.Concurrent.Tasks
                     Network.Kademlia
+                    Network.Kademlia.CommonAPI
+                    Network.Kademlia.Persistence
                     Network.BitTorrent.MainlineDHT
                     Network.BitTorrent.MainlineDHT.Symbols
                     System.Global6
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index fb42597e..67507634 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -72,12 +72,12 @@ import Network.UPNP as UPNP
 import Network.Address hiding (NodeId, NodeInfo(..))
 import Network.QueryResponse
 import Network.StreamServer
+import Network.Kademlia.CommonAPI
+import Network.Kademlia.Persistence
+import Network.Kademlia.Routing as R
 import Network.Kademlia.Search
 import qualified Network.BitTorrent.MainlineDHT as Mainline
 import qualified Network.Tox as Tox
-import Network.Kademlia.Routing as R
-import Data.Aeson as J (ToJSON, FromJSON)
-import qualified Data.Aeson as J
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
@@ -159,108 +159,6 @@ hPutClientChunk (ClientHandle h hstate) s = do
     hPutStr h (' ' : marshalForClient s)
     putMVar hstate 2 -- ready for more output
 
-data DHTQuery nid ni = forall addr r tok.
-                        ( Ord addr
-                        , Typeable r
-                        , Typeable tok
-                        , Typeable ni
-                        ) => DHTQuery
-    { qsearch     :: Search nid addr tok ni r
-    , qhandler    :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination.
-    , qshowR      :: r -> String
-    , qshowTok    :: tok -> Maybe String
-    }
-
-data DHTAnnouncable nid = forall dta tok ni r.
-                        ( Show r
-                        , Typeable dta -- information being announced
-                        , Typeable tok -- token
-                        , Typeable r   -- search result
-                        , Typeable ni  -- node
-                        ) => DHTAnnouncable
-    { announceParseData    :: String -> Either String dta
-    , announceParseToken   :: dta -> String -> Either String tok
-    , announceParseAddress :: String -> Either String ni
-    , announceSendData     :: Either ( String {- search name -}
-                                     , String -> Either String r
-                                     , PublicKey {- me -} -> dta -> r -> IO ())
-                                     (dta -> tok -> Maybe ni -> IO (Maybe r))
-    , announceInterval     :: POSIXTime
-    , announceTarget       :: dta -> nid
-    }
-
-data DHTSearch nid ni = forall addr tok r. DHTSearch
-    { searchThread     :: ThreadId
-    , searchState      :: SearchState nid addr tok ni r
-    , searchShowTok    :: tok -> Maybe String
-    , searchResults    :: TVar (Set.Set String)
-    }
-
-data DHTPing ni = forall r. DHTPing
-    { pingQuery :: [String] -> ni -> IO (Maybe r)
-    , pingShowResult :: r -> String
-    }
-
-data DHT = forall nid ni. ( Show     ni
-                          , Read     ni
-                          , ToJSON   ni
-                          , FromJSON ni
-                          , Ord      ni
-                          , Hashable ni
-                          , Show     nid
-                          , Ord      nid
-                          , Hashable nid
-                          , Typeable ni
-                          , S.Serialize nid
-                          ) =>
-    DHT
-    { dhtBuckets       :: TVar (BucketList ni)
-    , dhtSecretKey     :: STM (Maybe SecretKey)
-    , dhtPing          :: Map.Map String (DHTPing ni)
-    , dhtQuery         :: Map.Map String (DHTQuery nid ni)
-    , dhtAnnouncables  :: Map.Map String (DHTAnnouncable nid)
-    , dhtParseId       :: String -> Either String nid
-    , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
-    , dhtFallbackNodes :: IO [ni]
-    , dhtBootstrap     :: [ni] -> [ni] -> IO ()
-    }
-
-nodesFileName :: String -> String
-nodesFileName netname = netname ++ "-nodes.json"
-
-saveNodes :: String -> DHT -> IO ()
-saveNodes netname DHT{dhtBuckets} = do
-    bkts <- atomically $ readTVar dhtBuckets
-    let ns = map fst $ concat $ R.toList bkts
-        bs = J.encode ns
-        fname = nodesFileName netname
-    L.writeFile fname bs
-
-loadNodes :: FromJSON ni => String -> IO [ni]
-loadNodes netname = do
-    let fname = nodesFileName netname
-    attempt <- tryIOError $ do
-        J.decode <$> L.readFile fname
-         >>= maybe (ioError $ userError "Nothing") return
-    either (const $ fallbackLoad fname) return attempt
-
-fallbackLoad :: FromJSON t => FilePath -> IO [t]
-fallbackLoad fname = do
-    attempt <- tryIOError $ do
-        J.decode <$> L.readFile fname
-         >>= maybe (ioError $ userError "Nothing") return
-    let go r = do
-            let m = HashMap.lookup "nodes" (r :: J.Object)
-                ns0 = case m of Just (J.Array v) -> V.toList v
-                                Nothing        -> []
-                ns1 = zip (map J.fromJSON ns0) ns0
-                issuc (J.Error _,_) = False
-                issuc _             = True
-                (ss,fs) = partition issuc ns1
-                ns = map (\(J.Success n,_) -> n) ss
-            mapM_ print (map snd fs)  >> return ns
-    either (const $ return []) go attempt
-
 
 {-
 pingNodes :: String -> DHT -> IO Bool
diff --git a/src/Network/Kademlia/CommonAPI.hs b/src/Network/Kademlia/CommonAPI.hs
new file mode 100644
index 00000000..601be5d8
--- /dev/null
+++ b/src/Network/Kademlia/CommonAPI.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE ExistentialQuantification #-}
+module Network.Kademlia.CommonAPI where
+
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Data.Aeson                  as J (FromJSON, ToJSON)
+import Data.Hashable
+import qualified Data.Map          as Map
+import Data.Serialize              as S
+import qualified Data.Set          as Set
+import Data.Time.Clock.POSIX
+import Data.Typeable
+
+import Network.Kademlia.Search
+import Network.Kademlia.Routing as R
+import Crypto.Tox (SecretKey,PublicKey)
+
+data DHT = forall nid ni. ( Show     ni
+                          , Read     ni
+                          , ToJSON   ni
+                          , FromJSON ni
+                          , Ord      ni
+                          , Hashable ni
+                          , Show     nid
+                          , Ord      nid
+                          , Hashable nid
+                          , Typeable ni
+                          , S.Serialize nid
+                          ) =>
+    DHT
+    { dhtBuckets       :: TVar (BucketList ni)
+    , dhtSecretKey     :: STM (Maybe SecretKey)
+    , dhtPing          :: Map.Map String (DHTPing ni)
+    , dhtQuery         :: Map.Map String (DHTQuery nid ni)
+    , dhtAnnouncables  :: Map.Map String (DHTAnnouncable nid)
+    , dhtParseId       :: String -> Either String nid
+    , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
+    , dhtFallbackNodes :: IO [ni]
+    , dhtBootstrap     :: [ni] -> [ni] -> IO ()
+    }
+
+data DHTQuery nid ni = forall addr r tok.
+                        ( Ord addr
+                        , Typeable r
+                        , Typeable tok
+                        , Typeable ni
+                        ) => DHTQuery
+    { qsearch     :: Search nid addr tok ni r
+    , qhandler    :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination.
+    , qshowR      :: r -> String
+    , qshowTok    :: tok -> Maybe String
+    }
+
+data DHTAnnouncable nid = forall dta tok ni r.
+                        ( Show r
+                        , Typeable dta -- information being announced
+                        , Typeable tok -- token
+                        , Typeable r   -- search result
+                        , Typeable ni  -- node
+                        ) => DHTAnnouncable
+    { announceParseData    :: String -> Either String dta
+    , announceParseToken   :: dta -> String -> Either String tok
+    , announceParseAddress :: String -> Either String ni
+    , announceSendData     :: Either ( String {- search name -}
+                                     , String -> Either String r
+                                     , PublicKey {- me -} -> dta -> r -> IO ())
+                                     (dta -> tok -> Maybe ni -> IO (Maybe r))
+    , announceInterval     :: POSIXTime
+    , announceTarget       :: dta -> nid
+    }
+
+data DHTSearch nid ni = forall addr tok r. DHTSearch
+    { searchThread     :: ThreadId
+    , searchState      :: SearchState nid addr tok ni r
+    , searchShowTok    :: tok -> Maybe String
+    , searchResults    :: TVar (Set.Set String)
+    }
+
+data DHTPing ni = forall r. DHTPing
+    { pingQuery :: [String] -> ni -> IO (Maybe r)
+    , pingShowResult :: r -> String
+    }
+
diff --git a/src/Network/Kademlia/Persistence.hs b/src/Network/Kademlia/Persistence.hs
new file mode 100644
index 00000000..d7431671
--- /dev/null
+++ b/src/Network/Kademlia/Persistence.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE NamedFieldPuns            #-}
+module Network.Kademlia.Persistence where
+
+import Network.Kademlia.CommonAPI
+import Network.Kademlia.Routing as R
+
+import Control.Concurrent.STM
+import qualified Data.Aeson           as J
+         ;import Data.Aeson           as J (FromJSON)
+import qualified Data.ByteString.Lazy as L
+import qualified Data.HashMap.Strict  as HashMap
+import Data.List
+import qualified Data.Vector          as V
+import System.IO.Error
+
+saveNodes :: String -> DHT -> IO ()
+saveNodes netname DHT{dhtBuckets} = do
+    bkts <- atomically $ readTVar dhtBuckets
+    let ns = map fst $ concat $ R.toList bkts
+        bs = J.encode ns
+        fname = nodesFileName netname
+    L.writeFile fname bs
+
+loadNodes :: FromJSON ni => String -> IO [ni]
+loadNodes netname = do
+    let fname = nodesFileName netname
+    attempt <- tryIOError $ do
+        J.decode <$> L.readFile fname
+         >>= maybe (ioError $ userError "Nothing") return
+    either (const $ fallbackLoad fname) return attempt
+
+nodesFileName :: String -> String
+nodesFileName netname = netname ++ "-nodes.json"
+
+fallbackLoad :: FromJSON t => FilePath -> IO [t]
+fallbackLoad fname = do
+    attempt <- tryIOError $ do
+        J.decode <$> L.readFile fname
+         >>= maybe (ioError $ userError "Nothing") return
+    let go r = do
+            let m = HashMap.lookup "nodes" (r :: J.Object)
+                ns0 = case m of Just (J.Array v) -> V.toList v
+                                Nothing        -> []
+                ns1 = zip (map J.fromJSON ns0) ns0
+                issuc (J.Error _,_) = False
+                issuc _             = True
+                (ss,fs) = partition issuc ns1
+                ns = map (\(J.Success n,_) -> n) ss
+            mapM_ print (map snd fs)  >> return ns
+    either (const $ return []) go attempt
+