summaryrefslogtreecommitdiff
path: root/src/Network/DHT
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-06-08 23:26:30 -0400
committerjoe <joe@jerkface.net>2017-06-08 23:26:30 -0400
commit84798bfef62a001ded1bd628d846612f0b0ade80 (patch)
tree6a66e1d8fa014bea6f6562650134440a5a515f56 /src/Network/DHT
parentcb2bd0bf4b5977ef6ec7ca7ab9ac0189457c2250 (diff)
Generalized Network.DatagramServer
Diffstat (limited to 'src/Network/DHT')
-rw-r--r--src/Network/DHT/Mainline.hs71
1 files changed, 1 insertions, 70 deletions
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs
index 7b3d6d55..2ecb9845 100644
--- a/src/Network/DHT/Mainline.hs
+++ b/src/Network/DHT/Mainline.hs
@@ -24,46 +24,12 @@ import Data.LargeWord
24import Data.Serialize as S 24import Data.Serialize as S
25import Data.String 25import Data.String
26import Data.Typeable 26import Data.Typeable
27import Network.DatagramServer.Mainline (NodeId(..))
27import Network.DatagramServer.Mainline as KRPC 28import Network.DatagramServer.Mainline as KRPC
28import Network.DatagramServer.Types as RPC 29import Network.DatagramServer.Types as RPC
29import Text.PrettyPrint as PP hiding ((<>)) 30import Text.PrettyPrint as PP hiding ((<>))
30import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) 31import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
31 32
32nodeIdSize = finiteBitSize (undefined :: NodeId KMessageOf) `div` 8
33
34instance BEncode (NodeId KMessageOf) where
35 toBEncode (NodeId w) = toBEncode $ S.encode w
36 fromBEncode bval = fromBEncode bval >>= S.decode
37
38-- instance BEncode NodeId where TODO
39
40-- TODO: put this somewhere appropriate
41instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
42 put (LargeKey lo hi) = put hi >> put lo
43 get = flip LargeKey <$> get <*> get
44
45instance Serialize (NodeId KMessageOf) where
46 get = NodeId <$> get
47 {-# INLINE get #-}
48 put (NodeId bs) = put bs
49 {-# INLINE put #-}
50
51-- | ASCII encoded.
52instance IsString (NodeId KMessageOf) where
53 fromString str
54 | length str == nodeIdSize = NodeId (either error id $ S.decode (fromString str :: ByteString))
55 | length str == 2 * nodeIdSize = NodeId (either error id $ S.decode (fst $ Base16.decode $ fromString str))
56 | otherwise = error "fromString: invalid NodeId length"
57 {-# INLINE fromString #-}
58
59-- | Meaningless node id, for testing purposes only.
60instance Default (NodeId KMessageOf) where
61 def = NodeId 0
62
63-- | base16 encoded.
64instance Pretty (NodeId KMessageOf) where
65 pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid
66
67-- | KRPC 'compact list' compatible encoding: contact information for 33-- | KRPC 'compact list' compatible encoding: contact information for
68-- nodes is encoded as a 26-byte string. Also known as "Compact node 34-- nodes is encoded as a 26-byte string. Also known as "Compact node
69-- info" the 20-byte Node ID in network byte order has the compact 35-- info" the 20-byte Node ID in network byte order has the compact
@@ -115,38 +81,3 @@ bep42 addr (NodeId r)
115 81
116 82
117 83
118instance Envelope KMessageOf where
119 type TransactionID KMessageOf = KRPC.TransactionId
120
121 -- | Each node has a globally unique identifier known as the \"node
122 -- ID.\"
123 --
124 -- Normally, /this/ node id should be saved between invocations
125 -- of the client software.
126 newtype NodeId KMessageOf = NodeId Word160
127 deriving (Show, Eq, Ord, Typeable, Bits, FiniteBits)
128
129 envelopePayload (Q q) = queryArgs q
130 envelopePayload (R r) = respVals r
131 envelopePayload (E _) = error "TODO: messagePayload for KError"
132
133 envelopeTransaction (Q q) = queryId q
134 envelopeTransaction (R r) = respId r
135 envelopeTransaction (E e) = errorId e
136
137 envelopeClass (Q _) = Query
138 envelopeClass (R _) = Response
139 envelopeClass (E _) = Error
140
141 buildReply self addr qry response =
142 (R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr)))
143
144instance WireFormat BValue KMessageOf where
145 type SerializableTo BValue = BEncode
146 type CipherContext BValue KMessageOf = ()
147
148 decodeHeaders _ bs = BE.decode bs >>= BE.fromBEncode
149 decodePayload kmsg = mapM BE.fromBEncode kmsg
150
151 encodeHeaders _ kmsg = L.toStrict $ BE.encode kmsg
152 encodePayload msg = fmap BE.toBEncode msg