diff options
author | joe <joe@jerkface.net> | 2017-06-08 23:26:30 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-06-08 23:26:30 -0400 |
commit | 84798bfef62a001ded1bd628d846612f0b0ade80 (patch) | |
tree | 6a66e1d8fa014bea6f6562650134440a5a515f56 /src/Network/DHT/Mainline.hs | |
parent | cb2bd0bf4b5977ef6ec7ca7ab9ac0189457c2250 (diff) |
Generalized Network.DatagramServer
Diffstat (limited to 'src/Network/DHT/Mainline.hs')
-rw-r--r-- | src/Network/DHT/Mainline.hs | 71 |
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 | |||
24 | import Data.Serialize as S | 24 | import Data.Serialize as S |
25 | import Data.String | 25 | import Data.String |
26 | import Data.Typeable | 26 | import Data.Typeable |
27 | import Network.DatagramServer.Mainline (NodeId(..)) | ||
27 | import Network.DatagramServer.Mainline as KRPC | 28 | import Network.DatagramServer.Mainline as KRPC |
28 | import Network.DatagramServer.Types as RPC | 29 | import Network.DatagramServer.Types as RPC |
29 | import Text.PrettyPrint as PP hiding ((<>)) | 30 | import Text.PrettyPrint as PP hiding ((<>)) |
30 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) | 31 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) |
31 | 32 | ||
32 | nodeIdSize = finiteBitSize (undefined :: NodeId KMessageOf) `div` 8 | ||
33 | |||
34 | instance 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 | ||
41 | instance (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 | |||
45 | instance Serialize (NodeId KMessageOf) where | ||
46 | get = NodeId <$> get | ||
47 | {-# INLINE get #-} | ||
48 | put (NodeId bs) = put bs | ||
49 | {-# INLINE put #-} | ||
50 | |||
51 | -- | ASCII encoded. | ||
52 | instance 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. | ||
60 | instance Default (NodeId KMessageOf) where | ||
61 | def = NodeId 0 | ||
62 | |||
63 | -- | base16 encoded. | ||
64 | instance 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 | ||
118 | instance 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 | |||
144 | instance 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 | ||