connection-manager: pure test

IntersectMBO · Jan 27, 2021 · 53de74e · 53de74e
1 parent 70897ba
commit 53de74e
Show file tree

Hide file tree

Showing 4 changed files with 877 additions and 8 deletions.
diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal
@@ -117,6 +117,7 @@ test-suite test
                        Network.TypedProtocol.ReqResp.Codec.CBOR
                        Test.Network.TypedProtocol.PingPong.Codec
                        Test.Network.TypedProtocol.ReqResp.Codec
+                       Test.Ouroboros.Network.ConnectionManager
                        Test.Ouroboros.Network.Driver
                        Test.Ouroboros.Network.Orphans
                        Test.Ouroboros.Network.Server2
@@ -135,6 +136,7 @@ test-suite test
                      , serialise
                      , text
                      , time
+                     , quiet
 
                      , QuickCheck
                      , tasty

diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
 
 module Ouroboros.Network.Snocket
   ( -- * Snocket Interface
@@ -22,6 +23,7 @@ module Ouroboros.Network.Snocket
   , LocalSocket (..)
   , LocalAddress (..)
   , localAddressFromPath
+  , TestAddress (..)
 
   , FileDescriptor
   , socketFileDescriptor
@@ -35,6 +37,7 @@ import           Control.Tracer (Tracer)
 import           Data.Bifunctor (Bifunctor (..))
 import           Data.Bifoldable (Bifoldable (..))
 import           Data.Hashable
+import           Data.Typeable (Typeable)
 import           GHC.Generics (Generic)
 import           Quiet (Quiet (..))
 #if !defined(mingw32_HOST_OS)
@@ -168,22 +171,31 @@ newtype LocalAddress = LocalAddress { getFilePath :: FilePath }
 instance Hashable LocalAddress where
     hashWithSalt s (LocalAddress path) = hashWithSalt s path
 
+newtype TestAddress addr = TestAddress { getTestAddress :: addr }
+  deriving (Eq, Ord, Typeable, Show)
+
 -- | We support either sockets or named pipes.
 --
+-- There are three families of addresses: 'SocketFamily' usef for Berkeley
+-- sockets, 'LocalFamily' used for 'LocalAddress'es (either Unix sockets or
+-- Windows named pipe addresses), and 'TestFamily' for testing purposes.
+--
 data AddressFamily addr where
 
     SocketFamily :: !Socket.Family
                  -> AddressFamily Socket.SockAddr
 
     LocalFamily  :: AddressFamily LocalAddress
 
-instance Eq (AddressFamily addr) where
-    SocketFamily fam0 == SocketFamily fam1 = fam0 == fam1
-    LocalFamily       == LocalFamily       = True
+    -- using a newtype wrapper make pattern matches on @AddressFamily@ complete,
+    -- e.g. it makes 'AddressFamily' injective:
+    -- @AddressFamily addr == AddressFamily addr'@ then @addr == addr'@. .
+    --
+    TestFamily   :: AddressFamily (TestAddress addr)
+
+deriving instance Eq (AddressFamily addr)
+deriving instance Show (AddressFamily addr)
 
-instance Show (AddressFamily addr) where
-    show (SocketFamily fam) = show fam
-    show LocalFamily        = "LocalFamily"
 
 -- | Abstract communication interface that can be used by more than
 -- 'Socket'.  Snockets are polymorphic over monad which is used, this feature

diff --git a/ouroboros-network-framework/test/Main.hs b/ouroboros-network-framework/test/Main.hs
@@ -4,8 +4,9 @@ import           Test.Tasty
 
 import qualified Test.Network.TypedProtocol.PingPong.Codec as PingPong
 import qualified Test.Network.TypedProtocol.ReqResp.Codec as ReqResp
-import qualified Test.Ouroboros.Network.Server2 as Server2
+import qualified Test.Ouroboros.Network.ConnectionManager as ConnectionManager
 import qualified Test.Ouroboros.Network.Driver as Driver
+import qualified Test.Ouroboros.Network.Server2 as Server2
 import qualified Test.Ouroboros.Network.Socket as Socket
 import qualified Test.Ouroboros.Network.Subscription as Subscription
 import qualified Test.Ouroboros.Network.RateLimiting as RateLimiting
@@ -16,7 +17,8 @@ main = defaultMain tests
 tests :: TestTree
 tests =
   testGroup "ouroboros-network-framework"
-  [ PingPong.tests
+  [ ConnectionManager.tests
+  , PingPong.tests
   , ReqResp.tests
   , Driver.tests
   , Server2.tests