[Experimental] WIP newtype redefinition of ProtocolNumber

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

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 {

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

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

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

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
+    ]
+