Compare commits

..

3 commits

Author SHA1 Message Date
Trolli Schmittlauch b8eeb852da Merge pull request 'Linting integration' (#17) from Hecate/Hash2Pub:hlint-configuration into master
Introduce some code formatting guidelines and enforce them with hlint and stylish:

- End-of-line extra spaces removal;
- Import lines ordering;
- Redundant ($) removal;
- Generalisation of (++) and map to (<>) and fmap;
- Preferring pure over return;
- Removing extraenous extensions.
2020-05-19 16:35:59 +02:00
Trolli Schmittlauch 7fd369c8c5 add stylish as haskell linter 2020-05-19 16:33:00 +02:00
Hécate 41e999ed99 Linting integration
This commit brings in an HLint configuration file
and several recommended modifications such as:

* End-of-line extra spaces removal;
* Import lines ordering;
* Redundant $ removal;
* Generalisation of ++ and map to <> and fmap;
* Preferring `pure` over `return`;
* Removing extraenous extensions.

And finally, a `stylish-haskell` helper script
that detects if code files are dirty. Can be useful for CI,
although manually calling it can be nice if you would rather
first implement then beautify.
2020-05-19 12:42:06 +02:00
12 changed files with 282 additions and 248 deletions

8
.hlint.yaml Normal file
View 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`"}

View file

@ -23,6 +23,7 @@ in
haddock
cabal-install
hlint
stylish-haskell
pkgs.python3Packages.asn1ate
];
};

View file

@ -1,9 +1,9 @@
import Hash2Pub.FediChord
import Data.Map.Internal.Debug (showTree)
import qualified Data.Map.Strict as Map
import Hash2Pub.FediChord
giebMalCache :: [Integer] -> Map.Map NodeID ()
giebMalCache = Map.fromList . map (mkCacheEntry . fromInteger)
giebMalCache = Map.fromList . fmap (mkCacheEntry . fromInteger)
where
mkCacheEntry nodeid = (nodeid, ())
@ -22,7 +22,7 @@ edgeCase1 = do
putStrLn "\nWhile (NodeID 2^255+2^254+3) > (NodeID 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…"
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."
print $ nidLookupGT testOverlap (2^254+14)
putStrLn "\nThat's the tree of the map:"

View file

@ -2,23 +2,23 @@
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 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 Hash2Pub.DHTProtocol
import Hash2Pub.FediChord
import Hash2Pub.Utils
import Hash2Pub.DHTProtocol
import Debug.Trace
@ -107,7 +107,7 @@ serialiseMessage maxBytesLength msg =
payloadParts i = zip [1..] . splitPayload i <$> actionPayload
actionPayload = payload msg
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
encodeMsg :: FediChordMessage -> BS.ByteString
@ -127,21 +127,21 @@ encodePayload LeaveResponsePayload = [Null]
encodePayload payload'@LeaveRequestPayload{} =
Start Sequence
: Start Sequence
: map (IntVal . getNodeID) (leaveSuccessors payload')
++ [End Sequence
: fmap (IntVal . getNodeID) (leaveSuccessors payload')
<> [End Sequence
, Start Sequence]
++ map (IntVal . getNodeID) (leavePredecessors payload')
++ [End Sequence
<> fmap (IntVal . getNodeID) (leavePredecessors payload')
<> [End Sequence
, End Sequence]
-- currently StabiliseResponsePayload and LeaveRequestPayload are equal
encodePayload payload'@StabiliseResponsePayload{} =
Start Sequence
: Start Sequence
: map (IntVal . getNodeID) (stabiliseSuccessors payload')
++ [End Sequence
: fmap (IntVal . getNodeID) (stabiliseSuccessors payload')
<> [End Sequence
, Start Sequence]
++ map (IntVal . getNodeID) (stabilisePredecessors payload')
++ [End Sequence
<> fmap (IntVal . getNodeID) (stabilisePredecessors payload')
<> [End Sequence
, End Sequence]
encodePayload payload'@StabiliseRequestPayload = [Null]
encodePayload payload'@QueryIDResponsePayload{} =
@ -151,12 +151,12 @@ encodePayload payload'@QueryIDResponsePayload{} =
Start Sequence
: encodeQueryResult resp
: case resp of
FOUND ns -> encodeNodeState $ ns
FOUND ns -> encodeNodeState ns
FORWARD entrySet ->
Start Sequence
: (concatMap encodeCacheEntry . Set.elems $ entrySet)
++ [End Sequence]
++ [End Sequence]
<> [End Sequence]
<> [End Sequence]
encodePayload payload'@QueryIDRequestPayload{} = [
Start Sequence
, IntVal . getNodeID $ queryTargetID payload'
@ -167,21 +167,21 @@ encodePayload payload'@QueryIDRequestPayload{} = [
encodePayload payload'@JoinResponsePayload{} =
Start Sequence
: Start Sequence
: map (IntVal . getNodeID) (joinSuccessors payload')
++ [End Sequence
: fmap (IntVal . getNodeID) (joinSuccessors payload')
<> [End Sequence
, Start Sequence]
++ map (IntVal . getNodeID) (joinPredecessors payload')
++ [End Sequence
<> fmap (IntVal . getNodeID) (joinPredecessors payload')
<> [End Sequence
, Start Sequence]
++ concatMap encodeCacheEntry (joinCache payload')
++ [End Sequence
<> concatMap encodeCacheEntry (joinCache payload')
<> [End Sequence
, End Sequence]
encodePayload payload'@JoinRequestPayload{} = [Null]
encodePayload PingRequestPayload{} = [Null]
encodePayload payload'@PingResponsePayload{} =
Start Sequence
: concatMap encodeNodeState (pingNodeStates payload')
++ [End Sequence]
<> [End Sequence]
encodeNodeState :: NodeState -> [ASN1]
encodeNodeState ns = [
@ -200,7 +200,7 @@ encodeCacheEntry (RemoteCacheEntry ns timestamp) =
Start Sequence
: encodeNodeState ns
-- ToDo: possibly optimise this by using dlists
++ [
<> [
IntVal . fromIntegral . fromEnum $ timestamp
, End Sequence]
encodeCacheEntry _ = []
@ -218,11 +218,11 @@ encodeMessage
: (Enumerated . fromIntegral . fromEnum $ action)
: IntVal requestID
: encodeNodeState sender
++ [
<> [
IntVal parts
, IntVal part ]
++ maybe [] encodePayload requestPayload
++ [End Sequence]
<> maybe [] encodePayload requestPayload
<> [End Sequence]
encodeMessage
(Response responseTo senderID parts part action responsePayload) = [
Start Sequence
@ -231,8 +231,8 @@ encodeMessage
, IntVal parts
, IntVal part
, Enumerated . fromIntegral . fromEnum $ action]
++ maybe [] encodePayload responsePayload
++ [End Sequence]
<> maybe [] encodePayload responsePayload
<> [End Sequence]
-- ===== parser combinators =====
@ -240,21 +240,21 @@ parseMessage :: ParseASN1 FediChordMessage
parseMessage = do
begin <- getNext
case begin of
Start Sequence -> return ()
x -> throwParseError $ "unexpected ASN.1 element " ++ show x
Start Sequence -> pure ()
x -> throwParseError $ "unexpected ASN.1 element " <> show x
-- request and response messages are distiguishable by their structure,
-- see ASN.1 schema
firstElem <- getNext
message <- case firstElem of
Enumerated a -> parseRequest . toEnum . fromIntegral $ a
IntVal i -> parseResponse i
other -> throwParseError $ "unexpected first ASN1 element: " ++ show other
other -> throwParseError $ "unexpected first ASN1 element: " <> show other
-- consume sequence end
end <- getNext
case end of
End Sequence -> return ()
x -> throwParseError $ "unexpected ASN.1 element " ++ show x
return message
End Sequence -> pure ()
x -> throwParseError $ "unexpected ASN.1 element " <> show x
pure message
@ -265,14 +265,14 @@ parseRequest action = do
parts <- parseInteger
part <- parseInteger
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
Join -> parseJoinRequest
Leave -> parseLeaveRequest
Stabilise -> parseStabiliseRequest
Ping -> parsePingRequest
return $ Request requestID sender parts part action payload
pure $ Request requestID sender parts part action payload
parseResponse :: Integer -> ParseASN1 FediChordMessage
parseResponse responseTo = do
@ -281,49 +281,49 @@ parseResponse responseTo = do
part <- parseInteger
action <- parseEnum :: ParseASN1 Action
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
Join -> parseJoinResponse
Leave -> parseLeaveResponse
Stabilise -> parseStabiliseResponse
Ping -> parsePingResponse
return $ Response responseTo senderID parts part action payload
pure $ Response responseTo senderID parts part action payload
parseInteger :: ParseASN1 Integer
parseInteger = do
i <- getNext
case i of
IntVal parsed -> return parsed
x -> throwParseError $ "Expected IntVal but got " ++ show x
IntVal parsed -> pure parsed
x -> throwParseError $ "Expected IntVal but got " <> show x
parseEnum :: Enum a => ParseASN1 a
parseEnum = do
e <- getNext
case e of
Enumerated en -> return $ toEnum . fromIntegral $ en
x -> throwParseError $ "Expected Enumerated but got " ++ show x
Enumerated en -> pure $ toEnum . fromIntegral $ en
x -> throwParseError $ "Expected Enumerated but got " <> show x
parseString :: ParseASN1 String
parseString = do
s <- getNext
case s of
ASN1String toBeParsed -> maybe (throwParseError "string parsing failed") return $ asn1CharacterToString toBeParsed
x -> throwParseError $ "Expected a ASN1String but got " ++ show x
ASN1String toBeParsed -> maybe (throwParseError "string parsing failed") pure $ asn1CharacterToString toBeParsed
x -> throwParseError $ "Expected a ASN1String but got " <> show x
parseOctets :: ParseASN1 BS.ByteString
parseOctets = do
os <- getNext
case os of
OctetString bs -> return bs
x -> throwParseError $ "Expected an OctetString but got " ++ show x
OctetString bs -> pure bs
x -> throwParseError $ "Expected an OctetString but got " <> show x
parseNull :: ParseASN1 ()
parseNull = do
n <- getNext
case n of
Null -> return ()
x -> throwParseError $ "Expected Null but got " ++ show x
Null -> pure ()
x -> throwParseError $ "Expected Null but got " <> show x
parseNodeState :: ParseASN1 NodeState
parseNodeState = onNextContainer Sequence $ do
@ -333,7 +333,7 @@ parseNodeState = onNextContainer Sequence $ do
dhtPort' <- fromInteger <$> parseInteger
apPort' <- fromInteger <$> parseInteger
vServer' <- parseInteger
return NodeState {
pure NodeState {
nid = nid'
, domain = domain'
, dhtPort = dhtPort'
@ -348,7 +348,7 @@ parseCacheEntry :: ParseASN1 RemoteCacheEntry
parseCacheEntry = onNextContainer Sequence $ do
node <- parseNodeState
timestamp <- toEnum . fromIntegral <$> parseInteger
return $ RemoteCacheEntry node timestamp
pure $ RemoteCacheEntry node timestamp
parseNodeCache :: ParseASN1 [RemoteCacheEntry]
parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
@ -356,14 +356,14 @@ parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry
parseJoinRequest :: ParseASN1 ActionPayload
parseJoinRequest = do
parseNull
return JoinRequestPayload
pure JoinRequestPayload
parseJoinResponse :: ParseASN1 ActionPayload
parseJoinResponse = onNextContainer Sequence $ do
succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
cache <- parseNodeCache
return $ JoinResponsePayload {
pure $ JoinResponsePayload {
joinSuccessors = succ'
, joinPredecessors = pred'
, joinCache = cache
@ -373,7 +373,7 @@ parseQueryIDRequest :: ParseASN1 ActionPayload
parseQueryIDRequest = onNextContainer Sequence $ do
targetID <- fromInteger <$> parseInteger
lBestNodes <- parseInteger
return $ QueryIDRequestPayload {
pure $ QueryIDRequestPayload {
queryTargetID = targetID
, queryLBestNodes = lBestNodes
}
@ -385,29 +385,29 @@ parseQueryIDResponse = onNextContainer Sequence $ do
0 -> FOUND <$> parseNodeState
1 -> FORWARD . Set.fromList <$> parseNodeCache
_ -> throwParseError "invalid QueryIDResponse type"
return $ QueryIDResponsePayload {
pure $ QueryIDResponsePayload {
queryResult = result
}
parseStabiliseRequest :: ParseASN1 ActionPayload
parseStabiliseRequest = do
parseNull
return StabiliseRequestPayload
pure StabiliseRequestPayload
parseStabiliseResponse :: ParseASN1 ActionPayload
parseStabiliseResponse = onNextContainer Sequence $ do
succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
return $ StabiliseResponsePayload {
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pure $ StabiliseResponsePayload {
stabiliseSuccessors = succ'
, stabilisePredecessors = pred'
}
parseLeaveRequest :: ParseASN1 ActionPayload
parseLeaveRequest = onNextContainer Sequence $ do
succ' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pred' <- map fromInteger <$> onNextContainer Sequence (getMany parseInteger)
return $ LeaveRequestPayload {
succ' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pred' <- fmap fromInteger <$> onNextContainer Sequence (getMany parseInteger)
pure $ LeaveRequestPayload {
leaveSuccessors = succ'
, leavePredecessors = pred'
}
@ -415,16 +415,16 @@ parseLeaveRequest = onNextContainer Sequence $ do
parseLeaveResponse :: ParseASN1 ActionPayload
parseLeaveResponse = do
parseNull
return LeaveResponsePayload
pure LeaveResponsePayload
parsePingRequest :: ParseASN1 ActionPayload
parsePingRequest = do
parseNull
return PingRequestPayload
pure PingRequestPayload
parsePingResponse :: ParseASN1 ActionPayload
parsePingResponse = onNextContainer Sequence $ do
handledNodes <- getMany parseNodeState
return $ PingResponsePayload {
pure $ PingResponsePayload {
pingNodeStates = handledNodes
}

View file

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Hash2Pub.DHTProtocol
( QueryResponse (..)
, queryLocalCache
@ -17,28 +15,20 @@ module Hash2Pub.DHTProtocol
)
where
import Data.Maybe (maybe, fromMaybe)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, maybe)
import qualified Data.Set as Set
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 Hash2Pub.FediChord
( NodeID
, NodeState (..)
, getSuccessors
, putSuccessors
, getPredecessors
, putPredecessors
, cacheGetNodeStateUnvalidated
, NodeCache
, CacheEntry(..)
, cacheLookup
, cacheLookupSucc
, cacheLookupPred
, localCompare
)
import Hash2Pub.FediChord (CacheEntry (..), NodeCache, NodeID,
NodeState (..),
cacheGetNodeStateUnvalidated,
cacheLookup, cacheLookupPred,
cacheLookupSucc, getPredecessors,
getSuccessors, localCompare,
putPredecessors, putSuccessors)
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
addCacheEntry entry cache = do
now <- getPOSIXTime
return $ addCacheEntryPure now entry cache
pure $ addCacheEntryPure now entry cache
-- | pure version of 'addCacheEntry' with current time explicitly specified as argument
addCacheEntryPure :: POSIXTime -- ^ current time
@ -214,9 +204,9 @@ markCacheEntryAsVerified timestamp = Map.adjust adjustFunc
attempts :: Int -- ^ number of retries *i*
-> IO (Maybe a) -- ^ action to retry
-> IO (Maybe a) -- ^ result after at most *i* retries
attempts 0 _ = return Nothing
attempts 0 _ = pure Nothing
attempts i action = do
actionResult <- action
case actionResult of
Nothing -> attempts (i-1) action
Just res -> return $ Just res
Just res -> pure $ Just res

View file

@ -1,4 +1,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, DataKinds, OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : FediChord
Description : An opinionated implementation of the EpiChord DHT by Leong et al.
@ -45,25 +47,26 @@ module Hash2Pub.FediChord (
, cacheWriter
) where
import qualified Data.Map.Strict as Map
import Network.Socket
import Data.Time.Clock.POSIX
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
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.TQueue
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.Word
import qualified Network.ByteOrder as NetworkBytes
import Hash2Pub.Utils
@ -280,12 +283,12 @@ lookupWrapper :: (NodeID -> NodeCache -> Maybe (NodeID, CacheEntry)) -> (NodeID
lookupWrapper f fRepeat direction key cache =
case f key cache of
-- 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
Just (_, (ProxyEntry _ (Just (ProxyEntry _ _)))) -> Nothing
Just (_, ProxyEntry _ (Just (ProxyEntry _ _))) -> Nothing
-- proxy entry without own entry is a pointer on where to continue
-- 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
then pointerID
else foundKey + (fromInteger . toInteger . fromEnum $ direction)
@ -322,17 +325,17 @@ cacheLookupPred = lookupWrapper Map.lookupLT Map.lookupLE Backwards
cacheGetNodeStateUnvalidated :: CacheEntry -> NodeState
cacheGetNodeStateUnvalidated (NodeEntry _ nState _) = nState
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
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'
bsAsIpAddr :: BS.ByteString -> HostAddress6
bsAsIpAddr bytes = (a,b,c,d)
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
@ -344,7 +347,7 @@ genNodeIDBS ip nodeDomain vserver =
hashIpaddrUpper `BS.append` hashID nodeDomain' `BS.append` hashIpaddLower
where
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
hashID bstr = BS.pack . BA.unpack $ (hash bstr :: Digest (SHAKE128 128))
(hashIpaddrUpper, hashIpaddLower) = BS.splitAt 64 $ hashID ipaddrNet
@ -391,7 +394,7 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs
--checkCacheSlices :: NodeState -> IO [()]
--checkCacheSlices state = case getNodeCache state of
-- -- don't do anything on nodes without a cache
-- Nothing -> return [()]
-- Nothing -> pure [()]
-- Just cache' -> checkSlice jEntries (nid state) startBound lastSucc =<< readIORef cache'
-- -- TODO: do the same for predecessors
-- where
@ -415,10 +418,10 @@ byteStringToUInteger bs = sum $ parsedBytes 0 bs
-- -- TODO: replace empty IO actions with actual lookups to middle of slice
-- -- TODO: validate ID before adding to cache
-- 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, _) ->
-- if
-- matchID <= lowerBound then return () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
-- matchID <= lowerBound then pure () : checkSlice j ownID lowerBound (Just lastSuccNode) cache
-- else
-- checkSlice j ownID lowerBound (Just lastSuccNode) cache
@ -439,7 +442,7 @@ fediChordInit :: FediChordConf -> IO (Socket, NodeState)
fediChordInit conf = do
initialState <- nodeStateInit conf
serverSock <- mkServerSocket (ipAddr initialState) (dhtPort initialState)
return (serverSock, initialState)
pure (serverSock, initialState)
-- | initialises the 'NodeState' for this local node.
-- Separated from 'fediChordInit' to be usable in tests.
@ -467,7 +470,7 @@ nodeStateInit conf = do
, pNumParallelQueries = 2
, jEntriesPerSlice = 2
}
return initialState
pure initialState
--fediChordJoin :: NodeState -- ^ the local 'NodeState'
-- -> (String, PortNumber) -- ^ domain and port of a bootstrapping node
@ -486,13 +489,13 @@ cacheWriter :: NodeState -> IO ()
cacheWriter ns = do
let writeQueue' = getCacheWriteQueue ns
case writeQueue' of
Nothing -> return ()
Nothing -> pure ()
Just writeQueue -> forever $ do
f <- atomically $ readTQueue writeQueue
let
refModifier :: NodeCache -> (NodeCache, ())
refModifier nc = (f nc, ())
maybe (return ()) (
maybe (pure ()) (
\ref -> atomicModifyIORef' ref refModifier
) $ getNodeCacheRef ns
@ -518,7 +521,7 @@ mkServerSocket ip port = do
sock <- socket AF_INET6 Datagram defaultProtocol
setSocketOption sock IPv6Only 1
bind sock sockAddr
return sock
pure sock
-- | create a UDP datagram socket, connected to a destination.
-- The socket gets an arbitrary free local port assigned.
@ -529,4 +532,4 @@ mkSendSocket dest destPort = do
destAddr <- addrAddress <$> resolve (Just dest) (Just destPort)
sendSock <- socket AF_INET6 Datagram defaultProtocol
setSocketOption sendSock IPv6Only 1
return sendSock
pure sendSock

View file

@ -1,8 +1,8 @@
module Main where
import System.Environment
import Data.IP (IPv6, toHostAddress6) -- iproute, just for IPv6 string parsing
import Control.Concurrent
import Data.IP (IPv6, toHostAddress6)
import System.Environment
import Hash2Pub.FediChord
@ -20,12 +20,12 @@ main = do
-- idea: list of bootstrapping nodes, try joining within a timeout
-- stop main thread from terminating during development
getChar
return ()
pure ()
readConfig :: IO FediChordConf
readConfig = do
confDomainString : ipString : portString : _ <- getArgs
return $ FediChordConf {
pure $ FediChordConf {
confDomain = confDomainString
, confIP = toHostAddress6 . read $ ipString
, confDhtPort = read portString

View file

@ -1,11 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified Data.ASN1.Encoding as ASN1 -- asn1-encoding package
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.Types as ASN1 -- asn1-types package
import qualified Data.ASN1.Parse as ASN1P
import qualified Data.ASN1.Types as ASN1
import qualified Data.ByteString as BS
import Data.Maybe (fromMaybe)
import Debug.Trace (trace)
@ -14,7 +14,7 @@ import Debug.Trace (trace)
-- encoding values as ASN.1 types is done using Data.ASN1.Prim
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
domain = "domains.are.ascii.on.ly"
unicode = "Hähä, but unicode string!"
@ -27,12 +27,12 @@ derToAsn1 :: BS.ByteString -> Either ASN1.ASN1Error [ASN1.ASN1]
derToAsn1 = ASN1.decodeASN1' ASN1.DER
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 = do
foo <- ASN1P.onNextContainer ASN1.Sequence getAll
return $ show foo
pure $ show foo
getAll :: ASN1P.ParseASN1 [ASN1.ASN1]
getAll = ASN1P.getMany ASN1P.getNext

32
stylish.sh Executable file
View 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

View file

@ -1,20 +1,20 @@
{-# LANGUAGE OverloadedStrings #-}
module FediChordSpec where
import Test.Hspec
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.Time.Clock.POSIX
import qualified Data.ByteString as BS
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.DHTProtocol
import Hash2Pub.FediChord
spec :: Spec
spec = do
@ -123,7 +123,7 @@ spec = do
nid1 = toNodeID 2^(23::Integer)+1
node1 = do
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
node2 = exampleNodeState { nid = nid2}
nid3 = toNodeID 2^(25::Integer)+10
@ -156,7 +156,7 @@ spec = do
describe "Messages can be encoded to and decoded from ASN.1" $ do
-- define test messages
let
someNodeIDs = map fromInteger [3..12]
someNodeIDs = fmap fromInteger [3..12]
qidReqPayload = QueryIDRequestPayload {
queryTargetID = nid exampleNodeState
, queryLBestNodes = 3

View file

@ -1,8 +1,8 @@
module Main (main) where
import Test.Hspec
import qualified FediChordSpec
import Test.Hspec
main :: IO ()
main = hspec $ do
main = hspec $
describe "FediChord tests" FediChordSpec.spec