diff --git a/Network/Socket.hs b/Network/Socket.hs index 898cc9fc..488dd0cb 100644 --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -181,8 +181,14 @@ module Network.Socket , packFamily , unpackFamily -- ** Protocol number - , ProtocolNumber + , ProtocolNumber(DefaultProtocol,GeneralProtocol + ,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/Info.hsc b/Network/Socket/Info.hsc index 0a874a92..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 --- 0 +-- DefaultProtocol defaultHints :: AddrInfo defaultHints = AddrInfo { 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..8493fb87 100644 --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -68,8 +68,14 @@ module Network.Socket.Types ( , withSockAddr -- * Unsorted - , ProtocolNumber + , ProtocolNumber(DefaultProtocol,GeneralProtocol + ,IPPROTO_IPV4,IPPROTO_IPV6 + ,IPPROTO_UDP,IPPROTO_TCP + ,IPPROTO_ICMP,IPPROTO_ICMPV6,IPPROTO_RAW + ) , defaultProtocol + , packProtocol + , unpackProtocol , PortNumber , defaultPort @@ -280,14 +286,96 @@ 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 +-- +-- 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) + +unpackProtocol :: CInt -> ProtocolNumber +unpackProtocol = ProtocolNumber +{-# INLINE unpackProtocol #-} -- | This is the default protocol for a given service. -- -- >>> defaultProtocol --- 0 +-- DefaultProtocol defaultProtocol :: ProtocolNumber -defaultProtocol = 0 +defaultProtocol = DefaultProtocol + +-- * 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" + +-- | 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 = 4 +pattern IPPROTO_IPV4 :: ProtocolNumber +pattern IPPROTO_IPV4 = ProtocolNumber 4 + +-- | TCP = 6 +pattern IPPROTO_TCP :: ProtocolNumber +pattern IPPROTO_TCP = ProtocolNumber 6 + +-- | UDP = 17 +pattern IPPROTO_UDP :: ProtocolNumber +pattern IPPROTO_UDP = ProtocolNumber 17 + +-- | IPv6 = 41 +pattern IPPROTO_IPV6 :: ProtocolNumber +pattern IPPROTO_IPV6 = ProtocolNumber 41 + +-- | ICMP IPv6 = 58 +pattern IPPROTO_ICMPV6 :: ProtocolNumber +pattern IPPROTO_ICMPV6 = ProtocolNumber 58 + +-- | Raw = 255 +pattern IPPROTO_RAW :: ProtocolNumber +pattern IPPROTO_RAW = ProtocolNumber 255 + + +pattern GeneralProtocol :: CInt -> ProtocolNumber +pattern GeneralProtocol n = ProtocolNumber n +#if __GLASGOW_HASKELL__ >= 806 +{-# COMPLETE GeneralProtocol #-} +#endif + + +protoNumBijection :: Bijection ProtocolNumber String +protoNumBijection = + [ (DefaultProtocol,"DefaultProtocol") + , (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 @@ -403,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/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..e10a3115 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 = DefaultProtocol in + show proto `shouldBe` "DefaultProtocol" + + it "works for unsupported" $ + let proto = GeneralProtocol (-1) in + show proto `shouldBe` "-1" + + 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,16 @@ cmsgidPatterns = nub , CmsgIdIPv6PktInfo , CmsgIdFd ] + +protoPatterns :: [ProtocolNumber] +protoPatterns = nub + [ DefaultProtocol + , IPPROTO_IPV4 + , IPPROTO_IPV6 + , IPPROTO_UDP + , IPPROTO_TCP + , IPPROTO_ICMP + , IPPROTO_ICMPV6 + , IPPROTO_RAW + ] +