Socket type and family as CInt patterns

The current sum-type model for Socket types and families is not extensible, and makes it needlessly difficult to perform generic operations on sockets, see e.g. #427 This commit, simplifies the model by replacing the sum-types in question with newtypes around CInt + patterns for the known constant values. It also adds the SO_DOMAIN and SO_PROTOCOL options (when available on the target system). The "Read" instance for "Family" is for simplicify limited to just the address families actually supported by the library (unspec, inet, inet6 and unix). The rest could be added if deemed worth the trouble.
haskell · May 23, 2020 · 46d2996 · 46d2996
1 parent ef42779
commit 46d2996
Show file tree

Hide file tree

Showing 6 changed files with 698 additions and 459 deletions.
diff --git a/Network/Socket.hs b/Network/Socket.hs
@@ -134,9 +134,9 @@ module Network.Socket
 
     -- * Socket options
     , SocketOption(SockOpt
-                  ,Debug,ReuseAddr,Type,SoError,DontRoute,Broadcast
-                  ,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive
-                  ,MaxSegment,NoDelay,Cork,Linger,ReusePort
+                  ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute
+                  ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline
+                  ,TimeToLive,MaxSegment,NoDelay,Cork,Linger,ReusePort
                   ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut
                   ,UseLoopBack,UserTimeout,IPv6Only
                   ,RecvIPv4TTL,RecvIPv4TOS,RecvIPv4PktInfo
@@ -160,11 +160,22 @@ module Network.Socket
     , mkSocket
     , socketToHandle
     -- ** Types of Socket
-    , SocketType(..)
+    , SocketType(GeneralSocketType, UnsupportedSocketType, NoSocketType
+                , Stream, Datagram, Raw, RDM, SeqPacket)
     , isSupportedSocketType
     , getSocketType
     -- ** Family
-    , Family(..)
+    , Family(GeneralFamily, UnsupportedFamily
+            ,AF_UNSPEC,AF_UNIX,AF_INET,AF_INET6,AF_IMPLINK,AF_PUP,AF_CHAOS
+            ,AF_NS,AF_NBS,AF_ECMA,AF_DATAKIT,AF_CCITT,AF_SNA,AF_DECnet
+            ,AF_DLI,AF_LAT,AF_HYLINK,AF_APPLETALK,AF_ROUTE,AF_NETBIOS
+            ,AF_NIT,AF_802,AF_ISO,AF_OSI,AF_NETMAN,AF_X25,AF_AX25,AF_OSINET
+            ,AF_GOSSIP,AF_IPX,Pseudo_AF_XTP,AF_CTF,AF_WAN,AF_SDL,AF_NETWARE
+            ,AF_NDD,AF_INTF,AF_COIP,AF_CNT,Pseudo_AF_RTIP,Pseudo_AF_PIP
+            ,AF_SIP,AF_ISDN,Pseudo_AF_KEY,AF_NATM,AF_ARP,Pseudo_AF_HDRCMPLT
+            ,AF_ENCAP,AF_LINK,AF_RAW,AF_RIF,AF_NETROM,AF_BRIDGE,AF_ATMPVC
+            ,AF_ROSE,AF_NETBEUI,AF_SECURITY,AF_PACKET,AF_ASH,AF_ECONET
+            ,AF_ATMSVC,AF_IRDA,AF_PPPOX,AF_WANPIPE,AF_BLUETOOTH,AF_CAN)
     , isSupportedFamily
     , packFamily
     , unpackFamily

diff --git a/Network/Socket/Info.hsc b/Network/Socket/Info.hsc
@@ -124,18 +124,17 @@ instance Storable AddrInfo where
                         then return Nothing
                         else Just <$> peekCString ai_canonname_ptr
 
-        socktype <- unpackSocketType' "AddrInfo.peek" ai_socktype
         return $ AddrInfo {
             addrFlags = unpackBits aiFlagMapping ai_flags
           , addrFamily = unpackFamily ai_family
-          , addrSocketType = socktype
+          , addrSocketType = unpackSocketType ai_socktype
           , addrProtocol = ai_protocol
           , addrAddress = ai_addr
           , addrCanonName = ai_canonname
           }
 
     poke p (AddrInfo flags family sockType protocol _ _) = do
-        c_stype <- packSocketTypeOrThrow "AddrInfo.poke" sockType
+        let c_stype = packSocketType sockType
 
         (#poke struct addrinfo, ai_flags) p (packBits aiFlagMapping flags)
         (#poke struct addrinfo, ai_family) p (packFamily family)

diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc
@@ -9,8 +9,8 @@
 
 module Network.Socket.Options (
     SocketOption(SockOpt
-                ,Debug,ReuseAddr,Type,SoError,DontRoute,Broadcast
-                ,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive
+                ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute
+                ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive
                 ,MaxSegment,NoDelay,Cork,Linger,ReusePort
                 ,RecvLowWater,SendLowWater,RecvTimeOut,SendTimeOut
                 ,UseLoopBack,UserTimeout,IPv6Only
@@ -53,8 +53,7 @@ isSupportedSocketOption opt = opt /= SockOpt (-1) (-1)
 --
 --   Since: 3.0.1.0
 getSocketType :: Socket -> IO SocketType
-getSocketType s = (fromMaybe NoSocketType . unpackSocketType . fromIntegral)
-                    <$> getSocketOption s Type
+getSocketType s = unpackSocketType <$> getSockOpt s Type
 
 #ifdef SOL_SOCKET
 -- | SO_DEBUG
@@ -71,13 +70,31 @@ pattern ReuseAddr      = SockOpt (#const SOL_SOCKET) (#const SO_REUSEADDR)
 #else
 pattern ReuseAddr      = SockOpt (-1) (-1)
 #endif
--- | SO_TYPE
+
+-- | SO_DOMAIN, read-only
+pattern SoDomain :: SocketOption
+#ifdef SO_DOMAIN
+pattern SoDomain       = SockOpt (#const SOL_SOCKET) (#const SO_DOMAIN)
+#else
+pattern SoDomain       = SockOpt (-1) (-1)
+#endif
+
+-- | SO_TYPE, read-only
 pattern Type :: SocketOption
 #ifdef SO_TYPE
 pattern Type           = SockOpt (#const SOL_SOCKET) (#const SO_TYPE)
 #else
 pattern Type           = SockOpt (-1) (-1)
 #endif
+
+-- | SO_PROTOCOL, read-only
+pattern SoProtocol :: SocketOption
+#ifdef SO_PROTOCOL
+pattern SoProtocol     = SockOpt (#const SOL_SOCKET) (#const SO_PROTOCOL)
+#else
+pattern SoProtocol     = SockOpt (-1) (-1)
+#endif
+
 -- | SO_ERROR
 pattern SoError :: SocketOption
 #ifdef SO_ERROR

diff --git a/Network/Socket/Syscall.hs b/Network/Socket/Syscall.hs
@@ -84,7 +84,7 @@ socket family stype protocol = E.bracketOnError create c_close $ \fd -> do
     return s
   where
     create = do
-        c_stype <- modifyFlag <$> packSocketTypeOrThrow "socket" stype
+        let c_stype = modifyFlag $ packSocketType stype
         throwSocketErrorIfMinus1Retry "Network.Socket.socket" $
             c_socket (packFamily family) c_stype protocol