forked from schmittlauch/Hash2Pub
Compare commits
3 commits
d049b65f1e
...
b8eeb852da
Author | SHA1 | Date | |
---|---|---|---|
Trolli Schmittlauch | b8eeb852da | ||
Trolli Schmittlauch | 7fd369c8c5 | ||
Hécate | 41e999ed99 |
8
.hlint.yaml
Normal file
8
.hlint.yaml
Normal file
|
@ -0,0 +1,8 @@
|
||||||
|
- group: {name: generalise, enabled: true}
|
||||||
|
|
||||||
|
- warn: { name: Use DerivingStrategies }
|
||||||
|
|
||||||
|
- error: { lhs: return, rhs: pure }
|
||||||
|
|
||||||
|
- ignore: {name: "Avoid lambda using `infix`"}
|
||||||
|
|
|
@ -23,6 +23,7 @@ in
|
||||||
haddock
|
haddock
|
||||||
cabal-install
|
cabal-install
|
||||||
hlint
|
hlint
|
||||||
|
stylish-haskell
|
||||||
pkgs.python3Packages.asn1ate
|
pkgs.python3Packages.asn1ate
|
||||||
];
|
];
|
||||||
};
|
};
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
import Hash2Pub.FediChord
|
|
||||||
import Data.Map.Internal.Debug (showTree)
|
import Data.Map.Internal.Debug (showTree)
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Hash2Pub.FediChord
|
||||||
|
|
||||||
giebMalCache :: [Integer] -> Map.Map NodeID ()
|
giebMalCache :: [Integer] -> Map.Map NodeID ()
|
||||||
giebMalCache = Map.fromList . map (mkCacheEntry . fromInteger)
|
giebMalCache = Map.fromList . fmap (mkCacheEntry . fromInteger)
|
||||||
where
|
where
|
||||||
mkCacheEntry nodeid = (nodeid, ())
|
mkCacheEntry nodeid = (nodeid, ())
|
||||||
|
|
||||||
|
@ -22,7 +22,7 @@ edgeCase1 = do
|
||||||
putStrLn "\nWhile (NodeID 2^255+2^254+3) > (NodeID 2^254 + 14) …"
|
putStrLn "\nWhile (NodeID 2^255+2^254+3) > (NodeID 2^254 + 14) …"
|
||||||
print $ toNodeID (2^255+2^254+3) > toNodeID (2^254+14)
|
print $ toNodeID (2^255+2^254+3) > toNodeID (2^254+14)
|
||||||
putStrLn "… and 2^255+2^254+3 is an element of the map…"
|
putStrLn "… and 2^255+2^254+3 is an element of the map…"
|
||||||
print $ Map.member (fromInteger 2^255+2^254+3) testOverlap
|
print $ Map.member (fromInteger (2^255+2^254+3)) testOverlap
|
||||||
putStrLn "… looking for an element larger than 2^254 + 14 doesn't yield any."
|
putStrLn "… looking for an element larger than 2^254 + 14 doesn't yield any."
|
||||||
print $ nidLookupGT testOverlap (2^254+14)
|
print $ nidLookupGT testOverlap (2^254+14)
|
||||||
putStrLn "\nThat's the tree of the map:"
|
putStrLn "\nThat's the tree of the map:"
|
||||||
|
|
|
@ -2,23 +2,23 @@
|
||||||
|
|
||||||
module Hash2Pub.ASN1Coding where
|
module Hash2Pub.ASN1Coding where
|
||||||
|
|
||||||
import Data.ASN1.Encoding -- asn1-encoding package
|
|
||||||
import Data.ASN1.BinaryEncoding
|
|
||||||
import Data.ASN1.Error()
|
|
||||||
import Data.ASN1.Types -- asn1-types package
|
|
||||||
import Data.ASN1.Parse
|
|
||||||
import Data.Maybe (fromMaybe, mapMaybe, isNothing)
|
|
||||||
import Data.Time.Clock.POSIX()
|
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.Map.Strict as Map
|
|
||||||
import Data.Bifunctor (first)
|
|
||||||
import Control.Exception (displayException)
|
import Control.Exception (displayException)
|
||||||
|
import Data.ASN1.BinaryEncoding
|
||||||
|
import Data.ASN1.Encoding
|
||||||
|
import Data.ASN1.Error ()
|
||||||
|
import Data.ASN1.Parse
|
||||||
|
import Data.ASN1.Types
|
||||||
|
import Data.Bifunctor (first)
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Data.Time.Clock.POSIX ()
|
||||||
import Safe
|
import Safe
|
||||||
|
|
||||||
|
import Hash2Pub.DHTProtocol
|
||||||
import Hash2Pub.FediChord
|
import Hash2Pub.FediChord
|
||||||
import Hash2Pub.Utils
|
import Hash2Pub.Utils
|
||||||
import Hash2Pub.DHTProtocol
|
|
||||||
|
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
|
|
||||||
|
@ -107,7 +107,7 @@ serialiseMessage maxBytesLength msg =
|
||||||
payloadParts i = zip [1..] . splitPayload i <$> actionPayload
|
payloadParts i = zip [1..] . splitPayload i <$> actionPayload
|
||||||
actionPayload = payload msg
|
actionPayload = payload msg
|
||||||
encodedMsgs i = Map.map encodeMsg $ messageParts i
|
encodedMsgs i = Map.map encodeMsg $ messageParts i
|
||||||
maxMsgLength = maximum . map BS.length . Map.elems
|
maxMsgLength = maximum . fmap BS.length . Map.elems
|
||||||
|
|
||||||
-- | encode a 'FediChordMessage' to a bytestring without further modification
|
-- | encode a 'FediChordMessage' to a bytestring without further modification
|
||||||
encodeMsg :: FediChordMessage -> BS.ByteString
|
encodeMsg :: FediChordMessage -> BS.ByteString
|
||||||
|
@ -127,21 +127,21 @@ encodePayload LeaveResponsePayload = [Null]
|
||||||
encodePayload payload'@LeaveRequestPayload{} =
|
encodePayload payload'@LeaveRequestPayload{} =
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: Start Sequence
|
: Start Sequence
|
||||||
: map (IntVal . getNodeID) (leaveSuccessors payload')
|
: fmap (IntVal . getNodeID) (leaveSuccessors payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, Start Sequence]
|
, Start Sequence]
|
||||||
++ map (IntVal . getNodeID) (leavePredecessors payload')
|
<> fmap (IntVal . getNodeID) (leavePredecessors payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, End Sequence]
|
, End Sequence]
|
||||||
-- currently StabiliseResponsePayload and LeaveRequestPayload are equal
|
-- currently StabiliseResponsePayload and LeaveRequestPayload are equal
|
||||||
encodePayload payload'@StabiliseResponsePayload{} =
|
encodePayload payload'@StabiliseResponsePayload{} =
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: Start Sequence
|
: Start Sequence
|
||||||
: map (IntVal . getNodeID) (stabiliseSuccessors payload')
|
: fmap (IntVal . getNodeID) (stabiliseSuccessors payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, Start Sequence]
|
, Start Sequence]
|
||||||
++ map (IntVal . getNodeID) (stabilisePredecessors payload')
|
<> fmap (IntVal . getNodeID) (stabilisePredecessors payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, End Sequence]
|
, End Sequence]
|
||||||
encodePayload payload'@StabiliseRequestPayload = [Null]
|
encodePayload payload'@StabiliseRequestPayload = [Null]
|
||||||
encodePayload payload'@QueryIDResponsePayload{} =
|
encodePayload payload'@QueryIDResponsePayload{} =
|
||||||
|
@ -151,12 +151,12 @@ encodePayload payload'@QueryIDResponsePayload{} =
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: encodeQueryResult resp
|
: encodeQueryResult resp
|
||||||
: case resp of
|
: case resp of
|
||||||
FOUND ns -> encodeNodeState $ ns
|
FOUND ns -> encodeNodeState ns
|
||||||
FORWARD entrySet ->
|
FORWARD entrySet ->
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: (concatMap encodeCacheEntry . Set.elems $ entrySet)
|
: (concatMap encodeCacheEntry . Set.elems $ entrySet)
|
||||||
++ [End Sequence]
|
<> [End Sequence]
|
||||||
++ [End Sequence]
|
<> [End Sequence]
|
||||||
encodePayload payload'@QueryIDRequestPayload{} = [
|
encodePayload payload'@QueryIDRequestPayload{} = [
|
||||||
Start Sequence
|
Start Sequence
|
||||||
, IntVal . getNodeID $ queryTargetID payload'
|
, IntVal . getNodeID $ queryTargetID payload'
|
||||||
|
@ -167,21 +167,21 @@ encodePayload payload'@QueryIDRequestPayload{} = [
|
||||||
encodePayload payload'@JoinResponsePayload{} =
|
encodePayload payload'@JoinResponsePayload{} =
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: Start Sequence
|
: Start Sequence
|
||||||
: map (IntVal . getNodeID) (joinSuccessors payload')
|
: fmap (IntVal . getNodeID) (joinSuccessors payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, Start Sequence]
|
, Start Sequence]
|
||||||
++ map (IntVal . getNodeID) (joinPredecessors payload')
|
<> fmap (IntVal . getNodeID) (joinPredecessors payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, Start Sequence]
|
, Start Sequence]
|
||||||
++ concatMap encodeCacheEntry (joinCache payload')
|
<> concatMap encodeCacheEntry (joinCache payload')
|
||||||
++ [End Sequence
|
<> [End Sequence
|
||||||
, End Sequence]
|
, End Sequence]
|
||||||
encodePayload payload'@JoinRequestPayload{} = [Null]
|
encodePayload payload'@JoinRequestPayload{} = [Null]
|
||||||
encodePayload PingRequestPayload{} = [Null]
|
encodePayload PingRequestPayload{} = [Null]
|
||||||
encodePayload payload'@PingResponsePayload{} =
|
encodePayload payload'@PingResponsePayload{} =
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: concatMap encodeNodeState (pingNodeStates payload')
|
: concatMap encodeNodeState (pingNodeStates payload')
|
||||||
++ [End Sequence]
|
<> [End Sequence]
|
||||||
|
|
||||||
encodeNodeState :: NodeState -> [ASN1]
|
encodeNodeState :: NodeState -> [ASN1]
|
||||||
encodeNodeState ns = [
|
encodeNodeState ns = [
|
||||||
|
@ -200,7 +200,7 @@ encodeCacheEntry (RemoteCacheEntry ns timestamp) =
|
||||||
Start Sequence
|
Start Sequence
|
||||||
: encodeNodeState ns
|
: encodeNodeState ns
|
||||||
-- ToDo: possibly optimise this by using dlists
|
-- ToDo: possibly optimise this by using dlists
|
||||||
++ [
|
<> [
|
||||||
IntVal . fromIntegral . fromEnum $ timestamp
|
IntVal . fromIntegral . fromEnum $ timestamp
|
||||||
, End Sequence]
|
, End Sequence]
|
||||||
encodeCacheEntry _ = []
|
encodeCacheEntry _ = []
|
||||||
|
@ -218,11 +218,11 @@ encodeMessage
|
||||||
: (Enumerated . fromIntegral . fromEnum $ action)
|
: (Enumerated . fromIntegral . fromEnum $ action)
|
||||||
: IntVal requestID
|
: IntVal requestID
|
||||||
: encodeNodeState sender
|
: encodeNodeState sender
|
||||||
++ [
|
<> [
|
||||||
IntVal parts
|
IntVal parts
|
||||||
, IntVal part ]
|
, IntVal part ]
|
||||||
++ maybe [] encodePayload requestPayload
|
<> maybe [] encodePayload requestPayload
|
||||||
++ [End Sequence]
|
<> [End Sequence]
|
||||||
encodeMessage
|
encodeMessage
|
||||||
(Response responseTo senderID parts part action responsePayload) = [
|
(Response responseTo senderID parts part action responsePayload) = [
|
||||||
Start Sequence
|
Start Sequence
|
||||||
|
@ -231,8 +231,8 @@ encodeMessage
|
||||||
, IntVal parts
|
, IntVal parts
|
||||||
, IntVal part
|
, IntVal part
|
||||||
, Enumerated . fromIntegral . fromEnum $ action]
|
, Enumerated . fromIntegral . fromEnum $ action]
|
||||||
++ maybe [] encodePayload responsePayload
|
<> maybe [] encodePayload responsePayload
|
||||||
++ [End Sequence]
|
<> [End Sequence]
|
||||||
|
|
||||||
-- ===== parser combinators =====
|
-- ===== parser combinators =====
|
||||||
|
|
||||||
|
@ -240,21 +240,21 @@ parseMessage :: ParseASN1 FediChordMessage
|
||||||
parseMessage = do
|
parseMessage = do
|
||||||
begin <- getNext
|
begin <- getNext
|
||||||
case begin of
|
case begin of
|
||||||
Start Sequence -> return ()
|
Start Sequence -> pure ()
|
||||||
x -> throwParseError $ "unexpected ASN.1 element " ++ show x
|
x -> throwParseError $ "unexpected ASN.1 element " <> show x
|
||||||
-- request and response messages are distiguishable by their structure,
|
-- request and response messages are distiguishable by their structure,
|
||||||
-- see ASN.1 schema
|
-- see ASN.1 schema
|
||||||
firstElem <- getNext
|
firstElem <- getNext
|
||||||
message <- case firstElem of
|
message <- case firstElem of
|
||||||
Enumerated a -> parseRequest . toEnum . fromIntegral $ a
|
Enumerated a -> parseRequest . toEnum . fromIntegral $ a
|
||||||
IntVal i -> parseResponse i
|
IntVal i -> parseResponse i
|
||||||
other -> throwParseError $ "unexpected first ASN1 element: " ++ show other
|
other -> throwParseError $ "unexpected first ASN1 element: " <> show other
|
||||||
-- consume sequence end
|
-- consume sequence end
|
||||||
end <- getNext
|
end <- getNext
|
||||||
case end of
|
case end of
|
||||||
End Sequence -> return ()
|
End Sequence -> pure ()
|
||||||
x -> throwParseError $ "unexpected ASN.1 element " ++ show x
|
x -> throwParseError $ "unexpected ASN.1 element " <> show x
|
||||||
return message
|
pure message
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -265,14 +265,14 @@ parseRequest action = do
|
||||||
parts <- parseInteger
|
parts <- parseInteger
|
||||||
part <- parseInteger
|
part <- parseInteger
|
||||||
hasPayload <- hasNext
|
hasPayload <- hasNext
|
||||||
payload <- if not hasPayload then return Nothing else Just <$> case action of
|
payload <- if not hasPayload then pure Nothing else Just <$> case action of
|
||||||
QueryID -> parseQueryIDRequest
|
QueryID -> parseQueryIDRequest
|
||||||
Join -> parseJoinRequest
|
Join -> parseJoinRequest
|
||||||
Leave -> parseLeaveRequest
|
Leave -> parseLeaveRequest
|
||||||
Stabilise -> parseStabiliseRequest
|
Stabilise -> parseStabiliseRequest
|
||||||
Ping -> parsePingRequest
|
Ping -> parsePingRequest
|
||||||
|
|
||||||
return $ Request requestID sender parts part action payload
|
pure $ Request requestID sender parts part action payload
|
||||||
|
|
||||||
parseResponse :: Integer -> ParseASN1 FediChordMessage
|
parseResponse :: Integer -> ParseASN1 FediChordMessage
|
||||||
parseResponse responseTo = do
|
parseResponse responseTo = do
|
||||||
|
@ -281,49 +281,49 @@ parseResponse responseTo = do
|
||||||
part <- parseInteger
|
part <- parseInteger
|
||||||
action <- parseEnum :: ParseASN1 Action
|
action <- parseEnum :: ParseASN1 Action
|
||||||
hasPayload <- hasNext
|
hasPayload <- hasNext
|
||||||
payload <- if not hasPayload then return Nothing else Just <$> case action of
|
payload <- if not hasPayload then pure Nothing else Just <$> case action of
|
||||||
QueryID -> parseQueryIDResponse
|
QueryID -> parseQueryIDResponse
|
||||||
Join -> parseJoinResponse
|
Join -> parseJoinResponse
|
||||||
Leave -> parseLeaveResponse
|
Leave -> parseLeaveResponse
|
||||||
Stabilise -> parseStabiliseResponse
|
Stabilise -> parseStabiliseResponse
|
||||||
Ping -> parsePingResponse
|
Ping -> parsePingResponse
|
||||||
|
|
||||||
return $ Response responseTo senderID parts part action payload
|
pure $ Response responseTo senderID parts part action payload
|
||||||
|
|
||||||
parseInteger :: ParseASN1 Integer
|
parseInteger :: ParseASN1 Integer
|
||||||
parseInteger = do
|
parseInteger = do
|
||||||
i <- getNext
|
i <- getNext
|
||||||
case i of
|
case i of
|
||||||
IntVal parsed -> return parsed
|
IntVal parsed -> pure parsed
|
||||||
x -> throwParseError $ "Expected IntVal but got " ++ show x
|
x -> throwParseError $ "Expected IntVal but got " <> show x
|
||||||
|
|
||||||
parseEnum :: Enum a => ParseASN1 a
|
parseEnum :: Enum a => ParseASN1 a
|
||||||
parseEnum = do
|
parseEnum = do
|
||||||
e <- getNext
|
e <- getNext
|
||||||
case e of
|
case e of
|
||||||
Enumerated en -> return $ toEnum . fromIntegral $ en
|
Enumerated en -> pure $ toEnum . fromIntegral $ en
|
||||||
x -> throwParseError $ "Expected Enumerated but got " ++ show x
|
x -> throwParseError $ "Expected Enumerated but got " <> show x
|
||||||
|
|
||||||
parseString :: ParseASN1 String
|
parseString :: ParseASN1 String
|
||||||
parseString = do
|
parseString = do
|
||||||
s <- getNext
|
s <- getNext
|
||||||
case s of
|
case s of
|
||||||
ASN1String toBeParsed -> maybe (throwParseError "string parsing failed") return $ asn1CharacterToString toBeParsed
|
ASN1String toBeParsed -> maybe (throwParseError "string parsing failed") pure $ asn1CharacterToString toBeParsed
|
||||||
x -> throwParseError $ "Expected a ASN1String but got " ++ show x
|
x -> throwParseError $ "Expected a ASN1String but got " <> show x
|
||||||
|
|
||||||
parseOctets :: ParseASN1 BS.ByteString
|
parseOctets :: ParseASN1 BS.ByteString
|
||||||
parseOctets = do
|
parseOctets = do
|
||||||
os <- getNext
|
os <- getNext
|
||||||
case os of
|
case os of
|
||||||
OctetString bs -> return bs
|
OctetString bs -> pure bs
|
||||||
x -> throwParseError $ "Expected an OctetString but got " ++ show x
|
x -> throwParseError $ "Expected an OctetString but got " <> show x
|
||||||
|
|
||||||
parseNull :: ParseASN1 ()
|
parseNull :: ParseASN1 ()
|
||||||
parseNull = do
|
parseNull = do
|
||||||
n <- getNext
|
n <- getNext
|
||||||
case n of
|
case n of
|
||||||
Null -> return ()
|
Null -> pure ()
|
||||||
x -> throwParseError $ "Expected Null but got " ++ show x
|
x -> throwParseError $ "Expected Null but got " <> show x
|
||||||
|
|
||||||
parseNodeState :: ParseASN1 NodeState
|
parseNodeState :: ParseASN1 NodeState
|
||||||
parseNodeState = onNextContainer Sequence $ do
|
parseNodeState = onNextContainer Sequence $ do
|
||||||
|
@ -333,7 +333,7 @@ parseNodeState = onNextContainer Sequence $ do
|
||||||
dhtPort' <- fromInteger <$> parseInteger
|
dhtPort' <- fromInteger <$> parseInteger
|
||||||
apPort' <- fromInteger <$> parseInteger
|
apPort' <- fromInteger <$> parseInteger
|
||||||
vServer' <- parseInteger
|
vServer' <- parseInteger
|
||||||
return NodeState {
|
pure NodeState {
|
||||||
nid = nid'
|
nid = nid'
|
||||||
, domain = domain'
|
, domain = domain'
|
||||||
, dhtPort = dhtPort'
|
, dhtPort = dhtPort'
|
||||||
|
@ -348,7 +348,7 @@ parseCacheEntry :: ParseASN1 RemoteCacheEntry
|
||||||
parseCacheEntry = onNextContainer Sequence $ do
|
parseCacheEntry = onNextContainer Sequence $ do
|
||||||
node <- parseNodeState
|
node <- parseNodeState
|
||||||
timestamp <- toEnum . fromIntegral <$> parseInteger
|
timestamp <- toEnum . fromIntegral <$> parseInteger
|
||||||
return $ RemoteCacheEntry node timestamp
|
pure $ RemoteCacheEntry node timestamp
|
||||||
|
|
||||||
parseNodeCache :: ParseASN1 [RemoteCacheEntry]
|
parseNodeCache :: ParseASN1 [RemoteCacheEntry]
|
||||||
parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
|
parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
|
||||||
|
@ -356,14 +356,14 @@ parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
|
||||||
parseJoinRequest :: ParseASN1 ActionPayload
|
parseJoinRequest :: ParseASN1 ActionPayload
|
||||||
parseJoinRequest = do
|
parseJoinRequest = do
|
||||||
parseNull
|
parseNull
|
||||||
return JoinRequestPayload
|
pure JoinRequestPayload
|
||||||
|
|
||||||
parseJoinResponse :: ParseASN1 ActionPayload
|
parseJoinResponse :: ParseASN1 ActionPayload
|
||||||
parseJoinResponse = onNextContainer Sequence $ do
|
parseJoinResponse = onNextContainer Sequence $ do
|
||||||
succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
||||||
pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
||||||
cache <- parseNodeCache
|
cache <- parseNodeCache
|
||||||
return $ JoinResponsePayload {
|
pure $ JoinResponsePayload {
|
||||||
joinSuccessors = succ'
|
joinSuccessors = succ'
|
||||||
, joinPredecessors = pred'
|
, joinPredecessors = pred'
|
||||||
, joinCache = cache
|
, joinCache = cache
|
||||||
|
@ -373,7 +373,7 @@ parseQueryIDRequest :: ParseASN1 ActionPayload
|
||||||
parseQueryIDRequest = onNextContainer Sequence $ do
|
parseQueryIDRequest = onNextContainer Sequence $ do
|
||||||
targetID <- fromInteger <$> parseInteger
|
targetID <- fromInteger <$> parseInteger
|
||||||
lBestNodes <- parseInteger
|
lBestNodes <- parseInteger
|
||||||
return $ QueryIDRequestPayload {
|
pure $ QueryIDRequestPayload {
|
||||||
queryTargetID = targetID
|
queryTargetID = targetID
|
||||||
, queryLBestNodes = lBestNodes
|
, queryLBestNodes = lBestNodes
|
||||||
}
|
}
|
||||||
|
@ -385,29 +385,29 @@ parseQueryIDResponse = onNextContainer Sequence $ do
|
||||||
0 -> FOUND <$> parseNodeState
|
0 -> FOUND <$> parseNodeState
|
||||||
1 -> FORWARD . Set.fromList <$> parseNodeCache
|
1 -> FORWARD . Set.fromList <$> parseNodeCache
|
||||||
_ -> throwParseError "invalid QueryIDResponse type"
|
_ -> throwParseError "invalid QueryIDResponse type"
|
||||||
return $ QueryIDResponsePayload {
|
pure $ QueryIDResponsePayload {
|
||||||
queryResult = result
|
queryResult = result
|
||||||
}
|
}
|
||||||
|
|
||||||
parseStabiliseRequest :: ParseASN1 ActionPayload
|
parseStabiliseRequest :: ParseASN1 ActionPayload
|
||||||
parseStabiliseRequest = do
|
parseStabiliseRequest = do
|
||||||
parseNull
|
parseNull
|
||||||
return StabiliseRequestPayload
|
pure StabiliseRequestPayload
|
||||||
|
|
||||||
parseStabiliseResponse :: ParseASN1 ActionPayload
|
parseStabiliseResponse :: ParseASN1 ActionPayload
|
||||||
parseStabiliseResponse = onNextContainer Sequence $ do
|
parseStabiliseResponse = onNextContainer Sequence $ do
|
||||||
succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
||||||
pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
||||||
return $ StabiliseResponsePayload {
|
pure $ StabiliseResponsePayload {
|
||||||
stabiliseSuccessors = succ'
|
stabiliseSuccessors = succ'
|
||||||
, stabilisePredecessors = pred'
|
, stabilisePredecessors = pred'
|
||||||
}
|
}
|
||||||
|
|
||||||
parseLeaveRequest :: ParseASN1 ActionPayload
|
parseLeaveRequest :: ParseASN1 ActionPayload
|
||||||
parseLeaveRequest = onNextContainer Sequence $ do
|
parseLeaveRequest = onNextContainer Sequence $ do
|
||||||
succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
||||||
pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
|
||||||
return $ LeaveRequestPayload {
|
pure $ LeaveRequestPayload {
|
||||||
leaveSuccessors = succ'
|
leaveSuccessors = succ'
|
||||||
, leavePredecessors = pred'
|
, leavePredecessors = pred'
|
||||||
}
|
}
|
||||||
|
@ -415,16 +415,16 @@ parseLeaveRequest = onNextContainer Sequence $ do
|
||||||
parseLeaveResponse :: ParseASN1 ActionPayload
|
parseLeaveResponse :: ParseASN1 ActionPayload
|
||||||
parseLeaveResponse = do
|
parseLeaveResponse = do
|
||||||
parseNull
|
parseNull
|
||||||
return LeaveResponsePayload
|
pure LeaveResponsePayload
|
||||||
|
|
||||||
parsePingRequest :: ParseASN1 ActionPayload
|
parsePingRequest :: ParseASN1 ActionPayload
|
||||||
parsePingRequest = do
|
parsePingRequest = do
|
||||||
parseNull
|
parseNull
|
||||||
return PingRequestPayload
|
pure PingRequestPayload
|
||||||
|
|
||||||
parsePingResponse :: ParseASN1 ActionPayload
|
parsePingResponse :: ParseASN1 ActionPayload
|
||||||
parsePingResponse = onNextContainer Sequence $ do
|
parsePingResponse = onNextContainer Sequence $ do
|
||||||
handledNodes <- getMany parseNodeState
|
handledNodes <- getMany parseNodeState
|
||||||
return $ PingResponsePayload {
|
pure $ PingResponsePayload {
|
||||||
pingNodeStates = handledNodes
|
pingNodeStates = handledNodes
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,5 +1,3 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Hash2Pub.DHTProtocol
|
module Hash2Pub.DHTProtocol
|
||||||
( QueryResponse (..)
|
( QueryResponse (..)
|
||||||
, queryLocalCache
|
, queryLocalCache
|
||||||
|
@ -17,28 +15,20 @@ module Hash2Pub.DHTProtocol
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Data.Maybe (maybe, fromMaybe)
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
import Data.Maybe (fromMaybe, maybe)
|
||||||
|
import qualified Data.Set as Set
|
||||||
import Data.Time.Clock.POSIX
|
import Data.Time.Clock.POSIX
|
||||||
import Network.Socket hiding (send, sendTo, recv, recvFrom)
|
import Network.Socket hiding (recv, recvFrom, send, sendTo)
|
||||||
import Network.Socket.ByteString
|
import Network.Socket.ByteString
|
||||||
|
|
||||||
import Hash2Pub.FediChord
|
import Hash2Pub.FediChord (CacheEntry (..), NodeCache, NodeID,
|
||||||
( NodeID
|
NodeState (..),
|
||||||
, NodeState (..)
|
cacheGetNodeStateUnvalidated,
|
||||||
, getSuccessors
|
cacheLookup, cacheLookupPred,
|
||||||
, putSuccessors
|
cacheLookupSucc, getPredecessors,
|
||||||
, getPredecessors
|
getSuccessors, localCompare,
|
||||||
, putPredecessors
|
putPredecessors, putSuccessors)
|
||||||
, cacheGetNodeStateUnvalidated
|
|
||||||
, NodeCache
|
|
||||||
, CacheEntry(..)
|
|
||||||
, cacheLookup
|
|
||||||
, cacheLookupSucc
|
|
||||||
, cacheLookupPred
|
|
||||||
, localCompare
|
|
||||||
)
|
|
||||||
|
|
||||||
import Debug.Trace (trace)
|
import Debug.Trace (trace)
|
||||||
|
|
||||||
|
@ -170,7 +160,7 @@ addCacheEntry :: RemoteCacheEntry -- ^ a remote cache entry received from netw
|
||||||
-> IO NodeCache -- ^ new node cache with the element inserted
|
-> IO NodeCache -- ^ new node cache with the element inserted
|
||||||
addCacheEntry entry cache = do
|
addCacheEntry entry cache = do
|
||||||
now <- getPOSIXTime
|
now <- getPOSIXTime
|
||||||
return $ addCacheEntryPure now entry cache
|
pure $ addCacheEntryPure now entry cache
|
||||||
|
|
||||||
-- | pure version of 'addCacheEntry' with current time explicitly specified as argument
|
-- | pure version of 'addCacheEntry' with current time explicitly specified as argument
|
||||||
addCacheEntryPure :: POSIXTime -- ^ current time
|
addCacheEntryPure :: POSIXTime -- ^ current time
|
||||||
|
@ -214,9 +204,9 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc
|
||||||
attempts :: Int -- ^ number of retries *i*
|
attempts :: Int -- ^ number of retries *i*
|
||||||
-> IO (Maybe a) -- ^ action to retry
|
-> IO (Maybe a) -- ^ action to retry
|
||||||
-> IO (Maybe a) -- ^ result after at most *i* retries
|
-> IO (Maybe a) -- ^ result after at most *i* retries
|
||||||
attempts 0 _ = return Nothing
|
attempts 0 _ = pure Nothing
|
||||||
attempts i action = do
|
attempts i action = do
|
||||||
actionResult <- action
|
actionResult <- action
|
||||||
case actionResult of
|
case actionResult of
|
||||||
Nothing -> attempts (i-1) action
|
Nothing -> attempts (i-1) action
|
||||||
Just res -> return $ Just res
|
Just res -> pure $ Just res
|
||||||
|
|
|
@ -1,4 +1,6 @@
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds, OverloadedStrings #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{- |
|
{- |
|
||||||
Module : FediChord
|
Module : FediChord
|
||||||
Description : An opinionated implementation of the EpiChord DHT by Leong et al.
|
Description : An opinionated implementation of the EpiChord DHT by Leong et al.
|
||||||
|
@ -45,25 +47,26 @@ module Hash2Pub.FediChord (
|
||||||
, cacheWriter
|
, cacheWriter
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Map.Strict as Map
|
|
||||||
import Network.Socket
|
|
||||||
import Data.Time.Clock.POSIX
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Data.Maybe (isJust, fromMaybe, mapMaybe)
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||||
|
import Data.Time.Clock.POSIX
|
||||||
|
import Network.Socket
|
||||||
|
|
||||||
-- for hashing and ID conversion
|
-- for hashing and ID conversion
|
||||||
import Crypto.Hash
|
|
||||||
import Data.Word
|
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import qualified Data.ByteString.UTF8 as BSU
|
|
||||||
import qualified Data.ByteArray as BA
|
|
||||||
import qualified Network.ByteOrder as NetworkBytes
|
|
||||||
import Data.IP (IPv6, fromHostAddress6, toHostAddress6)
|
|
||||||
import Data.IORef
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
import Control.Concurrent.STM.TQueue
|
import Control.Concurrent.STM.TQueue
|
||||||
import Control.Monad (forever)
|
import Control.Monad (forever)
|
||||||
|
import Crypto.Hash
|
||||||
|
import qualified Data.ByteArray as BA
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import qualified Data.ByteString.UTF8 as BSU
|
||||||
|
import Data.IORef
|
||||||
|
import Data.IP (IPv6, fromHostAddress6,
|
||||||
|
toHostAddress6)
|
||||||
import Data.Typeable (Typeable (..), typeOf)
|
import Data.Typeable (Typeable (..), typeOf)
|
||||||
|
import Data.Word
|
||||||
|
import qualified Network.ByteOrder as NetworkBytes
|
||||||
|
|
||||||
import Hash2Pub.Utils
|
import Hash2Pub.Utils
|
||||||
|
|
||||||
|
@ -280,12 +283,12 @@ lookupWrapper :: (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> (NodeID
|
||||||
lookupWrapper f fRepeat direction key cache =
|
lookupWrapper f fRepeat direction key cache =
|
||||||
case f key cache of
|
case f key cache of
|
||||||
-- the proxy entry found holds a
|
-- the proxy entry found holds a
|
||||||
Just (_, (ProxyEntry _ (Just entry@NodeEntry{}))) -> Just entry
|
Just (_, ProxyEntry _ (Just entry@NodeEntry{})) -> Just entry
|
||||||
-- proxy entry holds another proxy entry, this should not happen
|
-- proxy entry holds another proxy entry, this should not happen
|
||||||
Just (_, (ProxyEntry _ (Just (ProxyEntry _ _)))) -> Nothing
|
Just (_, ProxyEntry _ (Just (ProxyEntry _ _))) -> Nothing
|
||||||
-- proxy entry without own entry is a pointer on where to continue
|
-- proxy entry without own entry is a pointer on where to continue
|
||||||
-- if lookup direction is the same as pointer direction: follow pointer
|
-- if lookup direction is the same as pointer direction: follow pointer
|
||||||
Just (foundKey, (ProxyEntry (pointerID, pointerDirection) Nothing)) ->
|
Just (foundKey, ProxyEntry (pointerID, pointerDirection) Nothing) ->
|
||||||
let newKey = if pointerDirection == direction
|
let newKey = if pointerDirection == direction
|
||||||
then pointerID
|
then pointerID
|
||||||
else foundKey + (fromInteger . toInteger . fromEnum $ direction)
|
else foundKey + (fromInteger . toInteger . fromEnum $ direction)
|
||||||
|
@ -322,17 +325,17 @@ cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
|
||||||
cacheGetNodeStateUnvalidated :: CacheEntry -> NodeState
|
cacheGetNodeStateUnvalidated :: CacheEntry -> NodeState
|
||||||
cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState
|
cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState
|
||||||
cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry
|
cacheGetNodeStateUnvalidated (ProxyEntry _ (Just entry)) = cacheGetNodeStateUnvalidated entry
|
||||||
cacheGetNodeStateUnvalidated _ = error "trying to return empty node state, please report a bug"
|
cacheGetNodeStateUnvalidated _ = error "trying to pure empty node state, please report a bug"
|
||||||
|
|
||||||
-- | converts a 'HostAddress6' IP address to a big-endian strict ByteString
|
-- | converts a 'HostAddress6' IP address to a big-endian strict ByteString
|
||||||
ipAddrAsBS :: HostAddress6 -> BS.ByteString
|
ipAddrAsBS :: HostAddress6 -> BS.ByteString
|
||||||
ipAddrAsBS (a, b, c, d) = mconcat $ map NetworkBytes.bytestring32 [a, b, c, d]
|
ipAddrAsBS (a, b, c, d) = mconcat $ fmap NetworkBytes.bytestring32 [a, b, c, d]
|
||||||
|
|
||||||
-- | converts a ByteString in big endian order to an IPv6 address 'HostAddress6'
|
-- | converts a ByteString in big endian order to an IPv6 address 'HostAddress6'
|
||||||
bsAsIpAddr :: BS.ByteString -> HostAddress6
|
bsAsIpAddr :: BS.ByteString -> HostAddress6
|
||||||
bsAsIpAddr bytes = (a,b,c,d)
|
bsAsIpAddr bytes = (a,b,c,d)
|
||||||
where
|
where
|
||||||
a:b:c:d:_ = map NetworkBytes.word32 . chunkBytes 4 $ bytes
|
a:b:c:d:_ = fmap NetworkBytes.word32 . chunkBytes 4 $ bytes
|
||||||
|
|
||||||
|
|
||||||
-- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString
|
-- | generates a 256 bit long NodeID using SHAKE128, represented as ByteString
|
||||||
|
@ -344,7 +347,7 @@ genNodeIDBS ip nodeDomain vserver =
|
||||||
hashIpaddrUpper `BS.append` hashID nodeDomain' `BS.append` hashIpaddLower
|
hashIpaddrUpper `BS.append` hashID nodeDomain' `BS.append` hashIpaddLower
|
||||||
where
|
where
|
||||||
vsBS = BS.pack [vserver] -- attention: only works for vserver IDs up to 255
|
vsBS = BS.pack [vserver] -- attention: only works for vserver IDs up to 255
|
||||||
ipaddrNet = (BS.take 8 $ ipAddrAsBS ip) `BS.append` vsBS
|
ipaddrNet = BS.take 8 (ipAddrAsBS ip) `BS.append` vsBS
|
||||||
nodeDomain' = BSU.fromString nodeDomain `BS.append` vsBS
|
nodeDomain' = BSU.fromString nodeDomain `BS.append` vsBS
|
||||||
hashID bstr = BS.pack . BA.unpack $ (hash bstr :: Digest (SHAKE128 128))
|
hashID bstr = BS.pack . BA.unpack $ (hash bstr :: Digest (SHAKE128 128))
|
||||||
(hashIpaddrUpper, hashIpaddLower) = BS.splitAt 64 $ hashID ipaddrNet
|
(hashIpaddrUpper, hashIpaddLower) = BS.splitAt 64 $ hashID ipaddrNet
|
||||||
|
@ -391,7 +394,7 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs
|
||||||
--checkCacheSlices :: NodeState -> IO [()]
|
--checkCacheSlices :: NodeState -> IO [()]
|
||||||
--checkCacheSlices state = case getNodeCache state of
|
--checkCacheSlices state = case getNodeCache state of
|
||||||
-- -- don't do anything on nodes without a cache
|
-- -- don't do anything on nodes without a cache
|
||||||
-- Nothing -> return [()]
|
-- Nothing -> pure [()]
|
||||||
-- Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache'
|
-- Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache'
|
||||||
-- -- TODO: do the same for predecessors
|
-- -- TODO: do the same for predecessors
|
||||||
-- where
|
-- where
|
||||||
|
@ -415,10 +418,10 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs
|
||||||
-- -- TODO: replace empty IO actions with actual lookups to middle of slice
|
-- -- TODO: replace empty IO actions with actual lookups to middle of slice
|
||||||
-- -- TODO: validate ID before adding to cache
|
-- -- TODO: validate ID before adding to cache
|
||||||
-- case Map.lookupLT upperBound cache of
|
-- case Map.lookupLT upperBound cache of
|
||||||
-- Nothing -> return () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
|
-- Nothing -> pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
|
||||||
-- Just (matchID, _) ->
|
-- Just (matchID, _) ->
|
||||||
-- if
|
-- if
|
||||||
-- matchID <= lowerBound then return () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
|
-- matchID <= lowerBound then pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
|
||||||
-- else
|
-- else
|
||||||
-- checkSlice j ownID lowerBound (Just lastSuccNode) cache
|
-- checkSlice j ownID lowerBound (Just lastSuccNode) cache
|
||||||
|
|
||||||
|
@ -439,7 +442,7 @@ fediChordInit :: FediChordConf -> IO (Socket, NodeState)
|
||||||
fediChordInit conf = do
|
fediChordInit conf = do
|
||||||
initialState <- nodeStateInit conf
|
initialState <- nodeStateInit conf
|
||||||
serverSock <- mkServerSocket (ipAddr initialState) (dhtPort initialState)
|
serverSock <- mkServerSocket (ipAddr initialState) (dhtPort initialState)
|
||||||
return (serverSock, initialState)
|
pure (serverSock, initialState)
|
||||||
|
|
||||||
-- | initialises the 'NodeState' for this local node.
|
-- | initialises the 'NodeState' for this local node.
|
||||||
-- Separated from 'fediChordInit' to be usable in tests.
|
-- Separated from 'fediChordInit' to be usable in tests.
|
||||||
|
@ -467,7 +470,7 @@ nodeStateInit conf = do
|
||||||
, pNumParallelQueries = 2
|
, pNumParallelQueries = 2
|
||||||
, jEntriesPerSlice = 2
|
, jEntriesPerSlice = 2
|
||||||
}
|
}
|
||||||
return initialState
|
pure initialState
|
||||||
|
|
||||||
--fediChordJoin :: NodeState -- ^ the local 'NodeState'
|
--fediChordJoin :: NodeState -- ^ the local 'NodeState'
|
||||||
-- -> (String, PortNumber) -- ^ domain and port of a bootstrapping node
|
-- -> (String, PortNumber) -- ^ domain and port of a bootstrapping node
|
||||||
|
@ -486,13 +489,13 @@ cacheWriter :: NodeState -> IO ()
|
||||||
cacheWriter ns = do
|
cacheWriter ns = do
|
||||||
let writeQueue' = getCacheWriteQueue ns
|
let writeQueue' = getCacheWriteQueue ns
|
||||||
case writeQueue' of
|
case writeQueue' of
|
||||||
Nothing -> return ()
|
Nothing -> pure ()
|
||||||
Just writeQueue -> forever $ do
|
Just writeQueue -> forever $ do
|
||||||
f <- atomically $ readTQueue writeQueue
|
f <- atomically $ readTQueue writeQueue
|
||||||
let
|
let
|
||||||
refModifier :: NodeCache -> (NodeCache, ())
|
refModifier :: NodeCache -> (NodeCache, ())
|
||||||
refModifier nc = (f nc, ())
|
refModifier nc = (f nc, ())
|
||||||
maybe (return ()) (
|
maybe (pure ()) (
|
||||||
\ref -> atomicModifyIORef' ref refModifier
|
\ref -> atomicModifyIORef' ref refModifier
|
||||||
) $ getNodeCacheRef ns
|
) $ getNodeCacheRef ns
|
||||||
|
|
||||||
|
@ -518,7 +521,7 @@ mkServerSocket ip port = do
|
||||||
sock <- socket AF_INET6 Datagram defaultProtocol
|
sock <- socket AF_INET6 Datagram defaultProtocol
|
||||||
setSocketOption sock IPv6Only 1
|
setSocketOption sock IPv6Only 1
|
||||||
bind sock sockAddr
|
bind sock sockAddr
|
||||||
return sock
|
pure sock
|
||||||
|
|
||||||
-- | create a UDP datagram socket, connected to a destination.
|
-- | create a UDP datagram socket, connected to a destination.
|
||||||
-- The socket gets an arbitrary free local port assigned.
|
-- The socket gets an arbitrary free local port assigned.
|
||||||
|
@ -529,4 +532,4 @@ mkSendSocket dest destPort = do
|
||||||
destAddr <- addrAddress <$> resolve (Just dest) (Just destPort)
|
destAddr <- addrAddress <$> resolve (Just dest) (Just destPort)
|
||||||
sendSock <- socket AF_INET6 Datagram defaultProtocol
|
sendSock <- socket AF_INET6 Datagram defaultProtocol
|
||||||
setSocketOption sendSock IPv6Only 1
|
setSocketOption sendSock IPv6Only 1
|
||||||
return sendSock
|
pure sendSock
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import System.Environment
|
|
||||||
import Data.IP (IPv6, toHostAddress6) -- iproute, just for IPv6 string parsing
|
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
|
import Data.IP (IPv6, toHostAddress6)
|
||||||
|
import System.Environment
|
||||||
|
|
||||||
import Hash2Pub.FediChord
|
import Hash2Pub.FediChord
|
||||||
|
|
||||||
|
@ -20,12 +20,12 @@ main = do
|
||||||
-- idea: list of bootstrapping nodes, try joining within a timeout
|
-- idea: list of bootstrapping nodes, try joining within a timeout
|
||||||
-- stop main thread from terminating during development
|
-- stop main thread from terminating during development
|
||||||
getChar
|
getChar
|
||||||
return ()
|
pure ()
|
||||||
|
|
||||||
readConfig :: IO FediChordConf
|
readConfig :: IO FediChordConf
|
||||||
readConfig = do
|
readConfig = do
|
||||||
confDomainString : ipString : portString : _ <- getArgs
|
confDomainString : ipString : portString : _ <- getArgs
|
||||||
return $ FediChordConf {
|
pure $ FediChordConf {
|
||||||
confDomain = confDomainString
|
confDomain = confDomainString
|
||||||
, confIP = toHostAddress6 . read $ ipString
|
, confIP = toHostAddress6 . read $ ipString
|
||||||
, confDhtPort = read portString
|
, confDhtPort = read portString
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import qualified Data.ASN1.Encoding as ASN1 -- asn1-encoding package
|
|
||||||
import qualified Data.ASN1.BinaryEncoding as ASN1
|
import qualified Data.ASN1.BinaryEncoding as ASN1
|
||||||
|
import qualified Data.ASN1.Encoding as ASN1
|
||||||
import qualified Data.ASN1.Error as ASN1
|
import qualified Data.ASN1.Error as ASN1
|
||||||
import qualified Data.ASN1.Types as ASN1 -- asn1-types package
|
|
||||||
import qualified Data.ASN1.Parse as ASN1P
|
import qualified Data.ASN1.Parse as ASN1P
|
||||||
|
import qualified Data.ASN1.Types as ASN1
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Debug.Trace (trace)
|
import Debug.Trace (trace)
|
||||||
|
@ -14,7 +14,7 @@ import Debug.Trace (trace)
|
||||||
|
|
||||||
-- encoding values as ASN.1 types is done using Data.ASN1.Prim
|
-- encoding values as ASN.1 types is done using Data.ASN1.Prim
|
||||||
someASN1 :: [ASN1.ASN1]
|
someASN1 :: [ASN1.ASN1]
|
||||||
someASN1 = ASN1.Start ASN1.Sequence : ASN1.ASN1String (ASN1.asn1CharacterString ASN1.Visible domain) : ASN1.ASN1String (ASN1.asn1CharacterString ASN1.UTF8 unicode) : map ASN1.IntVal xs ++ [ASN1.End ASN1.Sequence]
|
someASN1 = ASN1.Start ASN1.Sequence : ASN1.ASN1String (ASN1.asn1CharacterString ASN1.Visible domain) : ASN1.ASN1String (ASN1.asn1CharacterString ASN1.UTF8 unicode) : fmap ASN1.IntVal xs <> [ASN1.End ASN1.Sequence]
|
||||||
where
|
where
|
||||||
domain = "domains.are.ascii.on.ly"
|
domain = "domains.are.ascii.on.ly"
|
||||||
unicode = "Hähä, but unicode string!"
|
unicode = "Hähä, but unicode string!"
|
||||||
|
@ -27,12 +27,12 @@ derToAsn1 :: BS.ByteString -> Either ASN1.ASN1Error [ASN1.ASN1]
|
||||||
derToAsn1 = ASN1.decodeASN1' ASN1.DER
|
derToAsn1 = ASN1.decodeASN1' ASN1.DER
|
||||||
|
|
||||||
getUnicodeField :: [ASN1.ASN1] -> String
|
getUnicodeField :: [ASN1.ASN1] -> String
|
||||||
getUnicodeField ((ASN1.Start ASN1.Sequence) : _ : (ASN1.ASN1String strASN1) : _) = fromMaybe "" $ ASN1.asn1CharacterToString strASN1
|
getUnicodeField (ASN1.Start ASN1.Sequence : _ : ASN1.ASN1String strASN1 : _) = fromMaybe "" $ ASN1.asn1CharacterToString strASN1
|
||||||
|
|
||||||
testParser :: ASN1P.ParseASN1 String
|
testParser :: ASN1P.ParseASN1 String
|
||||||
testParser = do
|
testParser = do
|
||||||
foo <- ASN1P.onNextContainer ASN1.Sequence getAll
|
foo <- ASN1P.onNextContainer ASN1.Sequence getAll
|
||||||
return $ show foo
|
pure $ show foo
|
||||||
|
|
||||||
getAll :: ASN1P.ParseASN1 [ASN1.ASN1]
|
getAll :: ASN1P.ParseASN1 [ASN1.ASN1]
|
||||||
getAll = ASN1P.getMany ASN1P.getNext
|
getAll = ASN1P.getMany ASN1P.getNext
|
||||||
|
|
32
stylish.sh
Executable file
32
stylish.sh
Executable file
|
@ -0,0 +1,32 @@
|
||||||
|
#!/usr/bin/env bash
|
||||||
|
|
||||||
|
set -euo pipefail
|
||||||
|
|
||||||
|
function ls-source-files {
|
||||||
|
git ls-files "app/*.hs" "src/*.hs" "test/*.hs"
|
||||||
|
}
|
||||||
|
|
||||||
|
function check-git-status {
|
||||||
|
[ "$(git status -s '*.hs' | wc -l)" == "0" ]
|
||||||
|
}
|
||||||
|
|
||||||
|
function stylish {
|
||||||
|
stylish-haskell -i $(ls-source-files)
|
||||||
|
}
|
||||||
|
|
||||||
|
if check-git-status
|
||||||
|
then
|
||||||
|
echo "Running stylish-haskell..."
|
||||||
|
stylish
|
||||||
|
echo "Done."
|
||||||
|
if check-git-status
|
||||||
|
then
|
||||||
|
echo "OK, impeccable style."
|
||||||
|
else
|
||||||
|
echo "KO! Lack of style on those files:"
|
||||||
|
git status -sb
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
else
|
||||||
|
echo "git status not clean, aborting"
|
||||||
|
fi
|
|
@ -1,20 +1,20 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module FediChordSpec where
|
module FediChordSpec where
|
||||||
|
|
||||||
import Test.Hspec
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Network.Socket
|
|
||||||
import Data.Maybe (fromJust)
|
|
||||||
import qualified Data.Map.Strict as Map
|
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
import Data.ASN1.Parse (runParseASN1)
|
import Data.ASN1.Parse (runParseASN1)
|
||||||
import Data.Time.Clock.POSIX
|
import qualified Data.ByteString as BS
|
||||||
import Data.IORef
|
import Data.IORef
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Maybe (fromJust)
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
import Data.Time.Clock.POSIX
|
||||||
|
import Network.Socket
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
import Hash2Pub.FediChord
|
|
||||||
import Hash2Pub.DHTProtocol
|
|
||||||
import Hash2Pub.ASN1Coding
|
import Hash2Pub.ASN1Coding
|
||||||
|
import Hash2Pub.DHTProtocol
|
||||||
|
import Hash2Pub.FediChord
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
|
@ -123,7 +123,7 @@ spec = do
|
||||||
nid1 = toNodeID 2^(23::Integer)+1
|
nid1 = toNodeID 2^(23::Integer)+1
|
||||||
node1 = do
|
node1 = do
|
||||||
eln <- exampleLocalNode -- is at 2^23.00000017198264 = 8388609
|
eln <- exampleLocalNode -- is at 2^23.00000017198264 = 8388609
|
||||||
return $ putPredecessors [nid4] $ eln {nid = nid1}
|
pure $ putPredecessors [nid4] $ eln {nid = nid1}
|
||||||
nid2 = toNodeID 2^(230::Integer)+12
|
nid2 = toNodeID 2^(230::Integer)+12
|
||||||
node2 = exampleNodeState { nid = nid2}
|
node2 = exampleNodeState { nid = nid2}
|
||||||
nid3 = toNodeID 2^(25::Integer)+10
|
nid3 = toNodeID 2^(25::Integer)+10
|
||||||
|
@ -156,7 +156,7 @@ spec = do
|
||||||
describe "Messages can be encoded to and decoded from ASN.1" $ do
|
describe "Messages can be encoded to and decoded from ASN.1" $ do
|
||||||
-- define test messages
|
-- define test messages
|
||||||
let
|
let
|
||||||
someNodeIDs = map fromInteger [3..12]
|
someNodeIDs = fmap fromInteger [3..12]
|
||||||
qidReqPayload = QueryIDRequestPayload {
|
qidReqPayload = QueryIDRequestPayload {
|
||||||
queryTargetID = nid exampleNodeState
|
queryTargetID = nid exampleNodeState
|
||||||
, queryLBestNodes = 3
|
, queryLBestNodes = 3
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import Test.Hspec
|
|
||||||
import qualified FediChordSpec
|
import qualified FediChordSpec
|
||||||
|
import Test.Hspec
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec $ do
|
main = hspec $
|
||||||
describe "FediChord tests" FediChordSpec.spec
|
describe "FediChord tests" FediChordSpec.spec
|
||||||
|
|
Loading…
Reference in a new issue