Hash2Pub/test/FediChordSpec.hs

{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
module FediChordSpec where

import           Control.Concurrent.STM.TVar
import           Control.Exception
import           Data.ASN1.Parse             (runParseASN1)
import qualified Data.ByteString             as BS
import qualified Data.HashMap.Strict         as HMap
import qualified Data.Map.Strict             as Map
import           Data.Maybe                  (fromJust, isJust)
import qualified Data.Set                    as Set
import           Data.Time.Clock.POSIX
import           Network.Socket
import           Test.Hspec

import           Hash2Pub.ASN1Coding
import           Hash2Pub.DHTProtocol
import           Hash2Pub.FediChord
import           Hash2Pub.FediChordTypes

spec :: Spec
spec = do
    describe "NodeID" $ do
        it "can store a numeral ID" $
            getNodeID (toNodeID 2342) `shouldBe` 2342
        it "computes ID values within the modular bounds" $ do
            getNodeID ((maxBound :: NodeID) + toNodeID 2) < getNodeID (maxBound :: NodeID) `shouldBe` True
            3 * (maxBound :: NodeID) `shouldBe`  fromInteger (-3)
        it "local comparison works in the context of preceding/ succeding nodes on a ring" $ do
            toNodeID 12 `localCompare` toNodeID 12 `shouldBe` EQ
            let
                a = toNodeID 3
                b = toNodeID 3 - toNodeID 10
            a `localCompare` b `shouldBe` GT
            b `localCompare` a `shouldBe` LT
            -- edge cases
            ((toNodeID 5001 - toNodeID 2^(255::Integer)) `localCompare` 5001) `shouldBe` LT
            (toNodeID 5001 - toNodeID 2^(255::Integer) - 1) `localCompare` 5001 `shouldBe` GT
        it "throws an exception when @toNodeID@ on out-of-bound values"
            pending
        it "can be generated" $ do
            genNodeIDBS exampleIp exampleNodeDomain exampleVs `shouldBe` "\ACK\211\183&S\GS\214\247Xn8\216\232\195\247\162\182\253\210\SOHG7I\194\251\196\130\142RSx\219"
            genNodeID exampleIp exampleNodeDomain exampleVs `shouldBe` toNodeID 3087945874980469002564169693112490135217795916629034079089428181202645514459

    describe "ByteString to Integer conversion" $
        it "correctly interprets ByteStrings as unsigned big-endian integers" $ do
            byteStringToUInteger (BS.pack $ replicate 32 0xff) `shouldBe` 2^(256::Integer)-1
            byteStringToUInteger (BS.pack $ replicate 32 0x00) `shouldBe` 0
            byteStringToUInteger (BS.pack [0x00, 0x03, 0xf6, 0x78, 0x10, 0x00]) `shouldBe` 17019965440
    describe "key ID" $
        it "can be generated" $ do
            genKeyIDBS "#sometag" `shouldBe` "\178\239\146\131\166\SYN\ESC\209\205\&3\143\212\145@#\205T\219\152\191\229\ACK|\153<b\199p\147\182&l"
            genKeyIDBS "#ÄปӥicоdeTag" `shouldBe` "\f\159\165|D*\SUB\180\SO\202\&0\158\148\238\STX FZ/\184\SOH\188\169\153\154\164\229\&2Ix\SUB\169"
            genKeyID "#sometag" `shouldBe` 80934974700514031200587628522801847528706765451025022694022301350330549806700
            genKeyID "#ÄปӥicоdeTag" `shouldBe` 5709825004658123480531764908635278432808461265905814952223156184506818894505
    describe "NodeState" $ do
        it "can be initialised" $
            print exampleNodeState
        it "can be initialised partly and then modified later" $ do
            let ns = RemoteNodeState {
                nid = undefined
              , domain = exampleNodeDomain
              , ipAddr = exampleIp
              , dhtPort = 2342
              , servicePort = 513
              , vServerID = undefined
                               }
                nsReady = ns {
                  nid = genNodeID (ipAddr ns) (domain ns) 3
                , vServerID = 1
                             }
            print nsReady
    describe "IP address to ByteString conversion" $
        it "correctly converts HostAddress6 values back and forth" $
            (bsAsIpAddr . ipAddrAsBS $ ipAddr exampleNodeState) `shouldBe` ipAddr exampleNodeState
    describe "NodeCache" $ do
        let
            emptyCache = initCache
            anotherID = toNodeID 2^(230::Integer)+1
            anotherNode = exampleNodeState { nid = anotherID}
            maxNode = exampleNodeState { nid = maxBound}
            newCache = addCacheEntryPure 10 (RemoteCacheEntry exampleNodeState 10) (addCacheEntryPure 10 (RemoteCacheEntry anotherNode 10) emptyCache)
            exampleID = nid exampleNodeState
        it "entries can be added to a node cache and looked up again" $ do
            rMapSize emptyCache `shouldBe` 0
            rMapSize newCache `shouldBe` 2
            -- normal entry lookup
            nid . cacheGetNodeStateUnvalidated <$> cacheLookup anotherID newCache `shouldBe` Just anotherID
            nid . cacheGetNodeStateUnvalidated <$> cacheLookup (anotherID+1) newCache `shouldBe` Nothing
            -- initially, the proxy elements store nothing
            cacheLookup minBound emptyCache `shouldBe` Nothing
            cacheLookup maxBound emptyCache `shouldBe` Nothing
            -- now store a node at that ID
            let cacheWithMaxNode = addCacheEntryPure 10 (RemoteCacheEntry maxNode 10) newCache
            nid . cacheGetNodeStateUnvalidated <$> cacheLookup maxBound cacheWithMaxNode `shouldBe` Just maxBound
        it "looking up predecessor and successor works like on a modular ring" $ do
            -- ignore empty proxy elements in initial cache
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupPred (exampleID + 10) emptyCache `shouldBe` Nothing
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupSucc exampleID emptyCache `shouldBe` Nothing

            -- given situation: 0 < anotherNode < nid exampleLocalNode < maxBound
            -- first try non-modular queries between the 2 stored nodes
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupPred (exampleID + 10) newCache `shouldBe` Just exampleID
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupSucc exampleID newCache `shouldBe` Just exampleID
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupSucc (exampleID + 10) newCache `shouldBe` Just anotherID
            -- queries that require a (pseudo)modular structure
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupPred (exampleID - 2) newCache `shouldBe` Just anotherID
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupSucc (anotherID + 2) newCache `shouldBe` Just exampleID
            -- now store a node in one of the ProxyEntries
            let cacheWithProxyNodeEntry = addCacheEntryPure 10 (RemoteCacheEntry maxNode 10) newCache
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupPred (exampleID - 2) cacheWithProxyNodeEntry `shouldBe` Just maxBound
            nid . cacheGetNodeStateUnvalidated <$> cacheLookupSucc (anotherID + 2) cacheWithProxyNodeEntry `shouldBe` Just maxBound
        it "entries can be deleted" $ do
            let
                nC = addCacheEntryPure 10 (RemoteCacheEntry maxNode 10) newCache
                nc' = deleteCacheEntry maxBound . deleteCacheEntry anotherID $ nC
            cacheLookup anotherID nc' `shouldBe` Nothing
            cacheLookup maxBound nc' `shouldBe` Nothing


    describe "NodeCache query lookup" $ do
        let
            emptyCache = initCache
            nid1 = toNodeID 2^(23::Integer)+1
            node1 = setPredecessors [node4] . setNid nid1 <$> exampleLocalNode
            nid2 = toNodeID 2^(230::Integer)+12
            node2 = exampleNodeState { nid = nid2}
            nid3 = toNodeID 2^(25::Integer)+10
            node3 = exampleNodeState { nid = nid3}
            nid4 = toNodeID 2^(9::Integer)+100
            node4 = exampleNodeState { nid = nid4}
            nid5 = toNodeID 2^(25::Integer)+100
            node5 = exampleNodeState { nid = nid5}
            cacheWith2Entries :: NodeCache
            cacheWith2Entries = addCacheEntryPure 10 (RemoteCacheEntry node5 10) (addCacheEntryPure 10 (RemoteCacheEntry node2 10) emptyCache)
            cacheWith4Entries = addCacheEntryPure 10 (RemoteCacheEntry node3 10) (addCacheEntryPure 10 (RemoteCacheEntry node4 10) cacheWith2Entries)
        it "unjoined nodes should never return themselfs" $ do
            exampleLocalNodeAsRemote <- toRemoteNodeState <$> exampleLocalNode
            queryLocalCache <$> exampleLocalNode <*> pure emptyCache <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5) `shouldReturn` FORWARD Set.empty
            (FORWARD fwSet) <- queryLocalCache <$> exampleLocalNode <*> pure cacheWith4Entries <*> pure 1 <*> (getNid <$> exampleLocalNode)
            remoteNode (head $ Set.elems fwSet) `shouldBe` node4
        it "joined nodes do not fall back to the default" $
            queryLocalCache <$> node1 <*> pure emptyCache <*> pure 1 <*> pure (toNodeID 3) `shouldReturn` FORWARD Set.empty
        it "works on a cache with less entries than needed" $ do
            (FORWARD nodeset) <- queryLocalCache <$> node1 <*> pure cacheWith2Entries <*> pure 4 <*> pure (toNodeID 2^(9::Integer)+5)
            Set.map (nid . remoteNode) nodeset `shouldBe` Set.fromList [ nid5, nid2 ]
        it "works on a cache with sufficient entries" $ do
            (FORWARD nodeset1) <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(9::Integer)+5)
            (FORWARD nodeset2) <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 1 <*> pure (toNodeID 2^(9::Integer)+5)
            Set.map (nid . remoteNode) nodeset1 `shouldBe` Set.fromList [nid4, nid2, nid5]
            Set.map (nid . remoteNode) nodeset2 `shouldBe` Set.fromList [nid4]
        it "recognises the node's own responsibility" $ do
            FOUND selfQueryRes <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 3 <*> pure nid1
            getNid <$> node1 `shouldReturn` getNid selfQueryRes
            FOUND responsibilityResult <- queryLocalCache <$> node1 <*> pure cacheWith4Entries <*> pure 3 <*> pure (toNodeID 2^(22::Integer))
            getNid <$> node1 `shouldReturn` getNid responsibilityResult
    describe "successors and predecessors do not disturb the ring characteristics of EpiChord operations (see #48)" $ do
        let
            emptyCache = initCache
            -- implicitly relies on kNeighbours to be <= 3
            thisNid = toNodeID 1000
            thisNode = setNid thisNid <$> exampleLocalNode
            nid2 = toNodeID 1003
            node2 = exampleNodeState { nid = nid2}
            nid3 = toNodeID 1010
            node3 = exampleNodeState { nid = nid3}
            nid4 = toNodeID 1020
            node4 = exampleNodeState { nid = nid4}
            nid5 = toNodeID 1025
            node5 = exampleNodeState { nid = nid5}
            allRemoteNodes = [node2, node3, node4, node5]
        it "lookups also work for slices larger than 1/2 key space" $ do
            node <- setSuccessors allRemoteNodes . setPredecessors allRemoteNodes <$> thisNode
            -- do lookup on empty cache but with successors for a key > 1/2 key space
            -- succeeding the node
            queryLocalCache node emptyCache 1 (nid5 + 10) `shouldBe` FOUND (toRemoteNodeState node)


    describe "Messages can be encoded to and decoded from ASN.1" $ do
        -- define test messages
        let
            someNodes = fmap (flip setNid exampleNodeState . fromInteger) [3..12]
            qidReqPayload = QueryIDRequestPayload {
                queryTargetID = nid exampleNodeState
              , queryLBestNodes = 3
                                               }
            jReqPayload = JoinRequestPayload
            lReqPayload = LeaveRequestPayload {
                leaveSuccessors = someNodes
              , leavePredecessors = someNodes
              , leaveDoMigration = True
                                              }
            stabReqPayload = StabiliseRequestPayload
            pingReqPayload = PingRequestPayload
            qidResPayload1 = QueryIDResponsePayload {
                queryResult = FOUND exampleNodeState
                                                    }
            qidResPayload2 = QueryIDResponsePayload {
                queryResult = FORWARD $ Set.fromList [
                    RemoteCacheEntry exampleNodeState (toEnum 23420001)
                  , RemoteCacheEntry (exampleNodeState {nid = fromInteger (-5)}) (toEnum 0)
                                                     ]
                                                    }
            jResPayload = JoinResponsePayload {
                joinSuccessors = someNodes
              , joinPredecessors = someNodes
              , joinCache = [
                  RemoteCacheEntry exampleNodeState (toEnum 23420001)
                , RemoteCacheEntry (exampleNodeState {nid = fromInteger (-5)}) (toEnum 0)
                            ]
                                              }
            lResPayload = LeaveResponsePayload
            stabResPayload = StabiliseResponsePayload {
                stabiliseSuccessors = someNodes
              , stabilisePredecessors = []
                                                      }
            pingResPayload = PingResponsePayload {
                pingNodeStates = [
                    exampleNodeState
                  , exampleNodeState {nid = fromInteger (-5)}
                                 ]
                                              }
            qLoadReqPayload = LoadRequestPayload
                { loadSegmentUpperBound = 1025
                }
            qLoadResPayload = LoadResponsePayload
                { loadSum = 3.141
                , loadRemainingTarget = -1.337
                , loadTotalCapacity = 2.21
                , loadSegmentLowerBound = 12
                }

            responseTemplate = Response {
                requestID = 2342
              , senderID = nid exampleNodeState
              , part = 1
              , isFinalPart = True
              , action = undefined
              , payload = undefined
                                      }
            requestWith senderNode a pa = mkRequest senderNode 4545 a (Just pa) 2342
            responseWith a pa = responseTemplate {action = a, payload = Just pa}

            encodeDecodeAndCheck msg = runParseASN1 parseMessage (encodeMessage msg) `shouldBe` pure msg
            largeMessage = responseWith Join $ JoinResponsePayload {
                joinSuccessors = flip setNid exampleNodeState . fromInteger <$> [-20..150]
              , joinPredecessors = flip setNid exampleNodeState . fromInteger <$> [5..11]
              , joinCache = [ RemoteCacheEntry (exampleNodeState {nid = node}) 290001 | node <- [50602,506011..60000]]
                                                                       }

        it "messages are encoded and decoded correctly from and to ASN1" $ do
            localNS <- exampleLocalNode
            encodeDecodeAndCheck $ requestWith localNS QueryID qidReqPayload
            encodeDecodeAndCheck $ requestWith localNS Join jReqPayload
            encodeDecodeAndCheck $ requestWith localNS Leave lReqPayload
            encodeDecodeAndCheck $ requestWith localNS Stabilise stabReqPayload
            encodeDecodeAndCheck $ requestWith localNS Ping pingReqPayload
            encodeDecodeAndCheck $ requestWith localNS QueryLoad qLoadReqPayload
            encodeDecodeAndCheck $ responseWith QueryID qidResPayload1
            encodeDecodeAndCheck $ responseWith QueryID qidResPayload2
            encodeDecodeAndCheck $ responseWith Join jResPayload
            encodeDecodeAndCheck $ responseWith Leave lResPayload
            encodeDecodeAndCheck $ responseWith Stabilise stabResPayload
            encodeDecodeAndCheck $ responseWith Ping pingResPayload
            encodeDecodeAndCheck $ responseWith QueryLoad qLoadResPayload
        it "messages are encoded and decoded to ASN.1 DER properly" $
            deserialiseMessage (fromJust $ Map.lookup 1 (serialiseMessage 652  $ responseWith Ping pingResPayload)) `shouldBe` Right (responseWith Ping pingResPayload)
        it "messages too large for a single packet can (often) be split into multiple parts" $ do
            -- TODO: once splitting works more efficient, test for exact number or payload, see #18
            length (serialiseMessage 600 largeMessage) > 1 `shouldBe` True
            length (serialiseMessage 60000 largeMessage) `shouldBe` 1
        it "message part numbering starts at the submitted part number" $ do
            isJust (Map.lookup 1 (serialiseMessage 600 largeMessage)) `shouldBe` True
            let startAt5 = serialiseMessage 600 (largeMessage {part = 5})
            Map.lookup 1 startAt5 `shouldBe` Nothing
            part <$> (deserialiseMessage . fromJust) (Map.lookup 5 startAt5) `shouldBe` Right 5
    describe "join cache lookup" $
        it "A bootstrap cache initialised with just one node returns that one." $ do
            let
                bootstrapNid = toNodeID 34804191837661041451755206127000721433747285589603756490902196113256157045194
                bootstrapNode = setNid bootstrapNid exampleNodeState
                bootstrapCache = addCacheEntryPure 10 (RemoteCacheEntry bootstrapNode 19) initCache
                ownId = toNodeID 34804191837661041451755206127000721433707928516052624394829818586723613390165
            ownNode <- setNid ownId <$> exampleLocalNode
            let (FORWARD qResult) = queryLocalCache ownNode bootstrapCache 2 ownId
            remoteNode (head $ Set.elems qResult) `shouldBe` bootstrapNode



