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

2 files changed, 135 insertions, 0 deletions

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
+