summaryrefslogtreecommitdiff
path: root/examples/dhtd.hs
diff options
context:
space:
mode:
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r--examples/dhtd.hs108
1 files changed, 3 insertions, 105 deletions
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
72import Network.Address hiding (NodeId, NodeInfo(..)) 72import Network.Address hiding (NodeId, NodeInfo(..))
73import Network.QueryResponse 73import Network.QueryResponse
74import Network.StreamServer 74import Network.StreamServer
75import Network.Kademlia.CommonAPI
76import Network.Kademlia.Persistence
77import Network.Kademlia.Routing as R
75import Network.Kademlia.Search 78import Network.Kademlia.Search
76import qualified Network.BitTorrent.MainlineDHT as Mainline 79import qualified Network.BitTorrent.MainlineDHT as Mainline
77import qualified Network.Tox as Tox 80import qualified Network.Tox as Tox
78import Network.Kademlia.Routing as R
79import Data.Aeson as J (ToJSON, FromJSON)
80import qualified Data.Aeson as J
81import qualified Data.ByteString.Lazy as L 81import qualified Data.ByteString.Lazy as L
82import qualified Data.ByteString.Char8 as B 82import qualified Data.ByteString.Char8 as B
83import qualified Data.Text as T 83import qualified Data.Text as T
@@ -159,108 +159,6 @@ hPutClientChunk (ClientHandle h hstate) s = do
159 hPutStr h (' ' : marshalForClient s) 159 hPutStr h (' ' : marshalForClient s)
160 putMVar hstate 2 -- ready for more output 160 putMVar hstate 2 -- ready for more output
161 161
162data DHTQuery nid ni = forall addr r tok.
163 ( Ord addr
164 , Typeable r
165 , Typeable tok
166 , Typeable ni
167 ) => DHTQuery
168 { qsearch :: Search nid addr tok ni r
169 , qhandler :: ni -> nid -> IO ([ni], [r], Maybe tok) -- ^ Invoked on local node, when there is no query destination.
170 , qshowR :: r -> String
171 , qshowTok :: tok -> Maybe String
172 }
173
174data DHTAnnouncable nid = forall dta tok ni r.
175 ( Show r
176 , Typeable dta -- information being announced
177 , Typeable tok -- token
178 , Typeable r -- search result
179 , Typeable ni -- node
180 ) => DHTAnnouncable
181 { announceParseData :: String -> Either String dta
182 , announceParseToken :: dta -> String -> Either String tok
183 , announceParseAddress :: String -> Either String ni
184 , announceSendData :: Either ( String {- search name -}
185 , String -> Either String r
186 , PublicKey {- me -} -> dta -> r -> IO ())
187 (dta -> tok -> Maybe ni -> IO (Maybe r))
188 , announceInterval :: POSIXTime
189 , announceTarget :: dta -> nid
190 }
191
192data DHTSearch nid ni = forall addr tok r. DHTSearch
193 { searchThread :: ThreadId
194 , searchState :: SearchState nid addr tok ni r
195 , searchShowTok :: tok -> Maybe String
196 , searchResults :: TVar (Set.Set String)
197 }
198
199data DHTPing ni = forall r. DHTPing
200 { pingQuery :: [String] -> ni -> IO (Maybe r)
201 , pingShowResult :: r -> String
202 }
203
204data DHT = forall nid ni. ( Show ni
205 , Read ni
206 , ToJSON ni
207 , FromJSON ni
208 , Ord ni
209 , Hashable ni
210 , Show nid
211 , Ord nid
212 , Hashable nid
213 , Typeable ni
214 , S.Serialize nid
215 ) =>
216 DHT
217 { dhtBuckets :: TVar (BucketList ni)
218 , dhtSecretKey :: STM (Maybe SecretKey)
219 , dhtPing :: Map.Map String (DHTPing ni)
220 , dhtQuery :: Map.Map String (DHTQuery nid ni)
221 , dhtAnnouncables :: Map.Map String (DHTAnnouncable nid)
222 , dhtParseId :: String -> Either String nid
223 , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
224 , dhtFallbackNodes :: IO [ni]
225 , dhtBootstrap :: [ni] -> [ni] -> IO ()
226 }
227
228nodesFileName :: String -> String
229nodesFileName netname = netname ++ "-nodes.json"
230
231saveNodes :: String -> DHT -> IO ()
232saveNodes netname DHT{dhtBuckets} = do
233 bkts <- atomically $ readTVar dhtBuckets
234 let ns = map fst $ concat $ R.toList bkts
235 bs = J.encode ns
236 fname = nodesFileName netname
237 L.writeFile fname bs
238
239loadNodes :: FromJSON ni => String -> IO [ni]
240loadNodes netname = do
241 let fname = nodesFileName netname
242 attempt <- tryIOError $ do
243 J.decode <$> L.readFile fname
244 >>= maybe (ioError $ userError "Nothing") return
245 either (const $ fallbackLoad fname) return attempt
246
247fallbackLoad :: FromJSON t => FilePath -> IO [t]
248fallbackLoad fname = do
249 attempt <- tryIOError $ do
250 J.decode <$> L.readFile fname
251 >>= maybe (ioError $ userError "Nothing") return
252 let go r = do
253 let m = HashMap.lookup "nodes" (r :: J.Object)
254 ns0 = case m of Just (J.Array v) -> V.toList v
255 Nothing -> []
256 ns1 = zip (map J.fromJSON ns0) ns0
257 issuc (J.Error _,_) = False
258 issuc _ = True
259 (ss,fs) = partition issuc ns1
260 ns = map (\(J.Success n,_) -> n) ss
261 mapM_ print (map snd fs) >> return ns
262 either (const $ return []) go attempt
263
264 162
265{- 163{-
266pingNodes :: String -> DHT -> IO Bool 164pingNodes :: String -> DHT -> IO Bool