-- some example data

exampleNodeState :: RemoteNodeState
exampleNodeState = RemoteNodeState {
    nid = toNodeID 12
  , domain = exampleNodeDomain
  , ipAddr = exampleIp
  , dhtPort = 2342
  , servicePort = 513
  , vServerID = 0
                   }

exampleLocalNode :: IO (LocalNodeState MockService)
exampleLocalNode = do
    realNodeSTM <- newTVarIO $ RealNode {
            vservers = HMap.empty
          , nodeConfig = exampleFediConf
          , bootstrapNodes = confBootstrapNodes exampleFediConf
          , nodeService = MockService
                                                        }
    nodeStateInit realNodeSTM 0


exampleFediConf :: FediChordConf
exampleFediConf = FediChordConf {
    confDomain = "example.social"
  , confIP = exampleIp
  , confDhtPort = 2342
                                                    }

exampleNodeDomain :: String
exampleNodeDomain = "example.social"
exampleVs :: (Integral i) => i
exampleVs = 4
exampleIp :: HostAddress6
exampleIp = tupleToHostAddress6 (0x2001, 0x16b8, 0x755a, 0xb110, 0x7d6a, 0x12ab, 0xf0c5, 0x386e)

data MockService d = MockService

instance DHT d => Service MockService d where
    runService _ _ = pure MockService
    getListeningPortFromService = const 1337