Linting integration #17
					 11 changed files with 281 additions and 248 deletions
				
			
		
							
								
								
									
										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`"} | ||||||
|  |            | ||||||
|  | @ -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…
	
	Add table
		Add a link
		
	
		Reference in a new issue