From 585e70124848d8b4b10919e0588698dae0dba616 Mon Sep 17 00:00:00 2001 From: archaephyrryx Date: Fri, 17 Jul 2020 13:41:41 -0400 Subject: [PATCH 1/3] WIP newtype redefinition of ProtocolNumber redefines ProtocolNumber as newtype around CInt (formerly type alias for CInt) that re-derives all instance methods for CInt that are defined in Foreign.C.Types defines and exports pattern synonyms for commonly used protocol-number constants (defined in "netinet/in.h") (IPPROTO_(IP|IPV4|IPV6|TCP|UDP|ICMP|ICMPV6|RAW)) as well as UnsupportedProtocol and GeneralProtocol patterns refactored function definitions previously relying on (ProtocolNumber ~ CInt) to use unwrapper function implements bijective read/show instances for ProtocolNumber whose default behavior is to directly read and show integer values with no constructor syntax --- Network/Socket.hs | 8 ++- Network/Socket/Syscall.hs | 2 +- Network/Socket/Types.hsc | 119 +++++++++++++++++++++++++++++++++++- Network/Socket/Unix.hsc | 2 +- tests/Network/SocketSpec.hs | 37 +++++++++++ 5 files changed, 163 insertions(+), 5 deletions(-) diff --git a/Network/Socket.hs b/Network/Socket.hs index 898cc9fc..3622a2f3 100644 --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -181,8 +181,14 @@ module Network.Socket , packFamily , unpackFamily -- ** Protocol number - , ProtocolNumber + , ProtocolNumber(UnsupportedProtocol,GeneralProtocol + ,IPPROTO_IP,IPPROTO_IPV4,IPPROTO_IPV6 + ,IPPROTO_UDP,IPPROTO_TCP + ,IPPROTO_ICMP,IPPROTO_ICMPV6,IPPROTO_RAW + ) , defaultProtocol + , packProtocol + , unpackProtocol -- * Basic socket address type , SockAddr(..) , isSupportedSockAddr diff --git a/Network/Socket/Syscall.hs b/Network/Socket/Syscall.hs index a7378be4..0b78e193 100644 --- a/Network/Socket/Syscall.hs +++ b/Network/Socket/Syscall.hs @@ -86,7 +86,7 @@ socket family stype protocol = E.bracketOnError create c_close $ \fd -> do create = do let c_stype = modifyFlag $ packSocketType stype throwSocketErrorIfMinus1Retry "Network.Socket.socket" $ - c_socket (packFamily family) c_stype protocol + c_socket (packFamily family) c_stype (packProtocol protocol) #ifdef HAVE_ADVANCED_SOCKET_FLAGS modifyFlag c_stype = c_stype .|. sockNonBlock diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc index be9b9c45..0c2aa89f 100644 --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -68,8 +68,14 @@ module Network.Socket.Types ( , withSockAddr -- * Unsorted - , ProtocolNumber + , ProtocolNumber(UnsupportedProtocol,GeneralProtocol + ,IPPROTO_IP,IPPROTO_IPV4,IPPROTO_IPV6 + ,IPPROTO_UDP,IPPROTO_TCP + ,IPPROTO_ICMP,IPPROTO_ICMPV6,IPPROTO_RAW + ) , defaultProtocol + , packProtocol + , unpackProtocol , PortNumber , defaultPort @@ -280,7 +286,15 @@ foreign import ccall unsafe "close" ----------------------------------------------------------------------------- -- | Protocol number. -type ProtocolNumber = CInt +-- +-- Derives all defined instances for Foreign.C.Types.CInt +-- to preserve API integrity as much as possible +newtype ProtocolNumber = ProtocolNumber { packProtocol :: CInt } + deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, FiniteBits, Bits, Storable) + +unpackProtocol :: CInt -> ProtocolNumber +unpackProtocol = ProtocolNumber +{-# INLINE unpackProtocol #-} -- | This is the default protocol for a given service. -- @@ -289,6 +303,107 @@ type ProtocolNumber = CInt defaultProtocol :: ProtocolNumber defaultProtocol = 0 +-- | Unsupported protocol, equal to any other protocol not supported on this system +pattern UnsupportedProtocol :: ProtocolNumber +pattern UnsupportedProtocol = ProtocolNumber (-1) + +-- | IP +pattern IPPROTO_IP :: ProtocolNumber +#ifdef IPPROTO_IP +pattern IPPROTO_IP = ProtocolNumber (#const IPPROTO_IP) +#else +pattern IPPROTO_IP = ProtocolNumber (-1) +#endif + +-- | IPv4 +pattern IPPROTO_IPV4 :: ProtocolNumber +#ifdef IPPROTO_IPV4 +pattern IPPROTO_IPV4 = ProtocolNumber (#const IPPROTO_IPV4) +#else +pattern IPPROTO_IPV4 = ProtocolNumber (-1) +#endif + +-- | IPv6 +pattern IPPROTO_IPV6 :: ProtocolNumber +#ifdef IPPROTO_IPV6 +pattern IPPROTO_IPV6 = ProtocolNumber (#const IPPROTO_IPV6) +#else +pattern IPPROTO_IPV6 = ProtocolNumber (-1) +#endif + +-- | UDP +pattern IPPROTO_UDP :: ProtocolNumber +#ifdef IPPROTO_UDP +pattern IPPROTO_UDP = ProtocolNumber (#const IPPROTO_UDP) +#else +pattern IPPROTO_UDP = ProtocolNumber (-1) +#endif + +-- | TCP +pattern IPPROTO_TCP :: ProtocolNumber +#ifdef IPPROTO_TCP +pattern IPPROTO_TCP = ProtocolNumber (#const IPPROTO_TCP) +#else +pattern IPPROTO_TCP = ProtocolNumber (-1) +#endif + +-- | ICMP +pattern IPPROTO_ICMP :: ProtocolNumber +#ifdef IPPROTO_ICMP +pattern IPPROTO_ICMP = ProtocolNumber (#const IPPROTO_ICMP) +#else +pattern IPPROTO_ICMP = ProtocolNumber (-1) +#endif + +-- | ICMPv6 +pattern IPPROTO_ICMPV6 :: ProtocolNumber +#ifdef IPPROTO_ICMPV6 +pattern IPPROTO_ICMPV6 = ProtocolNumber (#const IPPROTO_ICMPV6) +#else +pattern IPPROTO_ICMPV6 = ProtocolNumber (-1) +#endif + +-- | Raw +pattern IPPROTO_RAW :: ProtocolNumber +#ifdef IPPROTO_RAW +pattern IPPROTO_RAW = ProtocolNumber (#const IPPROTO_RAW) +#else +pattern IPPROTO_RAW = ProtocolNumber (-1) +#endif + + +pattern GeneralProtocol :: CInt -> ProtocolNumber +pattern GeneralProtocol n = ProtocolNumber n +#if __GLASGOW_HASKELL__ >= 806 +{-# COMPLETE GeneralProtocol #-} +#endif + + +protoNumBijection :: Bijection ProtocolNumber String +protoNumBijection = + [ (UnsupportedProtocol, "UnsupportedProtocol") + , (IPPROTO_IP, "IPPROTO_IP") + , (IPPROTO_IPV4, "IPPROTO_IPV4") + , (IPPROTO_IPV6, "IPPROTO_IPV6") + , (IPPROTO_UDP, "IPPROTO_UDP") + , (IPPROTO_TCP, "IPPROTO_TCP") + , (IPPROTO_ICMP, "IPPROTO_ICMP") + , (IPPROTO_ICMPV6, "IPPROTO_ICMPV6") + , (IPPROTO_RAW, "IPPROTO_RAW") + ] + +instance Show ProtocolNumber where + showsPrec = bijectiveShow protoNumBijection def + where + def = defShow "" packProtocol _showInt + +instance Read ProtocolNumber where + readPrec = bijectiveRead protoNumBijection def + where + def = defRead "" unpackProtocol _readInt + + + ----------------------------------------------------------------------------- -- Socket types diff --git a/Network/Socket/Unix.hsc b/Network/Socket/Unix.hsc index bc5298a0..13036ac4 100644 --- a/Network/Socket/Unix.hsc +++ b/Network/Socket/Unix.hsc @@ -180,7 +180,7 @@ socketPair family stype protocol = allocaBytes (2 * sizeOf (1 :: CInt)) $ \ fdArr -> do let c_stype = packSocketType stype _rc <- throwSocketErrorIfMinus1Retry "Network.Socket.socketpair" $ - c_socketpair (packFamily family) c_stype protocol fdArr + c_socketpair (packFamily family) c_stype (packProtocol protocol) fdArr [fd1,fd2] <- peekArray 2 fdArr setNonBlockIfNeeded fd1 setNonBlockIfNeeded fd2 diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs index 76d32972..f8451acd 100644 --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -352,6 +352,23 @@ spec = do let socktype = GeneralSocketType (-300) in show socktype `shouldBe` "GeneralSocketType (-300)" + describe "show ProtocolNumber" $ do + it "works for pattern synonyms" $ + let proto = IPPROTO_IP in + show proto `shouldBe` "IPPROTO_IP" + + it "works for unsupported" $ + let proto = GeneralProtocol (-1) in + show proto `shouldBe` "UnsupportedProtocol" + + it "works for positive values" $ + let proto = GeneralProtocol 300 in + show proto `shouldBe` "300" + + it "works for negative values" $ + let proto = GeneralProtocol (-300) in + show proto `shouldBe` "-300" + describe "show SocketOptions" $ do it "works for pattern synonyms" $ let opt = ReuseAddr in @@ -393,6 +410,9 @@ spec = do it "holds for SocketType" $ forAll socktypeGen $ \x -> (read . show $ x) == (x :: SocketType) + it "holds for ProtocolNumber" $ forAll protoGen $ + \x -> (read . show $ x) == (x :: ProtocolNumber) + it "holds for SocketOption" $ forAll sockoptGen $ \x -> (read . show $ x) == (x :: SocketOption) @@ -417,6 +437,9 @@ familyGen = biasedGen (fmap GeneralFamily) familyPatterns arbitrary socktypeGen :: Gen SocketType socktypeGen = biasedGen (fmap GeneralSocketType) socktypePatterns arbitrary +protoGen :: Gen ProtocolNumber +protoGen = biasedGen (fmap GeneralProtocol) protoPatterns arbitrary + sockoptGen :: Gen SocketOption sockoptGen = biasedGen (\g -> SockOpt <$> g <*> g) sockoptPatterns arbitrary @@ -472,3 +495,17 @@ cmsgidPatterns = nub , CmsgIdIPv6PktInfo , CmsgIdFd ] + +protoPatterns :: [ProtocolNumber] +protoPatterns = nub + [ UnsupportedProtocol + , IPPROTO_IP + , IPPROTO_IPV4 + , IPPROTO_IPV6 + , IPPROTO_UDP + , IPPROTO_TCP + , IPPROTO_ICMP + , IPPROTO_ICMPV6 + , IPPROTO_RAW + ] + From 9736cbd73c53e98bea4624a26d478e7cfcc26175 Mon Sep 17 00:00:00 2001 From: archaephyrryx Date: Fri, 17 Jul 2020 15:26:43 -0400 Subject: [PATCH 2/3] FIX doctest and IP-specific documentation Unbreaks doctest by substituting new `show` value of defaultProtocol where it appears in haddock examples Clarifies behavior of show for ProtocolNumber to highlight that pattern synonym names and their corresponding show values are based on assumption of IP protocol families even though the type itself remains general over all protocol families. --- Network/Socket/Info.hsc | 2 +- Network/Socket/Types.hsc | 8 +++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/Network/Socket/Info.hsc b/Network/Socket/Info.hsc index 0a874a92..026cca99 100644 --- a/Network/Socket/Info.hsc +++ b/Network/Socket/Info.hsc @@ -188,7 +188,7 @@ niFlagMapping = [(NI_DGRAM, #const NI_DGRAM), -- >>> addrSocketType defaultHints -- NoSocketType -- >>> addrProtocol defaultHints --- 0 +-- IPPROTO_IP defaultHints :: AddrInfo defaultHints = AddrInfo { diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc index 0c2aa89f..9ed2bc1b 100644 --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -289,6 +289,12 @@ foreign import ccall unsafe "close" -- -- Derives all defined instances for Foreign.C.Types.CInt -- to preserve API integrity as much as possible +-- +-- Show and Read instances are defined explicitly to match +-- pattern synonym names, and are specialized for IP protocol +-- numbers. The @ProtocolNumber@ type can be used with non-IP protocol +-- families as well, but will be displayed and parsed as if they were +-- IP protocol numbers newtype ProtocolNumber = ProtocolNumber { packProtocol :: CInt } deriving (Bounded, Enum, Eq, Integral, Num, Ord, Real, FiniteBits, Bits, Storable) @@ -299,7 +305,7 @@ unpackProtocol = ProtocolNumber -- | This is the default protocol for a given service. -- -- >>> defaultProtocol --- 0 +-- IPPROTO_IP defaultProtocol :: ProtocolNumber defaultProtocol = 0 From d988efd45047db4cd099e5fc601e5e9af25938c0 Mon Sep 17 00:00:00 2001 From: archaephyrryx Date: Sat, 18 Jul 2020 14:25:56 -0400 Subject: [PATCH 3/3] refactors definitions of protocolnumber synonyms Redefines ProtocolNumber synonyms in terms of canonical "magic" numbers from IANA reference (https://www.iana.org/assignments/protocol-numbers) rather than CPP-constants from C header file. Removes UnsupportedProtocol as all definitions are unconditional instead of relying on C header-file macro definitions; redefines test case to ensure that the value 'ProtocolNumber (-1)' is represented shown as "-1" rather than "UnsupportedProtocol" Renames IPPROTO_IP (dummy for '0') as DefaultProtocol, both as a pattern synonym and in read/show boilerplate bijection (as well as in haddock examples and tests/Network/SocketSpec.hs) --- Network/Socket.hs | 4 +- Network/Socket/Info.hsc | 2 +- Network/Socket/Types.hsc | 93 ++++++++++++------------------------- tests/Network/SocketSpec.hs | 9 ++-- 4 files changed, 37 insertions(+), 71 deletions(-) diff --git a/Network/Socket.hs b/Network/Socket.hs index 3622a2f3..488dd0cb 100644 --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -181,8 +181,8 @@ module Network.Socket , packFamily , unpackFamily -- ** Protocol number - , ProtocolNumber(UnsupportedProtocol,GeneralProtocol - ,IPPROTO_IP,IPPROTO_IPV4,IPPROTO_IPV6 + , ProtocolNumber(DefaultProtocol,GeneralProtocol + ,IPPROTO_IPV4,IPPROTO_IPV6 ,IPPROTO_UDP,IPPROTO_TCP ,IPPROTO_ICMP,IPPROTO_ICMPV6,IPPROTO_RAW ) diff --git a/Network/Socket/Info.hsc b/Network/Socket/Info.hsc index 026cca99..7328fc22 100644 --- a/Network/Socket/Info.hsc +++ b/Network/Socket/Info.hsc @@ -188,7 +188,7 @@ niFlagMapping = [(NI_DGRAM, #const NI_DGRAM), -- >>> addrSocketType defaultHints -- NoSocketType -- >>> addrProtocol defaultHints --- IPPROTO_IP +-- DefaultProtocol defaultHints :: AddrInfo defaultHints = AddrInfo { diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc index 9ed2bc1b..8493fb87 100644 --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -68,8 +68,8 @@ module Network.Socket.Types ( , withSockAddr -- * Unsorted - , ProtocolNumber(UnsupportedProtocol,GeneralProtocol - ,IPPROTO_IP,IPPROTO_IPV4,IPPROTO_IPV6 + , ProtocolNumber(DefaultProtocol,GeneralProtocol + ,IPPROTO_IPV4,IPPROTO_IPV6 ,IPPROTO_UDP,IPPROTO_TCP ,IPPROTO_ICMP,IPPROTO_ICMPV6,IPPROTO_RAW ) @@ -305,77 +305,45 @@ unpackProtocol = ProtocolNumber -- | This is the default protocol for a given service. -- -- >>> defaultProtocol --- IPPROTO_IP +-- DefaultProtocol defaultProtocol :: ProtocolNumber -defaultProtocol = 0 +defaultProtocol = DefaultProtocol --- | Unsupported protocol, equal to any other protocol not supported on this system -pattern UnsupportedProtocol :: ProtocolNumber -pattern UnsupportedProtocol = ProtocolNumber (-1) +-- * Unlike other types, pattern synonym values for ProtocolNumbers are defined according to +-- canonical IANA protocol number assignment table. +-- names correspond to constant definitions from header file "netinet/in.h" --- | IP -pattern IPPROTO_IP :: ProtocolNumber -#ifdef IPPROTO_IP -pattern IPPROTO_IP = ProtocolNumber (#const IPPROTO_IP) -#else -pattern IPPROTO_IP = ProtocolNumber (-1) -#endif +-- | Universal default for any protocol family = 0 +pattern DefaultProtocol :: ProtocolNumber +pattern DefaultProtocol = ProtocolNumber 0 + +-- | ICMP = 1 +pattern IPPROTO_ICMP :: ProtocolNumber +pattern IPPROTO_ICMP = ProtocolNumber 1 --- | IPv4 +-- | IPv4 = 4 pattern IPPROTO_IPV4 :: ProtocolNumber -#ifdef IPPROTO_IPV4 -pattern IPPROTO_IPV4 = ProtocolNumber (#const IPPROTO_IPV4) -#else -pattern IPPROTO_IPV4 = ProtocolNumber (-1) -#endif +pattern IPPROTO_IPV4 = ProtocolNumber 4 --- | IPv6 -pattern IPPROTO_IPV6 :: ProtocolNumber -#ifdef IPPROTO_IPV6 -pattern IPPROTO_IPV6 = ProtocolNumber (#const IPPROTO_IPV6) -#else -pattern IPPROTO_IPV6 = ProtocolNumber (-1) -#endif +-- | TCP = 6 +pattern IPPROTO_TCP :: ProtocolNumber +pattern IPPROTO_TCP = ProtocolNumber 6 --- | UDP +-- | UDP = 17 pattern IPPROTO_UDP :: ProtocolNumber -#ifdef IPPROTO_UDP -pattern IPPROTO_UDP = ProtocolNumber (#const IPPROTO_UDP) -#else -pattern IPPROTO_UDP = ProtocolNumber (-1) -#endif +pattern IPPROTO_UDP = ProtocolNumber 17 --- | TCP -pattern IPPROTO_TCP :: ProtocolNumber -#ifdef IPPROTO_TCP -pattern IPPROTO_TCP = ProtocolNumber (#const IPPROTO_TCP) -#else -pattern IPPROTO_TCP = ProtocolNumber (-1) -#endif - --- | ICMP -pattern IPPROTO_ICMP :: ProtocolNumber -#ifdef IPPROTO_ICMP -pattern IPPROTO_ICMP = ProtocolNumber (#const IPPROTO_ICMP) -#else -pattern IPPROTO_ICMP = ProtocolNumber (-1) -#endif +-- | IPv6 = 41 +pattern IPPROTO_IPV6 :: ProtocolNumber +pattern IPPROTO_IPV6 = ProtocolNumber 41 --- | ICMPv6 +-- | ICMP IPv6 = 58 pattern IPPROTO_ICMPV6 :: ProtocolNumber -#ifdef IPPROTO_ICMPV6 -pattern IPPROTO_ICMPV6 = ProtocolNumber (#const IPPROTO_ICMPV6) -#else -pattern IPPROTO_ICMPV6 = ProtocolNumber (-1) -#endif +pattern IPPROTO_ICMPV6 = ProtocolNumber 58 --- | Raw +-- | Raw = 255 pattern IPPROTO_RAW :: ProtocolNumber -#ifdef IPPROTO_RAW -pattern IPPROTO_RAW = ProtocolNumber (#const IPPROTO_RAW) -#else -pattern IPPROTO_RAW = ProtocolNumber (-1) -#endif +pattern IPPROTO_RAW = ProtocolNumber 255 pattern GeneralProtocol :: CInt -> ProtocolNumber @@ -387,8 +355,7 @@ pattern GeneralProtocol n = ProtocolNumber n protoNumBijection :: Bijection ProtocolNumber String protoNumBijection = - [ (UnsupportedProtocol, "UnsupportedProtocol") - , (IPPROTO_IP, "IPPROTO_IP") + [ (DefaultProtocol,"DefaultProtocol") , (IPPROTO_IPV4, "IPPROTO_IPV4") , (IPPROTO_IPV6, "IPPROTO_IPV6") , (IPPROTO_UDP, "IPPROTO_UDP") @@ -524,7 +491,7 @@ newtype Family = Family { packFamily :: CInt } deriving (Eq, Ord) isSupportedFamily :: Family -> Bool isSupportedFamily f = case f of UnsupportedFamily -> False - GeneralFamily _ -> True + _ -> True -- | Convert 'CInt' to 'Family'. unpackFamily :: CInt -> Family diff --git a/tests/Network/SocketSpec.hs b/tests/Network/SocketSpec.hs index f8451acd..e10a3115 100644 --- a/tests/Network/SocketSpec.hs +++ b/tests/Network/SocketSpec.hs @@ -354,12 +354,12 @@ spec = do describe "show ProtocolNumber" $ do it "works for pattern synonyms" $ - let proto = IPPROTO_IP in - show proto `shouldBe` "IPPROTO_IP" + let proto = DefaultProtocol in + show proto `shouldBe` "DefaultProtocol" it "works for unsupported" $ let proto = GeneralProtocol (-1) in - show proto `shouldBe` "UnsupportedProtocol" + show proto `shouldBe` "-1" it "works for positive values" $ let proto = GeneralProtocol 300 in @@ -498,8 +498,7 @@ cmsgidPatterns = nub protoPatterns :: [ProtocolNumber] protoPatterns = nub - [ UnsupportedProtocol - , IPPROTO_IP + [ DefaultProtocol , IPPROTO_IPV4 , IPPROTO_IPV6 , IPPROTO_UDP