diff options
Diffstat (limited to 'src/Network/Kademlia.hs')
-rw-r--r-- | src/Network/Kademlia.hs | 163 |
1 files changed, 0 insertions, 163 deletions
diff --git a/src/Network/Kademlia.hs b/src/Network/Kademlia.hs deleted file mode 100644 index e61afe9b..00000000 --- a/src/Network/Kademlia.hs +++ /dev/null | |||
@@ -1,163 +0,0 @@ | |||
1 | {-# LANGUAGE CPP, ScopedTypeVariables, PartialTypeSignatures, FlexibleContexts #-} | ||
2 | {-# LANGUAGE KindSignatures #-} | ||
3 | {-# LANGUAGE DeriveFunctor, DeriveTraversable #-} | ||
4 | -- {-# LANGUAGE TypeFamilies #-} | ||
5 | {-# LANGUAGE GADTs #-} | ||
6 | {-# LANGUAGE PatternSynonyms #-} | ||
7 | module Network.Kademlia where | ||
8 | |||
9 | import Data.Maybe | ||
10 | import Data.Time.Clock.POSIX | ||
11 | import Network.Kademlia.Routing as R | ||
12 | #ifdef THREAD_DEBUG | ||
13 | import Control.Concurrent.Lifted.Instrument | ||
14 | #else | ||
15 | import Control.Concurrent.Lifted | ||
16 | import GHC.Conc (labelThread) | ||
17 | #endif | ||
18 | import Control.Concurrent.STM | ||
19 | import Control.Monad | ||
20 | import Data.Time.Clock.POSIX (POSIXTime) | ||
21 | |||
22 | -- | The status of a given node with respect to a given routint table. | ||
23 | data RoutingStatus | ||
24 | = Stranger -- ^ The node is unknown to the Kademlia routing table. | ||
25 | | Applicant -- ^ The node may be inserted pending a ping timeout. | ||
26 | | Accepted -- ^ The node has a slot in one of the Kademlia buckets. | ||
27 | deriving (Eq,Ord,Enum,Show,Read) | ||
28 | |||
29 | -- | A change occured in the kademlia routing table. | ||
30 | data RoutingTransition ni = RoutingTransition | ||
31 | { transitioningNode :: ni | ||
32 | , transitionedTo :: !RoutingStatus | ||
33 | } | ||
34 | deriving (Eq,Ord,Show,Read) | ||
35 | |||
36 | data InsertionReporter ni = InsertionReporter | ||
37 | { -- | Called on every inbound packet. Accepts: | ||
38 | -- | ||
39 | -- * Origin of packet. | ||
40 | -- | ||
41 | -- * List of nodes to be pinged as a result. | ||
42 | reportArrival :: POSIXTime | ||
43 | -> ni | ||
44 | -> [ni] | ||
45 | -> IO () | ||
46 | -- | Called on every ping probe. Accepts: | ||
47 | -- | ||
48 | -- * Who was pinged. | ||
49 | -- | ||
50 | -- * True Bool value if they ponged. | ||
51 | , reportPingResult :: POSIXTime | ||
52 | -> ni | ||
53 | -> Bool | ||
54 | -> IO () | ||
55 | } | ||
56 | |||
57 | quietInsertions :: InsertionReporter ni | ||
58 | quietInsertions = InsertionReporter | ||
59 | { reportArrival = \_ _ _ -> return () | ||
60 | , reportPingResult = \_ _ _ -> return () | ||
61 | } | ||
62 | |||
63 | contramapIR :: (t -> ni) -> InsertionReporter ni -> InsertionReporter t | ||
64 | contramapIR f ir = InsertionReporter | ||
65 | { reportArrival = \tm ni nis -> reportArrival ir tm (f ni) (map f nis) | ||
66 | , reportPingResult = \tm ni b -> reportPingResult ir tm (f ni) b | ||
67 | } | ||
68 | |||
69 | -- | All the IO operations necessary to maintain a Kademlia routing table. | ||
70 | data TableStateIO ni = TableStateIO | ||
71 | { -- | Write the routing table. Typically 'writeTVar'. | ||
72 | tblWrite :: R.BucketList ni -> STM () | ||
73 | |||
74 | -- | Read the routing table. Typically 'readTVar'. | ||
75 | , tblRead :: STM (R.BucketList ni) | ||
76 | |||
77 | -- | Issue a ping to a remote node and report 'True' if the node | ||
78 | -- responded within an acceptable time and 'False' otherwise. | ||
79 | , tblPing :: ni -> IO Bool | ||
80 | |||
81 | -- | Convenience method provided to assist in maintaining state | ||
82 | -- consistent with the routing table. It will be invoked in the same | ||
83 | -- transaction that 'tblRead'\/'tblWrite' occured but only when there was | ||
84 | -- an interesting change. The returned IO action will be triggered soon | ||
85 | -- afterward. | ||
86 | -- | ||
87 | -- It is not necessary to do anything interesting here. The following | ||
88 | -- trivial implementation is fine: | ||
89 | -- | ||
90 | -- > tblTransition = const $ return $ return () | ||
91 | , tblTransition :: RoutingTransition ni -> STM (IO ()) | ||
92 | } | ||
93 | |||
94 | vanillaIO :: TVar (BucketList ni) -> (ni -> IO Bool) -> TableStateIO ni | ||
95 | vanillaIO var ping = TableStateIO | ||
96 | { tblRead = readTVar var | ||
97 | , tblWrite = writeTVar var | ||
98 | , tblPing = ping | ||
99 | , tblTransition = const $ return $ return () | ||
100 | } | ||
101 | |||
102 | -- | Everything necessary to maintain a routing table of /ni/ (node | ||
103 | -- information) entries. | ||
104 | data Kademlia nid ni = Kademlia { kademInsertionReporter :: InsertionReporter ni | ||
105 | , kademSpace :: KademliaSpace nid ni | ||
106 | , kademIO :: TableStateIO ni | ||
107 | } | ||
108 | |||
109 | |||
110 | -- Helper to 'insertNode'. | ||
111 | -- | ||
112 | -- Adapt return value from 'updateForPingResult' into a | ||
113 | -- more easily grokked list of transitions. | ||
114 | transition :: (ni,Maybe (t,ni)) -> [RoutingTransition ni] | ||
115 | transition (x,m) = | ||
116 | -- Just _ <- m = Node transition: Accepted --> Stranger | ||
117 | -- Nothing <- m = Node transition: Applicant --> Stranger | ||
118 | RoutingTransition x Stranger | ||
119 | : maybeToList (accepted <$> m) | ||
120 | |||
121 | -- Helper to 'transition' | ||
122 | -- | ||
123 | -- Node transition: Applicant --> Accepted | ||
124 | accepted :: (t,ni) -> RoutingTransition ni | ||
125 | accepted (_,y) = RoutingTransition y Accepted | ||
126 | |||
127 | |||
128 | insertNode :: Kademlia nid ni -> ni -> IO () | ||
129 | insertNode (Kademlia reporter space io) node = do | ||
130 | |||
131 | tm <- getPOSIXTime | ||
132 | |||
133 | (ps,reaction) <- atomically $ do | ||
134 | tbl <- tblRead io | ||
135 | let (inserted, ps,t') = R.updateForInbound space tm node tbl | ||
136 | tblWrite io t' | ||
137 | reaction <- case ps of | ||
138 | _ | inserted -> -- Node transition: Stranger --> Accepted | ||
139 | tblTransition io $ RoutingTransition node Accepted | ||
140 | (_:_) -> -- Node transition: Stranger --> Applicant | ||
141 | tblTransition io $ RoutingTransition node Applicant | ||
142 | _ -> return $ return () | ||
143 | return (ps, reaction) | ||
144 | |||
145 | reportArrival reporter tm node ps | ||
146 | reaction | ||
147 | |||
148 | _ <- fork $ do | ||
149 | myThreadId >>= flip labelThread "pingResults" | ||
150 | forM_ ps $ \n -> do | ||
151 | b <- tblPing io n | ||
152 | reportPingResult reporter tm n b -- XXX: tm is timestamp of original triggering packet, not result | ||
153 | join $ atomically $ do | ||
154 | tbl <- tblRead io | ||
155 | let (replacements, t') = R.updateForPingResult space n b tbl | ||
156 | tblWrite io t' | ||
157 | ios <- sequence $ concatMap | ||
158 | (map (tblTransition io) . transition) | ||
159 | replacements | ||
160 | return $ sequence_ ios | ||
161 | |||
162 | return () | ||
163 | |||