diff options
Diffstat (limited to 'examples/dhtd.hs')
-rw-r--r-- | examples/dhtd.hs | 108 |
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 | |||
72 | import Network.Address hiding (NodeId, NodeInfo(..)) | 72 | import Network.Address hiding (NodeId, NodeInfo(..)) |
73 | import Network.QueryResponse | 73 | import Network.QueryResponse |
74 | import Network.StreamServer | 74 | import Network.StreamServer |
75 | import Network.Kademlia.CommonAPI | ||
76 | import Network.Kademlia.Persistence | ||
77 | import Network.Kademlia.Routing as R | ||
75 | import Network.Kademlia.Search | 78 | import Network.Kademlia.Search |
76 | import qualified Network.BitTorrent.MainlineDHT as Mainline | 79 | import qualified Network.BitTorrent.MainlineDHT as Mainline |
77 | import qualified Network.Tox as Tox | 80 | import qualified Network.Tox as Tox |
78 | import Network.Kademlia.Routing as R | ||
79 | import Data.Aeson as J (ToJSON, FromJSON) | ||
80 | import qualified Data.Aeson as J | ||
81 | import qualified Data.ByteString.Lazy as L | 81 | import qualified Data.ByteString.Lazy as L |
82 | import qualified Data.ByteString.Char8 as B | 82 | import qualified Data.ByteString.Char8 as B |
83 | import qualified Data.Text as T | 83 | import 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 | ||
162 | data 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 | |||
174 | data 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 | |||
192 | data 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 | |||
199 | data DHTPing ni = forall r. DHTPing | ||
200 | { pingQuery :: [String] -> ni -> IO (Maybe r) | ||
201 | , pingShowResult :: r -> String | ||
202 | } | ||
203 | |||
204 | data 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 | |||
228 | nodesFileName :: String -> String | ||
229 | nodesFileName netname = netname ++ "-nodes.json" | ||
230 | |||
231 | saveNodes :: String -> DHT -> IO () | ||
232 | saveNodes 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 | |||
239 | loadNodes :: FromJSON ni => String -> IO [ni] | ||
240 | loadNodes 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 | |||
247 | fallbackLoad :: FromJSON t => FilePath -> IO [t] | ||
248 | fallbackLoad 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 | {- |
266 | pingNodes :: String -> DHT -> IO Bool | 164 | pingNodes :: String -> DHT -> IO Bool |