diff --git a/Network/Socket.hs b/Network/Socket.hs index 1246d4a2..5c4f459b 100644 --- a/Network/Socket.hs +++ b/Network/Socket.hs @@ -134,6 +134,7 @@ module Network.Socket -- * Socket options , SocketOption(SockOpt + ,UnsupportedSocketOption ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline ,TimeToLive,MaxSegment,NoDelay,Cork,Linger,ReusePort @@ -244,7 +245,7 @@ module Network.Socket ,CmsgIdIPv6TClass ,CmsgIdIPv4PktInfo ,CmsgIdIPv6PktInfo - ,CmsgIdFd) + ,UnsupportedCmsgId) -- ** APIs for control message , lookupCmsg , filterCmsg diff --git a/Network/Socket/Flag.hsc b/Network/Socket/Flag.hsc index ad55f12d..42788845 100644 --- a/Network/Socket/Flag.hsc +++ b/Network/Socket/Flag.hsc @@ -10,6 +10,12 @@ import qualified Data.Semigroup as Sem import Network.Socket.Imports +{- +import Network.Socket.ReadShow + +import qualified Text.Read as P +-} + -- | Message flags. To combine flags, use '(<>)'. newtype MsgFlag = MsgFlag { fromMsgFlag :: CInt } deriving (Show, Eq, Ord, Num, Bits) @@ -78,3 +84,16 @@ pattern MSG_WAITALL = MsgFlag (#const MSG_WAITALL) #else pattern MSG_WAITALL = MsgFlag 0 #endif + +{- +msgFlagPairs :: [Pair MsgFlag String] +msgFlagPairs = + [ (MSG_OOB, "MSG_OOB") + , (MSG_DONTROUTE, "MSG_DONTROUTE") + , (MSG_PEEK, "MSG_PEEK") + , (MSG_EOR, "MSG_EOR") + , (MSG_TRUNC, "MSG_TRUNC") + , (MSG_CTRUNC, "MSG_CTRUNC") + , (MSG_WAITALL, "MSG_WAITALL") + ] +-} diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc index f0b159f1..80364a84 100644 --- a/Network/Socket/Options.hsc +++ b/Network/Socket/Options.hsc @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} #include "HsNet.h" @@ -8,6 +9,7 @@ module Network.Socket.Options ( SocketOption(SockOpt + ,UnsupportedSocketOption ,Debug,ReuseAddr,SoDomain,Type,SoProtocol,SoError,DontRoute ,Broadcast,SendBuffer,RecvBuffer,KeepAlive,OOBInline,TimeToLive ,MaxSegment,NoDelay,Cork,Linger,ReusePort @@ -25,12 +27,15 @@ module Network.Socket.Options ( , setSockOpt ) where +import qualified Text.Read as P + import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with) import Network.Socket.Imports import Network.Socket.Internal import Network.Socket.Types +import Network.Socket.ReadShow ----------------------------------------------------------------------------- -- Socket Properties @@ -39,10 +44,15 @@ import Network.Socket.Types -- -- The existence of a constructor does not imply that the relevant option -- is supported on your system: see 'isSupportedSocketOption' -data SocketOption = SockOpt { - sockOptLevel :: !CInt - , sockOptName :: !CInt - } deriving (Eq, Show) +data SocketOption = SockOpt +#if __GLASGOW_HASKELL__ >= 806 + !CInt -- ^ Option Level + !CInt -- ^ Option Name +#else + !CInt -- Option Level + !CInt -- Option Name +#endif + deriving (Eq) -- | Does the 'SocketOption' exist on this system? isSupportedSocketOption :: SocketOption -> Bool @@ -54,6 +64,9 @@ isSupportedSocketOption opt = opt /= SockOpt (-1) (-1) getSocketType :: Socket -> IO SocketType getSocketType s = unpackSocketType <$> getSockOpt s Type +pattern UnsupportedSocketOption :: SocketOption +pattern UnsupportedSocketOption = SockOpt (-1) (-1) + #ifdef SOL_SOCKET -- | SO_DEBUG pattern Debug :: SocketOption @@ -141,7 +154,7 @@ pattern OOBInline :: SocketOption #ifdef SO_OOBINLINE pattern OOBInline = SockOpt (#const SOL_SOCKET) (#const SO_OOBINLINE) #else -pattern OOBINLINE = SockOpt (-1) (-1) +pattern OOBInline = SockOpt (-1) (-1) #endif -- | SO_LINGER: timeout in seconds, 0 means disabling/disabled. pattern Linger :: SocketOption @@ -376,6 +389,59 @@ getSockOpt s (SockOpt level opt) = do c_getsockopt fd level opt ptr ptr_sz peek ptr + +socketOptionPairs :: [Pair SocketOption String] +socketOptionPairs = + [ (UnsupportedSocketOption, "UnsupportedSocketOption") + , (Debug, "Debug") + , (ReuseAddr, "ReuseAddr") + , (SoDomain, "SoDomain") + , (Type, "Type") + , (SoProtocol, "SoProtocol") + , (SoError, "SoError") + , (DontRoute, "DontRoute") + , (Broadcast, "Broadcast") + , (SendBuffer, "SendBuffer") + , (RecvBuffer, "RecvBuffer") + , (KeepAlive, "KeepAlive") + , (OOBInline, "OOBInline") + , (Linger, "Linger") + , (ReusePort, "ReusePort") + , (RecvLowWater, "RecvLowWater") + , (SendLowWater, "SendLowWater") + , (RecvTimeOut, "RecvTimeOut") + , (SendTimeOut, "SendTimeOut") + , (UseLoopBack, "UseLoopBack") + , (MaxSegment, "MaxSegment") + , (NoDelay, "NoDelay") + , (UserTimeout, "UserTimeout") + , (Cork, "Cork") + , (TimeToLive, "TimeToLive") + , (RecvIPv4TTL, "RecvIPv4TTL") + , (RecvIPv4TOS, "RecvIPv4TOS") + , (RecvIPv4PktInfo, "RecvIPv4PktInfo") + , (IPv6Only, "IPv6Only") + , (RecvIPv6HopLimit, "RecvIPv6HopLimit") + , (RecvIPv6TClass, "RecvIPv6TClass") + , (RecvIPv6PktInfo, "RecvIPv6PktInfo") + ] + +socketOptionBijection :: Bijection SocketOption String +socketOptionBijection = Bijection{..} + where + cso = "CustomSockOpt" + unCSO = \(CustomSockOpt nm) -> nm + defFwd = defShow cso unCSO _show + defBwd = defRead cso CustomSockOpt _parse + pairs = socketOptionPairs + +instance Show SocketOption where + show = forward socketOptionBijection + +instance Read SocketOption where + readPrec = tokenize $ backward socketOptionBijection + + foreign import CALLCONV unsafe "getsockopt" c_getsockopt :: CInt -> CInt -> CInt -> Ptr a -> Ptr CInt -> IO CInt foreign import CALLCONV unsafe "setsockopt" diff --git a/Network/Socket/Posix/Cmsg.hsc b/Network/Socket/Posix/Cmsg.hsc index a605a860..9f6d7063 100644 --- a/Network/Socket/Posix/Cmsg.hsc +++ b/Network/Socket/Posix/Cmsg.hsc @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -19,6 +20,9 @@ import System.Posix.Types (Fd(..)) import Network.Socket.Imports import Network.Socket.Types +import Network.Socket.ReadShow + +import qualified Text.Read as P -- | Control message (ancillary data) including a pair of level and type. data Cmsg = Cmsg { @@ -32,7 +36,11 @@ data Cmsg = Cmsg { data CmsgId = CmsgId { cmsgLevel :: !CInt , cmsgType :: !CInt - } deriving (Eq, Show) + } deriving (Eq) + +-- | Unsupported identifier +pattern UnsupportedCmsgId :: CmsgId +pattern UnsupportedCmsgId = CmsgId (-1) (-1) -- | The identifier for 'IPv4TTL'. pattern CmsgIdIPv4TTL :: CmsgId @@ -220,3 +228,30 @@ instance Storable IPv6PktInfo where instance ControlMessage Fd where controlMessageId = CmsgIdFd + +cmsgIdPairs :: [Pair CmsgId String] +cmsgIdPairs = + [ (UnsupportedCmsgId, "UnsupportedCmsgId") + , (CmsgIdIPv4TTL, "CmsgIdIPv4TTL") + , (CmsgIdIPv6HopLimit, "CmsgIdIPv6HopLimit") + , (CmsgIdIPv4TOS, "CmsgIdIPv4TOS") + , (CmsgIdIPv6TClass, "CmsgIdIPv6TClass") + , (CmsgIdIPv4PktInfo, "CmsgIdIPv4PktInfo") + , (CmsgIdIPv6PktInfo, "CmsgIdIPv6PktInfo") + , (CmsgIdFd, "CmsgIdFd") + ] + +cmsgIdBijection :: Bijection CmsgId String +cmsgIdBijection = Bijection{..} + where + defname = "CmsgId" + unId = \(CmsgId l t) -> (l,t) + defFwd = defShow defname unId _show + defBwd = defRead defname (uncurry CmsgId) _parse + pairs = cmsgIdPairs + +instance Show CmsgId where + show = forward cmsgIdBijection + +instance Read CmsgId where + readPrec = tokenize $ backward cmsgIdBijection diff --git a/Network/Socket/ReadShow.hs b/Network/Socket/ReadShow.hs new file mode 100644 index 00000000..a656dedd --- /dev/null +++ b/Network/Socket/ReadShow.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} + + +module Network.Socket.ReadShow where + +import qualified Text.Read as P + +-- type alias for individual correspondences of a (possibly partial) bijection +type Pair a b = (a, b) + +-- | helper function for equality on first tuple element +{-# INLINE eqFst #-} +eqFst :: Eq a => a -> (a, b) -> Bool +eqFst x = \(x',_) -> x' == x + +-- | helper function for equality on snd tuple element +{-# INLINE eqSnd #-} +eqSnd :: Eq b => b -> (a, b) -> Bool +eqSnd y = \(_,y') -> y' == y + +-- | Return RHS element that is paired with provided LHS, +-- or apply a default fallback function if the list is partial +lookForward :: Eq a => (a -> b) -> [Pair a b] -> a -> b +lookForward defFwd ps x + = case filter (eqFst x) ps of + (_,y):_ -> y + [] -> defFwd x + +-- | Return LHS element that is paired with provided RHS, +-- or apply a default fallback function if the list is partial +lookBackward :: Eq b => (b -> a) -> [Pair a b] -> b -> a +lookBackward defBwd ps y + = case filter (eqSnd y) ps of + (x,_):_ -> x + [] -> defBwd y + +data Bijection a b + = Bijection + { defFwd :: a -> b + , defBwd :: b -> a + , pairs :: [Pair a b] + } + +-- | apply a bijection over an LHS-value +forward :: (Eq a) => Bijection a b -> a -> b +forward Bijection{..} = lookForward defFwd pairs + +-- | apply a bijection over an RHS-value +backward :: (Eq b) => Bijection a b -> b -> a +backward Bijection{..} = lookBackward defBwd pairs + +-- | show function for Int-like types that encodes negative numbers +-- with leading '_' instead of '-' +_showInt :: (Show a, Num a, Ord a) => a -> String +_showInt n | n < 0 = let ('-':s) = show n in '_':s + | otherwise = show n + +-- | parse function for Int-like types that interprets leading '_' +-- as if it were '-' instead +_readInt :: (Read a) => String -> a +_readInt ('_':s) = read $ '-':s +_readInt s = read s + + +-- | parse a quote-separated pair into a tuple of Int-like values +-- should not be used if either type might have +-- literal quote-characters in the Read pre-image +_parse :: (Read a, Read b) => String -> (a, b) +_parse xy = + let (xs, '\'':ys) = break (=='\'') xy + in (_readInt xs, _readInt ys) +{-# INLINE _parse #-} + +-- | inverse function to _parse +-- show a tuple of Int-like values as quote-separated strings +_show :: (Show a, Num a, Ord a, Show b, Num b, Ord b) => (a, b) -> String +_show (x, y) = _showInt x ++ "'" ++ _showInt y +{-# INLINE _show #-} + +defShow :: Eq a => String -> (a -> b) -> (b -> String) -> (a -> String) +defShow name unwrap sho = \x -> name ++ (sho . unwrap $ x) +{-# INLINE defShow #-} + +defRead :: Read a => String -> (b -> a) -> (String -> b) -> (String -> a) +defRead name wrap red = \s -> + case splitAt (length name) s of + (x, sn) | x == name -> wrap $ red sn + _ -> error $ "defRead: unable to parse " ++ show s +{-# INLINE defRead #-} + +-- | Apply a precedence-invariant one-token parse function within ReadPrec monad +tokenize :: (String -> a) -> P.ReadPrec a +tokenize f = P.lexP >>= \(P.Ident x) -> return $ f x +{-# INLINE tokenize #-} diff --git a/Network/Socket/Types.hsc b/Network/Socket/Types.hsc index c10b2489..61ab0792 100644 --- a/Network/Socket/Types.hsc +++ b/Network/Socket/Types.hsc @@ -101,6 +101,10 @@ import Foreign.Marshal.Array import Network.Socket.Imports +----- readshow module import +import Network.Socket.ReadShow + + ----------------------------------------------------------------------------- -- | Basic type for a socket. @@ -1312,122 +1316,115 @@ instance Storable In6Addr where ------------------------------------------------------------------------ -- Read and Show instance for pattern-based integral newtypes +socktypePairs :: [Pair SocketType String] +socktypePairs = + [ (UnsupportedSocketType, "UnsupportedSocketType") + , (Stream, "Stream") + , (Datagram, "Datagram") + , (Raw, "Raw") + , (RDM, "RDM") + , (SeqPacket, "SeqPacket") + , (NoSocketType, "NoSocketType") + ] + +socktypeBijection :: Bijection SocketType String +socktypeBijection = Bijection{..} + where + gst = "GeneralSocketType" + defFwd = defShow gst packSocketType _showInt + defBwd = defRead gst unpackSocketType _readInt + pairs = socktypePairs + instance Show SocketType where - showsPrec _ Stream = (++) "Stream" - showsPrec _ Datagram = (++) "Datagram" - showsPrec _ Raw = (++) "Raw" - showsPrec _ RDM = (++) "RDM" - showsPrec _ SeqPacket = (++) "SeqPacket" - showsPrec _ NoSocketType = (++) "NoSocketType" - showsPrec _ UnsupportedSocketType = (++) "Unsupported" - showsPrec d (GeneralSocketType n) = - showParen (d > app_prec) $ - ("GeneralSocketType " ++) . showsPrec (app_prec+1) n + show = forward socktypeBijection instance Read SocketType where - readPrec = P.parens $ specific <++ general - where - specific = P.lexP >>= \case - P.Ident "Stream" -> return Stream - P.Ident "Datagram" -> return Datagram - P.Ident "Raw" -> return Raw - P.Ident "RDM" -> return RDM - P.Ident "SeqPacket" -> return SeqPacket - P.Ident "NoSocketType" -> return NoSocketType - P.Ident "Unsupported" -> return UnsupportedSocketType - _ -> mzero - - general = P.prec app_prec $ do - P.lift $ P.expect $ P.Ident "GeneralSocketType" - GeneralSocketType <$> P.step safeInt + readPrec = tokenize $ backward socktypeBijection + +familyPairs :: [Pair Family String] +familyPairs = + [ (UnsupportedFamily, "UnsupportedFamily") + , (AF_UNSPEC, "AF_UNSPEC") + , (AF_UNIX, "AF_UNIX") + , (AF_INET, "AF_INET") + , (AF_INET6, "AF_INET6") + , (AF_IMPLINK, "AF_IMPLINK") + , (AF_PUP, "AF_PUP") + , (AF_CHAOS, "AF_CHAOS") + , (AF_NS, "AF_NS") + , (AF_NBS, "AF_NBS") + , (AF_ECMA, "AF_ECMA") + , (AF_DATAKIT, "AF_DATAKIT") + , (AF_CCITT, "AF_CCITT") + , (AF_SNA, "AF_SNA") + , (AF_DECnet, "AF_DECnet") + , (AF_DLI, "AF_DLI") + , (AF_LAT, "AF_LAT") + , (AF_HYLINK, "AF_HYLINK") + , (AF_APPLETALK, "AF_APPLETALK") + , (AF_ROUTE, "AF_ROUTE") + , (AF_NETBIOS, "AF_NETBIOS") + , (AF_NIT, "AF_NIT") + , (AF_802, "AF_802") + , (AF_ISO, "AF_ISO") + , (AF_OSI, "AF_OSI") + , (AF_NETMAN, "AF_NETMAN") + , (AF_X25, "AF_X25") + , (AF_AX25, "AF_AX25") + , (AF_OSINET, "AF_OSINET") + , (AF_GOSSIP, "AF_GOSSIP") + , (AF_IPX, "AF_IPX") + , (Pseudo_AF_XTP, "Pseudo_AF_XTP") + , (AF_CTF, "AF_CTF") + , (AF_WAN, "AF_WAN") + , (AF_SDL, "AF_SDL") + , (AF_NETWARE, "AF_NETWARE") + , (AF_NDD, "AF_NDD") + , (AF_INTF, "AF_INTF") + , (AF_COIP, "AF_COIP") + , (AF_CNT, "AF_CNT") + , (Pseudo_AF_RTIP, "Pseudo_AF_RTIP") + , (Pseudo_AF_PIP, "Pseudo_AF_PIP") + , (AF_SIP, "AF_SIP") + , (AF_ISDN, "AF_ISDN") + , (Pseudo_AF_KEY, "Pseudo_AF_KEY") + , (AF_NATM, "AF_NATM") + , (AF_ARP, "AF_ARP") + , (Pseudo_AF_HDRCMPLT, "Pseudo_AF_HDRCMPLT") + , (AF_ENCAP, "AF_ENCAP") + , (AF_LINK, "AF_LINK") + , (AF_RAW, "AF_RAW") + , (AF_RIF, "AF_RIF") + , (AF_NETROM, "AF_NETROM") + , (AF_BRIDGE, "AF_BRIDGE") + , (AF_ATMPVC, "AF_ATMPVC") + , (AF_ROSE, "AF_ROSE") + , (AF_NETBEUI, "AF_NETBEUI") + , (AF_SECURITY, "AF_SECURITY") + , (AF_PACKET, "AF_PACKET") + , (AF_ASH, "AF_ASH") + , (AF_ECONET, "AF_ECONET") + , (AF_ATMSVC, "AF_ATMSVC") + , (AF_IRDA, "AF_IRDA") + , (AF_PPPOX, "AF_PPPOX") + , (AF_WANPIPE, "AF_WANPIPE") + , (AF_BLUETOOTH, "AF_BLUETOOTH") + , (AF_CAN, "AF_CAN") + ] + +familyBijection :: Bijection Family String +familyBijection = Bijection{..} + where + gf = "GeneralFamily" + defFwd = defShow gf packFamily _showInt + defBwd = defRead gf unpackFamily _readInt + pairs = familyPairs instance Show Family where - showsPrec _ UnsupportedFamily = (++) "UnsupportedFamily" - showsPrec _ AF_UNSPEC = (++) "AF_UNSPEC" - showsPrec _ AF_UNIX = (++) "AF_UNIX" - showsPrec _ AF_INET = (++) "AF_INET" - showsPrec _ AF_INET6 = (++) "AF_INET6" - showsPrec _ AF_IMPLINK = (++) "AF_IMPLINK" - showsPrec _ AF_PUP = (++) "AF_PUP" - showsPrec _ AF_CHAOS = (++) "AF_CHAOS" - showsPrec _ AF_NS = (++) "AF_NS" - showsPrec _ AF_NBS = (++) "AF_NBS" - showsPrec _ AF_ECMA = (++) "AF_ECMA" - showsPrec _ AF_DATAKIT = (++) "AF_DATAKIT" - showsPrec _ AF_CCITT = (++) "AF_CCITT" - showsPrec _ AF_SNA = (++) "AF_SNA" - showsPrec _ AF_DECnet = (++) "AF_DECnet" - showsPrec _ AF_DLI = (++) "AF_DLI" - showsPrec _ AF_LAT = (++) "AF_LAT" - showsPrec _ AF_HYLINK = (++) "AF_HYLINK" - showsPrec _ AF_APPLETALK = (++) "AF_APPLETALK" - showsPrec _ AF_ROUTE = (++) "AF_ROUTE" - showsPrec _ AF_NETBIOS = (++) "AF_NETBIOS" - showsPrec _ AF_NIT = (++) "AF_NIT" - showsPrec _ AF_802 = (++) "AF_802" - showsPrec _ AF_ISO = (++) "AF_ISO" - showsPrec _ AF_OSI = (++) "AF_OSI" - showsPrec _ AF_NETMAN = (++) "AF_NETMAN" - showsPrec _ AF_X25 = (++) "AF_X25" - showsPrec _ AF_AX25 = (++) "AF_AX25" - showsPrec _ AF_OSINET = (++) "AF_OSINET" - showsPrec _ AF_GOSSIP = (++) "AF_GOSSIP" - showsPrec _ AF_IPX = (++) "AF_IPX" - showsPrec _ Pseudo_AF_XTP = (++) "Pseudo_AF_XTP" - showsPrec _ AF_CTF = (++) "AF_CTF" - showsPrec _ AF_WAN = (++) "AF_WAN" - showsPrec _ AF_SDL = (++) "AF_SDL" - showsPrec _ AF_NETWARE = (++) "AF_NETWARE" - showsPrec _ AF_NDD = (++) "AF_NDD" - showsPrec _ AF_INTF = (++) "AF_INTF" - showsPrec _ AF_COIP = (++) "AF_COIP" - showsPrec _ AF_CNT = (++) "AF_CNT" - showsPrec _ Pseudo_AF_RTIP = (++) "Pseudo_AF_RTIP" - showsPrec _ Pseudo_AF_PIP = (++) "Pseudo_AF_PIP" - showsPrec _ AF_SIP = (++) "AF_SIP" - showsPrec _ AF_ISDN = (++) "AF_ISDN" - showsPrec _ Pseudo_AF_KEY = (++) "Pseudo_AF_KEY" - showsPrec _ AF_NATM = (++) "AF_NATM" - showsPrec _ AF_ARP = (++) "AF_ARP" - showsPrec _ Pseudo_AF_HDRCMPLT = (++) "Pseudo_AF_HDRCMPLT" - showsPrec _ AF_ENCAP = (++) "AF_ENCAP" - showsPrec _ AF_LINK = (++) "AF_LINK" - showsPrec _ AF_RAW = (++) "AF_RAW" - showsPrec _ AF_RIF = (++) "AF_RIF" - showsPrec _ AF_NETROM = (++) "AF_NETROM" - showsPrec _ AF_BRIDGE = (++) "AF_BRIDGE" - showsPrec _ AF_ATMPVC = (++) "AF_ATMPVC" - showsPrec _ AF_ROSE = (++) "AF_ROSE" - showsPrec _ AF_NETBEUI = (++) "AF_NETBEUI" - showsPrec _ AF_SECURITY = (++) "AF_SECURITY" - showsPrec _ AF_PACKET = (++) "AF_PACKET" - showsPrec _ AF_ASH = (++) "AF_ASH" - showsPrec _ AF_ECONET = (++) "AF_ECONET" - showsPrec _ AF_ATMSVC = (++) "AF_ATMSVC" - showsPrec _ AF_IRDA = (++) "AF_IRDA" - showsPrec _ AF_PPPOX = (++) "AF_PPPOX" - showsPrec _ AF_WANPIPE = (++) "AF_WANPIPE" - showsPrec _ AF_BLUETOOTH = (++) "AF_BLUETOOTH" - showsPrec _ AF_CAN = (++) "AF_CAN" - showsPrec d (GeneralFamily n) = - showParen (d > app_prec) $ - ("GeneralFamily " ++) . showsPrec (app_prec+1) n - --- | The 'Read' instance presently supports only 'AF_INET', 'AF_INET6', --- 'AF_UNIX', 'AF_UNSPEC' and 'GeneralFamily'. + show = forward familyBijection + instance Read Family where - readPrec = P.parens $ specific <++ general - where - specific = P.lexP >>= \case - P.Ident "AF_INET" -> return AF_INET - P.Ident "AF_INET6" -> return AF_INET6 - P.Ident "AF_UNIX" -> return AF_UNIX - P.Ident "AF_UNSPEC" -> return AF_UNSPEC - _ -> mzero - - general = P.prec app_prec $ do - P.lift $ P.expect $ P.Ident "GeneralFamily" - GeneralFamily <$> P.step safeInt + readPrec = tokenize $ backward familyBijection -- Print "n" instead of "PortNum n". instance Show PortNumber where diff --git a/Network/Socket/Win32/Cmsg.hsc b/Network/Socket/Win32/Cmsg.hsc index c2fe3804..8fd85d3b 100644 --- a/Network/Socket/Win32/Cmsg.hsc +++ b/Network/Socket/Win32/Cmsg.hsc @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -16,6 +17,9 @@ import System.IO.Unsafe (unsafeDupablePerformIO) import Network.Socket.Imports import Network.Socket.Types +import Network.Socket.ReadShow + +import qualified Text.Read as P type DWORD = Word32 type ULONG = Word32 @@ -32,7 +36,11 @@ data Cmsg = Cmsg { data CmsgId = CmsgId { cmsgLevel :: !CInt , cmsgType :: !CInt - } deriving (Eq, Show) + } deriving (Eq) + +-- | Unsupported identifier +pattern UnsupportedCmsgId :: CmsgId +pattern UnsupportedCmsgId = CmsgId (-1) (-1) -- | The identifier for 'IPv4TTL'. pattern CmsgIdIPv4TTL :: CmsgId @@ -178,3 +186,29 @@ instance Storable IPv6PktInfo where In6Addr ha6 <- (#peek IN6_PKTINFO, ipi6_addr) p n :: ULONG <- (#peek IN6_PKTINFO, ipi6_ifindex) p return $ IPv6PktInfo (fromIntegral n) ha6 + +cmsgIdPairs :: [Pair CmsgId String] +cmsgIdPairs = + [ (UnsupportedCmsgId, "UnsupportedCmsgId") + , (CmsgIdIPv4TTL, "CmsgIdIPv4TTL") + , (CmsgIdIPv6HopLimit, "CmsgIdIPv6HopLimit") + , (CmsgIdIPv4TOS, "CmsgIdIPv4TOS") + , (CmsgIdIPv6TClass, "CmsgIdIPv6TClass") + , (CmsgIdIPv4PktInfo, "CmsgIdIPv4PktInfo") + , (CmsgIdIPv6PktInfo, "CmsgIdIPv6PktInfo") + ] + +cmsgIdBijection :: Bijection CmsgId String +cmsgIdBijection = Bijection{..} + where + defname = "CmsgId" + unId = \(CmsgId l t) -> (l,t) + defFwd = defShow defname unId _show + defBwd = defRead defname (uncurry CmsgId) _parse + pairs = cmsgIdPairs + +instance Show CmsgId where + show = forward cmsgIdBijection + +instance Read CmsgId where + readPrec = tokenize $ backward cmsgIdBijection diff --git a/network.cabal b/network.cabal index bf681a37..5d3a7216 100644 --- a/network.cabal +++ b/network.cabal @@ -75,6 +75,7 @@ library Network.Socket.Info Network.Socket.Name Network.Socket.Options + Network.Socket.ReadShow Network.Socket.Shutdown Network.Socket.SockAddr Network.Socket.Syscall