rtnetlink 0.1.0.4 → 0.2.0.0
raw patch · 12 files changed
+1738/−441 lines, 12 filesdep +bits-bytestringdep +exceptionsdep +linux-namespacesdep −monad-loopsdep −mtldep ~basedep ~hspec
Dependencies added: bits-bytestring, exceptions, linux-namespaces
Dependencies removed: monad-loops, mtl
Dependency ranges changed: base, hspec
Files
- ChangeLog.md +27/−5
- examples/rtnl-address/Main.hs +41/−12
- examples/rtnl-link/Main.hs +164/−9
- rtnetlink.cabal +25/−20
- src/System/Linux/RTNetlink.hs +30/−16
- src/System/Linux/RTNetlink/Address.hsc +332/−57
- src/System/Linux/RTNetlink/Link.hsc +334/−75
- src/System/Linux/RTNetlink/Message.hsc +185/−85
- src/System/Linux/RTNetlink/Packet.hsc +132/−22
- src/System/Linux/RTNetlink/Util.hs +45/−0
- src/System/Socket/Family/Netlink.hsc +9/−2
- tests/Main.hs +414/−138
ChangeLog.md view
@@ -1,21 +1,43 @@ # Revision history for rtnetlink +## 0.2.0.0 -- 2019-07-04++* According to rtnetlink(7), `ifi_change` in `struct ifinfomsg` "is reserved+ for future use and should be always set to `0xFFFFFFFF`", so did that.+* Added a new typeclass, `Dump`, that encodes request-reply pairs that can be+ used with `dump`.+* Added `Integral` and `IsString` instances for appropriate `newtype`s.+* Added general `LinkType` for creating links, instead of creating a new type+ for each kind of link.+* Added several new types to `Address.hs`, including ones for interface scope,+ precedence, labels, lifetimes, and IPv6 features.+* Added several new types to `Link.hs`, including ones for bridge slaves, link+ groups, and link stats.+* Added support for creating and managing vlan interfaces.+* Removed redundancies in `Create`, `Destroy`, `Change`, and `Dump`+ typeclasses, as well as header classes. This should drastically improve the+ DRYness of adding features.+* Fixed a bug that prevented nested `struct nlattr`s from being parsed.+* Made many minor interface improvements.+ ## 0.1.0.4 -- 2017-03-28 -* Remove some obscure rtnetlink groups that aren't in `linux/rtnetlink.h` on Trusty.-* Add `stack.yaml`.+* Removed some obscure rtnetlink groups that aren't in `linux/rtnetlink.h` on+ Trusty.+* Added `stack.yaml`. ## 0.1.0.3 -- 2017-03-27 -* Provide support for `base-4.8.*` by fixing `IsString` ambiguity in `LinkEther`.+* Provided support for `base-4.8.*` by fixing `IsString` ambiguity in+ `LinkEther`. ## 0.1.0.2 -- 2017-03-26 -* Provide support for `transformers-0.4.*`.+* Provided support for `transformers-0.4.*`. ## 0.1.0.1 -- 2017-03-25 -* Provide support for `base-4.7.*`.+* Provided support for `base-4.7.*`. ## 0.1.0.0 -- 2017-03-24
examples/rtnl-address/Main.hs view
@@ -1,8 +1,10 @@ module Main where -import Data.List.Split (splitOneOf)+import Data.List (break)+import Data.List.Split (splitOneOf, splitOn) import System.Environment import System.Socket.Family.Inet (inetAddressFromTuple)+import System.Socket.Family.Inet6 (Inet6Address, inet6AddressFromTuple) import System.Linux.RTNetlink import System.Linux.RTNetlink.Address@@ -13,33 +15,60 @@ putStrLn $ "Usage: " ++ prog ++ " COMMAND\n" ++ "\n" ++ "COMMAND\n"- ++ "\t= create ipv4 <ipv4>/<mask> index <ifindex>\n"+ ++ "\t= dump DUMP\n"+ ++ "\t| create ipv4 <ipv4>/<mask> index <ifindex>\n" ++ "\t| destroy ipv4 <ipv4>/<mask> index <ifindex>\n"- ++ "\t| dump ipv4\n"- ++ "\t| dump ipv6\n"+ ++ "\n"+ ++ "DUMP\n"+ ++ "\t= ipv4 | ipv6\n"+ ++ "\n"+ ++ "ADDRESS\n"+ ++ "\t= ipv4 <ipv4>/<mask>\n"+ ++ "\t| ipv6 <u16>:<u16>:<u16>:<u16>:<u16>:<u16>:<u16>:<u16>/<mask>\n" main :: IO () main = do args <- getArgs err <- tryRTNL $ case args of++ "dump":"ipv4":[] -> do+ addresses <- dump AnyInterface+ liftIO $ mapM_ (putStrLn . show) (addresses::[IfInetAddress])++ "dump":"ipv6":[] -> do+ addresses <- dump AnyInterface+ liftIO $ mapM_ (putStrLn . show) (addresses::[IfInet6Address])+ "create":"ipv4":ipv4:"index":ix':[] -> do let ix = IfIndex $ read ix'- [a,b,c,d,m] = fmap read . splitOneOf "./" $ ipv4+ [a,b,c,d,m] = read <$> splitOneOf "./" ipv4 address = inetAddressFromTuple (a,b,c,d) prefix = IfPrefix m create $ IfInetAddress address prefix ix++ "create":"ipv6":ipv6':"index":ix':[] -> do+ let ix = IfIndex $ read ix'+ (ipv6,'/':m) = break (=='/') ipv6'+ [a,b,c,d,e,f,g,h] = read . ("0x"++) <$> splitOn ":" ipv6+ address = inet6AddressFromTuple (a,b,c,d,e,f,g,h)+ prefix = IfPrefix $ read m+ create $ IfInet6Address address prefix ix+ "destroy":"ipv4":ipv4:"index":ix':[] -> do let ix = IfIndex $ read ix'- [a,b,c,d,m] = fmap read . splitOneOf "./" $ ipv4+ [a,b,c,d,m] = read <$> splitOneOf ":/" ipv4 address = inetAddressFromTuple (a,b,c,d) prefix = IfPrefix m destroy $ IfInetAddress address prefix ix- "dump":"ipv4":[] -> do- addresses <- dump AnyInterface- liftIO $ mapM_ (putStrLn . show) (addresses::[IfInetAddress])- "dump":"ipv6":[] -> do- addresses <- dump AnyInterface- liftIO $ mapM_ (putStrLn . show) (addresses::[IfInet6Address])++ "destroy":"ipv6":ipv6':"index":ix':[] -> do+ let ix = IfIndex $ read ix'+ (ipv6,'/':m) = break (=='/') ipv6'+ [a,b,c,d,e,f,g,h] = read . ("0x"++) <$> splitOn ":" ipv6+ address = inet6AddressFromTuple (a,b,c,d,e,f,g,h)+ prefix = IfPrefix $ read m+ destroy $ IfInet6Address address prefix ix+ _ -> liftIO usage case err of Left s -> putStrLn $ "Error: " ++ s
examples/rtnl-link/Main.hs view
@@ -1,11 +1,25 @@ module Main where +import Data.List.Split (splitOn) import System.Environment import qualified Data.ByteString.Char8 as S import System.Linux.RTNetlink import System.Linux.RTNetlink.Link +type AllLinkInfo = (LinkIndex+ , (LinkName+ , (LinkEther+ , (LinkBroadcastEther+ , (Maybe LinkType+ , (Maybe VlanId+ , (LinkMaster+ , (LinkMTU+ , (LinkPromiscuity+ , (LinkArp+ , (LinkDebug+ )))))))))))+ usage :: IO () usage = do prog <- getProgName@@ -13,56 +27,197 @@ ++ "\n" ++ "COMMAND\n" ++ "\t= create CREATE\n"- ++ "\t| destroy (name <ifname> | index <ifindex>)\n"- ++ "\t| dump [(name <ifname> | index <ifindex>) state]\n"- ++ "\t| change (name <ifname> | index <ifindex>) (up | down)\n"+ ++ "\t| destroy ID\n"+ ++ "\t| dump [ID [DUMP]]\n"+ ++ "\t| change ID CHANGE\n" ++ "\n"+ ++ "ID\n"+ ++ "\t= name <ifname> | index <ifindex>\n"+ ++ "\n" ++ "CREATE\n"- ++ "\t= TYPE <ifname> BRIDGE_OPTS\n"+ ++ "\t= TYPE <ifname>\n" ++ "\n" ++ "TYPE\n"- ++ "\t= bridge\n"+ ++ "\t= bridge | dummy | vlan <idnumber>\n"+ ++ "\n"+ ++ "DUMP\n"+ ++ "\t= state | promiscuity | arp | debug | mtu\n"+ ++ "\n"+ ++ "CHANGE\n"+ ++ "\t= up | down\n"+ ++ "\t| promiscuous | chaste\n"+ ++ "\t| arp | noarp\n"+ ++ "\t| debug | nodebug\n"+ ++ "\t| ether <layer2address>\n"+ ++ "\t| mtu <integer>\n"+ ++ "\t| name <ifname>\n" main :: IO () main = do args <- getArgs err <- tryRTNL $ case args of+ "create":"bridge":name':[] -> do let name = LinkName $ S.pack name'- create $ Bridge name+ create $ (Bridge, name)+ "create":"dummy":name':[] -> do let name = LinkName $ S.pack name'- create $ Dummy name+ create $ (Dummy, name)++ "create":"vlan":ix':idnum':name':[] -> do+ let ix = LinkIndex $ read ix'+ name = LinkName $ S.pack name'+ idnum = VlanId $ read idnum'+ create $ (Dot1QVlan ix idnum, name)+ "destroy":"name":name':[] -> do let name = LinkName $ S.pack name' destroy name+ "destroy":"index":ix':[] -> do let ix = LinkIndex $ read ix' destroy ix+ "dump":[] -> do- names <- dump AnyLink- liftIO $ mapM_ (putStrLn . show) (names::[(LinkIndex,(LinkName,LinkEther))])+ links <- dump AnyLink+ liftIO $ mapM_ (putStrLn . show) (links::[AllLinkInfo])++ "dump":"index":ix':[] -> do+ let ix = LinkIndex $ read ix'+ states <- dump ix+ liftIO $ mapM_ (putStrLn . show) (states::[AllLinkInfo])++ "dump":"name":name':[] -> do+ let name = LinkName $ S.pack name'+ states <- dump name+ liftIO $ mapM_ (putStrLn . show) (states::[AllLinkInfo])+ "dump":"index":ix':"state":[] -> do let ix = LinkIndex $ read ix' states <- dump ix liftIO $ mapM_ (putStrLn . show) (states::[(LinkIndex,LinkState)])+ "dump":"name":name':"state":[] -> do let name = LinkName $ S.pack name' states <- dump name liftIO $ mapM_ (putStrLn . show) (states::[(LinkName,LinkState)])++ "dump":"index":ix':"promiscuity":[] -> do+ let ix = LinkIndex $ read ix'+ states <- dump ix+ liftIO $ mapM_ (putStrLn . show) (states::[(LinkIndex,LinkPromiscuity)])++ "dump":"name":name':"promiscuity":[] -> do+ let name = LinkName $ S.pack name'+ states <- dump name+ liftIO $ mapM_ (putStrLn . show) (states::[(LinkName,LinkPromiscuity)])++ "dump":"index":ix':"arp":[] -> do+ let ix = LinkIndex $ read ix'+ states <- dump ix+ liftIO $ mapM_ (putStrLn . show) (states::[(LinkIndex,LinkArp)])++ "dump":"name":name':"arp":[] -> do+ let name = LinkName $ S.pack name'+ states <- dump name+ liftIO $ mapM_ (putStrLn . show) (states::[(LinkName,LinkArp)])++ "dump":"index":ix':"mtu":[] -> do+ let ix = LinkIndex $ read ix'+ mtus <- dump ix+ liftIO $ mapM_ (putStrLn . show) (mtus::[(LinkIndex,LinkMTU)])++ "dump":"name":name':"mtu":[] -> do+ let name = LinkName $ S.pack name'+ mtus <- dump name+ liftIO $ mapM_ (putStrLn . show) (mtus::[(LinkName,LinkMTU)])+ "change":"name":name':"up":[] -> do let name = LinkName $ S.pack name' change name Up+ "change":"name":name':"down":[] -> do let name = LinkName $ S.pack name' change name Down+ "change":"index":ix':"up":[] -> do let ix = LinkIndex $ read ix' change ix Up+ "change":"index":ix':"down":[] -> do let ix = LinkIndex $ read ix' change ix Down++ "change":"name":name':"promiscuous":[] -> do+ let name = LinkName $ S.pack name'+ change name Promiscuous++ "change":"name":name':"chaste":[] -> do+ let name = LinkName $ S.pack name'+ change name Chaste++ "change":"index":ix':"promiscuous":[] -> do+ let ix = LinkIndex $ read ix'+ change ix Promiscuous++ "change":"index":ix':"chaste":[] -> do+ let ix = LinkIndex $ read ix'+ change ix Chaste++ "change":"name":name':"arp":[] -> do+ let name = LinkName $ S.pack name'+ change name Arp++ "change":"name":name':"noarp":[] -> do+ let name = LinkName $ S.pack name'+ change name NoArp++ "change":"index":ix':"arp":[] -> do+ let ix = LinkIndex $ read ix'+ change ix Arp++ "change":"index":ix':"noarp":[] -> do+ let ix = LinkIndex $ read ix'+ change ix NoArp++ "change":"name":name':"debug":[] -> do+ let name = LinkName $ S.pack name'+ change name Debug++ "change":"index":ix':"nodebug":[] -> do+ let ix = LinkIndex $ read ix'+ change ix NoDebug++ "change":"name":name':"mtu":mtu':[] -> do+ let name = LinkName $ S.pack name'+ mtu = LinkMTU $ read mtu'+ change name mtu++ "change":"index":ix':"mtu":mtu':[] -> do+ let ix = LinkIndex $ read ix'+ mtu = LinkMTU $ read mtu'+ change ix mtu++ "change":"name":name':"ether":eth':[] -> do+ let name = LinkName $ S.pack name'+ [a,b,c,d,e,f] = read . ("0x"++) <$> splitOn ":" eth'+ eth = LinkEther a b c d e f+ change name eth++ "change":"index":ix':"ether":eth':[] -> do+ let ix = LinkIndex $ read ix'+ [a,b,c,d,e,f] = read . ("0x"++) <$> splitOn ":" eth'+ eth = LinkEther a b c d e f+ change ix eth++ "change":"index":ix':"name":name':[] -> do+ let ix = LinkIndex $ read ix'+ name = LinkName $ S.pack name'+ change ix name+ _ -> liftIO usage+ case err of Left s -> putStrLn $ "Error: " ++ s Right () -> putStrLn $ "Success"
rtnetlink.cabal view
@@ -1,7 +1,7 @@ name: rtnetlink-version: 0.1.0.4+version: 0.2.0.0 synopsis: Manipulate network devices, addresses, and routes on Linux-description: A high-level, extensible, pure Haskell interface to the+description: A high-level, extensible, pure-Haskell interface to the ROUTE_NETLINK subsystem of netlink for manipulating network devices on Linux. @@ -19,7 +19,7 @@ build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10-homepage: https://gitlab.com/formaltech/rtnetlink-hs+homepage: https://github.com/protoben/rtnetlink.hs flag examples description: Build example programs@@ -31,17 +31,21 @@ hs-source-dirs: tests main-is: Main.hs build-depends:- base >=4.7 && <4.10,- hspec >=2.4 && <2.5,- socket >=0.8 && <0.9,- unix >=2.7 && <2.8,+ base >=4.7 && <5,+ bytestring >=0.10 && <0.11,+ exceptions >=0.8 && <0.11,+ hspec >=2.4 && <3,+ socket >=0.8 && <0.9,+ unix >=2.7 && <2.8,+ linux-namespaces >=0.1 && <0.2, rtnetlink executable rtnl-link if flag(examples) build-depends:- base >=4.7 && <4.10,+ base >=4.7 && <5, bytestring >=0.10 && <0.11,+ split >=0.2 && <0.3, rtnetlink else buildable: False@@ -51,7 +55,7 @@ executable rtnl-address if flag(examples) build-depends:- base >=4.7 && <4.10,+ base >=4.7 && <5, socket >=0.8 && <0.9, split >=0.2 && <0.3, rtnetlink@@ -69,6 +73,8 @@ System.Linux.RTNetlink.Packet, System.Socket.Family.Netlink, System.Socket.Protocol.RTNetlink+ other-modules:+ System.Linux.RTNetlink.Util other-extensions: CPP, FlexibleContexts,@@ -80,20 +86,19 @@ RecordWildCards, TypeFamilies build-depends:- base >=4.7 && <4.10,- bytestring >=0.10 && <0.11,- cereal >=0.5 && <0.6,- monad-loops >=0.4 && <0.5,- mtl >=2.2 && <2.3,- transformers >=0.4 && <0.6,- random >=1.1 && <1.2,- socket >=0.8 && <0.9,- unix >=2.7 && <2.8,- pretty-hex >=1.0 && <1.1+ base >=4.7 && <5,+ bits-bytestring >=0.1 && <0.2,+ bytestring >=0.10 && <0.11,+ cereal >=0.5 && <0.6,+ exceptions >=0.8 && <0.11,+ pretty-hex >=1.0 && <1.1,+ random >=1.1 && <1.2,+ socket >=0.8 && <0.9,+ transformers >=0.4 && <0.6,+ unix >=2.7 && <2.8 default-language: Haskell2010 hs-source-dirs: src build-tools: hsc2hs- default-language: Haskell2010 source-repository head type: git
src/System/Linux/RTNetlink.hs view
@@ -58,6 +58,7 @@ , create , destroy , dump+ , dump' , change , getBacklog , clearBacklog@@ -72,10 +73,11 @@ import Control.Applicative (Applicative(..), (<$>)) import Control.Monad (when, void)+import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import Control.Monad.Catch (throwM, try, handle, bracket) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Loops (unfoldM)-import Control.Monad.State (MonadState, StateT, evalStateT)-import Control.Monad.State (get, gets, put, modify, modify')+import Control.Monad.Trans.State.Strict (StateT, evalStateT)+import Control.Monad.Trans.State.Strict (get, gets, put, modify, modify') import Data.Monoid (mempty) import Data.Either (partitionEithers) import Data.List (partition)@@ -87,11 +89,11 @@ import System.Socket (socket, bind, send, receive, close) import System.Socket.Type.Raw (Raw) import System.Timeout (timeout)-import qualified Control.Exception as X import qualified Data.ByteString as S import System.Linux.RTNetlink.Message import System.Linux.RTNetlink.Packet+import System.Linux.RTNetlink.Util import System.Socket.Family.Netlink import System.Socket.Protocol.RTNetlink @@ -103,13 +105,20 @@ } -- | RTNL monad to simplify netlink communication.-newtype RTNL a = RTNL {unRTNL :: StateT Handle IO a}- deriving (Functor, Applicative, Monad, MonadIO, MonadState Handle)+newtype RTNL a = RTNL {unRTNL :: StateT Handle IO a} deriving+ ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadCatch+ , MonadThrow+ , MonadMask+ ) -- | Run an RTNL function and catch all @IOError@s. This means that functions -- in this module are guaranteed not to throw uncaught exceptions. tryRTNL :: RTNL a -> IO (Either String a)-tryRTNL = fmap (left (\e -> show (e::IOError))) . X.try . runRTNL+tryRTNL = fmap (left (\e -> show (e::IOError))) . try . runRTNL -- | Run an RTNL function. RTNL functions in this module throw exclusively -- @IOError@s.@@ -118,7 +127,7 @@ -- | Run an RTNL function and specify some groups to subscribe to. runRTNLGroups :: [RTNetlinkGroup] -> RTNL a -> IO a-runRTNLGroups gs r = X.bracket (rethrow "socket" socket) close $ \s -> do+runRTNLGroups gs r = bracket (rethrow "socket" socket) close $ \s -> do rethrow "bind" $ bind s =<< netlinkAddress gs h <- Handle s [] False <$> randomIO evalStateT (unRTNL r) h@@ -152,7 +161,7 @@ let (bss',rs) = partitionEithers $ fmap tryDecodeReply bss (_,es) = partitionEithers $ fmap tryDecodeReply bss' case filter (/=eOK) es of- e:_ -> liftIO . X.throwIO $ errnoToIOError "RTNETLINK answers" e Nothing Nothing+ e:_ -> throwM $ errnoToIOError "RTNETLINK answers" e Nothing Nothing _ -> return rs -- | Like 'talk', but discards non-error 'Reply's.@@ -168,9 +177,17 @@ destroy = talk_ . destroyNLMessage -- | Send a 'Request' and receive the associated 'Reply's.-dump :: (Request q, Reply r) => q -> RTNL [r]+dump :: Dump q r => q -> RTNL [r] dump = talk . requestNLMessage +-- | Link 'dump', but throws 'IOError' if the 'Reply' list does not have exactly+-- one element.+dump' :: Dump q r => q -> RTNL r+dump' q = dump q >>= \l -> case l of+ e:[] -> return e+ _:_ -> throwM $ userError "`dumpOne' returned non-unique"+ [] -> throwM $ userError "`dumpOne' returned empty"+ -- | Send a 'Change' message and ignore non-error 'Reply's. change :: Change id c => id -> c -> RTNL () change i c = talk_ $ changeNLMessage i c@@ -216,9 +233,6 @@ receiveAll s n f = unfoldM . timeout 500 . rethrow "receive" $ receive s n f -- | Re-throw a SocketException as an IOError.-rethrow :: String -> IO a -> IO a-rethrow name = X.handle $ \(SocketException n) ->- X.throwIO $ errnoToIOError name (Errno n) Nothing Nothing--left :: (a -> b) -> Either a c -> Either b c-left f = either (Left . f) Right+rethrow :: MonadCatch m => String -> m a -> m a+rethrow name = handle $ \(SocketException n) ->+ throwM $ errnoToIOError name (Errno n) Nothing Nothing
src/System/Linux/RTNetlink/Address.hsc view
@@ -9,8 +9,10 @@ Portability : Linux -} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -19,30 +21,54 @@ , IfInet6Address(..) , IfIndex(..) , IfPrefix(..)+ , IfScope(..)+ , IfLabel(..)+ , Precedence(..)+ , DuplicateAddressDetection(..)+ , DuplicateAddressDetectionFlags(..)+ , Mip6Homing(..)+ , Preference(..)+ , Permanence(..)+ , PrefixRoute(..)+ , MulticastAutoJoin(..)+ , IfSeconds(..)+ , IfLifetime(..) , AnyInterface(..) , IfAddrMsg(..) -- * Re-exports , InetAddress+ , inetAddressFromTuple+ , inetAddressToTuple , Inet6Address+ , inet6AddressFromTuple+ , inet6AddressToTuple ) where import Control.Applicative ((<$>), (<*>))-import Control.Monad (guard)-import Data.Monoid (mempty)+import Control.Exception (throw)+import Control.Monad (guard, when)+import Data.Bits ((.&.))+import Data.Maybe (fromMaybe)+import Data.Monoid (mempty, (<>)) import Data.Serialize (Serialize, Get, Putter, get, put, runPut) import Data.Serialize (getWord32host, putWord32host, getWord8) import Data.Serialize (putWord8, getWord16be, putWord16be)+import Data.String (IsString) import Data.Word (Word8, Word32) import System.Socket.Family.Inet (InetAddress, inetAddressToTuple) import System.Socket.Family.Inet (inetAddressFromTuple) import System.Socket.Family.Inet6 (Inet6Address, inet6AddressToTuple) import System.Socket.Family.Inet6 (inet6AddressFromTuple)+import qualified Data.ByteString.Char8 as S+import qualified Foreign.C.Error as C import System.Linux.RTNetlink.Message import System.Linux.RTNetlink.Packet+import System.Linux.RTNetlink.Util #include <linux/if_addr.h> #include <linux/rtnetlink.h>+#include <net/if.h> #include <netinet/in.h> -- | Construct a network-byte-order representation of an 'InetAddress'.@@ -63,13 +89,9 @@ ] where ipv4 = runPut $ putInetAddress address instance Reply InetAddress where type ReplyHeader InetAddress = IfAddrMsg- replyTypeNumbers _ = [#{const RTM_NEWADDR}] fromNLMessage NLMessage {..} = do- let IfAddrMsg {..} = nlmHeader- guard $ addrFamily == #{const AF_INET}- attr <- findAttribute [#{const RTA_DST}] nlmAttrs- bs <- attributeData attr- runGetMaybe getInetAddress bs+ guard $ (addrFamily nlmHeader) == #{const AF_INET}+ findAttributeGet getInetAddress [#{const RTA_DST}] nlmAttrs -- | Construct a network-byte-order representation of an 'InetAddress'. putInet6Address :: Putter Inet6Address@@ -98,13 +120,9 @@ ] where ipv6 = runPut $ putInet6Address address instance Reply Inet6Address where type ReplyHeader Inet6Address = IfAddrMsg- replyTypeNumbers _ = [#{const RTM_NEWADDR}] fromNLMessage NLMessage {..} = do- let IfAddrMsg {..} = nlmHeader- guard $ addrFamily == #{const AF_INET6}- attr <- findAttribute [#{const RTA_DST}] nlmAttrs- bs <- attributeData attr- runGetMaybe getInet6Address bs+ guard $ (addrFamily nlmHeader) == #{const AF_INET6}+ findAttributeGet getInet6Address [#{const RTA_DST}] nlmAttrs -- | Interface wildcard. Use this to get information about all layer-3 -- interfaces.@@ -114,31 +132,271 @@ type MessageHeader AnyInterface = IfAddrMsg messageAttrs AnyInterface = mempty instance Request AnyInterface where- requestTypeNumber = const #{const RTM_GETADDR}- requestNLFlags = const dumpNLFlags+ requestNLFlags = dumpMany -- | The index of a layer-3 interface. newtype IfIndex = IfIndex {ifIndex :: Int}- deriving (Show, Eq, Num, Ord)+ deriving (Show, Eq, Num, Ord, Real, Enum, Integral) instance Message IfIndex where- type MessageHeader IfIndex = IfAddrMsg- messageHeader (IfIndex ix) = IfAddrMsg 0 0 0 0 (fromIntegral ix)+ type MessageHeader IfIndex = IfAddrMsg+ messageHeaderParts (IfIndex ix) = [IfAddrMsgIndex $ fromIntegral ix] instance Reply IfIndex where type ReplyHeader IfIndex = IfAddrMsg- replyTypeNumbers _ = [#{const RTM_NEWADDR}]- fromNLMessage = Just . IfIndex . fromIntegral . addrIndex . nlmHeader+ fromNLMessage = Just . IfIndex . fromIntegral . addrIndex . nlmHeader -- | A netmask in CIDR notation.-newtype IfPrefix = IfPrefix {ifPrefix :: Word8}- deriving (Show, Eq, Num, Ord)+newtype IfPrefix = IfPrefix Word8+ deriving (Show, Eq, Num, Ord, Real, Enum, Integral) instance Message IfPrefix where- type MessageHeader IfPrefix = IfAddrMsg- messageHeader (IfPrefix p) = IfAddrMsg 0 p 0 0 0+ type MessageHeader IfPrefix = IfAddrMsg+ messageHeaderParts (IfPrefix p) = [IfAddrMsgPrefix p] instance Reply IfPrefix where type ReplyHeader IfPrefix = IfAddrMsg- replyTypeNumbers _ = [#{const RTM_NEWADDR}]- fromNLMessage = Just . IfPrefix . addrPrefix . nlmHeader+ fromNLMessage = Just . fromIntegral . addrPrefix . nlmHeader +-- | Precedence for address on its link. The first address created on a subnet+-- is 'Primary', and each subsequent one is 'Secondary'. (This is similar to an+-- "alias" address in @ifconfig@.) By default, linux has the (maybe+-- counterintuitive) behavior that, when the primary address on a subnet is+-- deleted, all secondary interfaces are deleted as well. To change this+-- behavior, you can set @net.ipv{4|6}.conf.<dev>.promote_secondaries = 1@ in+-- @sysctl@.+data Precedence = Primary | Secondary+ deriving (Show, Eq)+instance Reply Precedence where+ type ReplyHeader Precedence = IfAddrMsg+ fromNLMessage m = Just $+ if (addrFlags . nlmHeader) m .&. #{const IFA_F_SECONDARY} == 0+ then Primary+ else Secondary++-- | Whether this IPv6 address should send duplicate address detection packets+-- (see RFC2462). Default is 'DadEnabled'. This flag only makes sense for IPv6+-- addresses, but the kernel is perfectly happy to let you set it on IPv4 ones,+-- with no effect.+data DuplicateAddressDetection = DadEnabled | DadDisabled+ deriving (Show, Eq)+instance Reply DuplicateAddressDetection where+ type ReplyHeader DuplicateAddressDetection = IfAddrMsg+ fromNLMessage m = Just $+ if (addrFlags . nlmHeader) m .&. #{const IFA_F_NODAD} == 0+ then DadEnabled+ else DadDisabled+instance Message DuplicateAddressDetection where+ type MessageHeader DuplicateAddressDetection = IfAddrMsg+ messageHeaderParts d =+ [ IfAddrMsgFlags $ ChangeFlags+ { cfFlags = if d == DadEnabled then 0 else #{const IFA_F_NODAD}+ , cfMask = #{const IFA_F_NODAD}+ }+ ]+ messageAttrs d = AttributeList [ word32AttrPart #{const IFA_FLAGS} f m ]+ where+ f = if d == DadEnabled then 0 else #{const IFA_F_NODAD}+ m = #{const IFA_F_NODAD}+instance (Create c, MessageHeader c ~ IfAddrMsg)+ => Create (c, DuplicateAddressDetection)+instance (Create c, MessageHeader c ~ IfAddrMsg)+ => Create (DuplicateAddressDetection, c)++-- | Flags for IPv6 duplicate address detection. See RFC4862.+data DuplicateAddressDetectionFlags = DuplicateAddressDetectionFlags+ { dadOptimistic :: Bool+ -- ^ Whether to use this address for neighbor dicovery and receiving frames+ -- when it is in a tentative state (i.e., DAD has not yet succeeded). It is+ -- dis-preferred for source address selection, like a deprecated address.+ -- See RFC4429.+ , dadTentative :: Bool+ -- ^ Indicates that DAD has not yet succeeded. This address will not be used+ -- for neighbor discovery unless 'dadOptimistic' is also set.+ , dadFailed :: Bool+ -- ^ Indicates that duplicate address detection failed on this address.+ } deriving (Show, Eq)+instance Reply DuplicateAddressDetectionFlags where+ type ReplyHeader DuplicateAddressDetectionFlags = IfAddrMsg+ fromNLMessage m = Just $ DuplicateAddressDetectionFlags+ { dadOptimistic = flags .&. #{const IFA_F_OPTIMISTIC} /= 0+ , dadTentative = flags .&. #{const IFA_F_TENTATIVE} /= 0+ , dadFailed = flags .&. #{const IFA_F_DADFAILED} /= 0+ } where flags = addrFlags $ nlmHeader m++-- | Home address for IPv6. Used in Mobility for IPv6 (MIP6), which allows a+-- device to use its home address on mobile networks. See RFC6275.+data Mip6Homing = Home | NotHome deriving (Show, Eq)+instance Reply Mip6Homing where+ type ReplyHeader Mip6Homing = IfAddrMsg+ fromNLMessage m = Just $+ if (addrFlags . nlmHeader) m .&. #{const IFA_F_HOMEADDRESS} == 0+ then Home+ else NotHome+instance Message Mip6Homing where+ type MessageHeader Mip6Homing = IfAddrMsg+ messageHeaderParts h =+ [ IfAddrMsgFlags $ ChangeFlags+ { cfFlags = if h == NotHome then 0 else #{const IFA_F_HOMEADDRESS}+ , cfMask = #{const IFA_F_HOMEADDRESS}+ }+ ]+ messageAttrs h = AttributeList [ word32AttrPart #{const IFA_FLAGS} f m ]+ where+ f = if h == Home then #{const IFA_F_HOMEADDRESS} else 0+ m = #{const IFA_F_HOMEADDRESS}++-- | Indicates an address that is past its preferred lifetime. A deprecated+-- address will be dis-preferred for source address selection.+data Preference = Prefered | Deprecated deriving (Show, Eq)+instance Reply Preference where+ type ReplyHeader Preference = IfAddrMsg+ fromNLMessage m = Just $+ if (addrFlags . nlmHeader) m .&. #{const IFA_F_DEPRECATED} == 0+ then Prefered+ else Deprecated++-- | A 'Permanent' IPv6 address is one that was explicitly created. A 'Dynamic'+-- address is one that was auto-generated, e.g. by SLAAC.+data Permanence = Permanent | Dynamic deriving (Show, Eq)+instance Reply Permanence where+ type ReplyHeader Permanence = IfAddrMsg+ fromNLMessage m = Just $+ if (addrFlags . nlmHeader) m .&. #{const IFA_F_PERMANENT} == 0+ then Dynamic+ else Permanent++-- | Whether to automatically add a route based on the prefix when the address+-- is added.+data PrefixRoute = PREnabled | PRDisabled+ deriving (Show, Eq)+instance Reply PrefixRoute where+ type ReplyHeader PrefixRoute = IfAddrMsg+ fromNLMessage m = Just . fromMaybe PREnabled $ do+ f <- findAttributeGet getWord32host [#{const IFA_FLAGS}] $ nlmAttrs m+ return $ if f .&. #{const IFA_F_NOPREFIXROUTE} == (0::Word32)+ then PREnabled+ else PRDisabled+instance Message PrefixRoute where+ type MessageHeader PrefixRoute = IfAddrMsg+ messageAttrs h = AttributeList [ word32AttrPart #{const IFA_FLAGS} f m ]+ where+ f = if h == PREnabled then 0 else #{const IFA_F_NOPREFIXROUTE}+ m = #{const IFA_F_NOPREFIXROUTE}+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, PrefixRoute)+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (PrefixRoute, c)++-- | Enable joining multicast groups when connected to a switch that does IGMP+-- snooping. Only sensible on multicast addresses.+data MulticastAutoJoin = AutoJoin | NoAutoJoin+ deriving (Show, Eq)+instance Reply MulticastAutoJoin where+ type ReplyHeader MulticastAutoJoin = IfAddrMsg+ fromNLMessage m = Just . fromMaybe NoAutoJoin $ do+ f <- findAttributeGet getWord32host [#{const IFA_FLAGS}] $ nlmAttrs m+ return $ if f .&. #{const IFA_F_MCAUTOJOIN} == (0::Word32)+ then NoAutoJoin+ else AutoJoin+instance Message MulticastAutoJoin where+ type MessageHeader MulticastAutoJoin = IfAddrMsg+ messageAttrs h = AttributeList [ word32AttrPart #{const IFA_FLAGS} f m ]+ where+ f = if h == NoAutoJoin then 0 else #{const IFA_F_MCAUTOJOIN}+ m = #{const IFA_F_MCAUTOJOIN}++data IfSeconds = IfSeconds Word32 | IfForever deriving (Show, Eq)+instance Ord IfSeconds where+ IfSeconds s `compare` IfSeconds t = s `compare` t+ IfForever `compare` _ = GT+ _ `compare` IfForever = LT+instance Serialize IfSeconds where+ put (IfSeconds s) = putWord32host s+ put IfForever = putWord32host oneBits+ get = getWord32host >>= \s ->+ return $ if s == oneBits then IfForever else IfSeconds s++-- | The lifetime of this address. The address will be in a 'Prefered' state for+-- 'ifPrefered' seconds, after which it will be 'Deprecated'. After 'ifValid'+-- seconds, the address will be removed. +data IfLifetime = IfLifetime+ { ifPrefered :: IfSeconds+ , ifValid :: IfSeconds+ } deriving (Show, Eq)+instance Reply IfLifetime where+ type ReplyHeader IfLifetime = IfAddrMsg+ fromNLMessage = Just . fromMaybe (IfLifetime IfForever IfForever)+ . findAttributeGet getLifetime [#{const IFA_CACHEINFO}] . nlmAttrs+ where+ secsFromWord32 s = if s == oneBits then IfForever else IfSeconds s+ getLifetime = IfLifetime+ <$> get -- lft_prefered+ <*> get -- lft_valid+ <* getWord32host -- cstamp+ <* getWord32host -- tstamp+instance Message IfLifetime where+ type MessageHeader IfLifetime = IfAddrMsg+ messageAttrs l = AttributeList [Attribute #{const IFA_CACHEINFO} cacheinfo]+ where+ cacheinfo = runPut $ do+ when (ifPrefered l > ifValid l) . throw $+ userError "prefered lifetime must not be greater than valid lifetime"+ put $ ifPrefered l -- lft_prefered+ put $ ifValid l -- lft_valid+ putWord32host 0 -- cstamp+ putWord32host 0 -- tstamp+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, IfLifetime)+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (IfLifetime, c)++-- According to @rtnetlink.h@, not so much a scope as a distance to the+-- destination. 'IfUniverse' is for address that talk to the world at large,+-- 'IfLink addresses talk to physically connected addresses, etc. 'IfSite'+-- is only for IPv6 addresses and deprecated, according to @ip-address(8)@,+-- but the kernel is happy to let you set it on IPv4 addresses.+--+-- Note that scope is determined automatically for IPv6 addresses, so the+-- kernel will ignore any scope you attach to a newly created address.+data IfScope+ = IfUniverse -- ^ Destination located anywhere (default).+ | IfUserScope Word8 -- ^ User-defined scope; 0, 200, and 253-5 are reserved.+ | IfSite -- ^ IPv6 address valid inside this site. Deprecated.+ | IfLink -- ^ Destination on attached link.+ | IfHost -- ^ Local address.+ | IfNowhere -- ^ Destination doesn't exist.+ deriving (Show, Eq)+instance Reply IfScope where+ type ReplyHeader IfScope = IfAddrMsg+ fromNLMessage = Just . toScope . addrScope . nlmHeader+ where+ toScope #{const RT_SCOPE_UNIVERSE} = IfUniverse+ toScope #{const RT_SCOPE_SITE} = IfSite+ toScope #{const RT_SCOPE_LINK} = IfLink+ toScope #{const RT_SCOPE_HOST} = IfHost+ toScope #{const RT_SCOPE_NOWHERE} = IfNowhere+ toScope n = IfUserScope n+instance Message IfScope where+ type MessageHeader IfScope = IfAddrMsg+ messageHeaderParts = (:[]) . IfAddrMsgScope . fromScope+ where+ fromScope IfUniverse = #{const RT_SCOPE_UNIVERSE}+ fromScope (IfUserScope n) = n+ fromScope IfSite = #{const RT_SCOPE_SITE}+ fromScope IfLink = #{const RT_SCOPE_LINK}+ fromScope IfHost = #{const RT_SCOPE_HOST}+ fromScope IfNowhere = #{const RT_SCOPE_NOWHERE}+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, IfScope)+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (IfScope, c)++-- | A textual label applied to an IPv4 address. Defaults to the 'LinkName' of+-- the parent link. Note that this is ignored/absent for IPv6 addresses.+newtype IfLabel = IfLabel S.ByteString+ deriving (Show, Eq, IsString)+instance Reply IfLabel where+ type ReplyHeader IfLabel = IfAddrMsg+ fromNLMessage NLMessage {..} = IfLabel+ <$> findAttributeCString [#{const IFA_LABEL}] nlmAttrs+instance Message IfLabel where+ type MessageHeader IfLabel = IfAddrMsg+ messageAttrs (IfLabel bs) = AttributeList+ [ cStringAttr #{const IFA_LABEL} $ S.take #{const IFNAMSIZ} bs ]+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (c, IfLabel)+instance (Create c, MessageHeader c ~ IfAddrMsg) => Create (IfLabel, c)+ -- | An ipv4 address and netmask associated with an interface. data IfInetAddress = IfInetAddress { ifInetAddress :: InetAddress -- ^ The ip4v address itself.@@ -146,23 +404,19 @@ , ifInetIfIndex :: IfIndex -- ^ Index of the associated interface. } deriving (Show, Eq) instance Message IfInetAddress where- type MessageHeader IfInetAddress = IfAddrMsg- messageAttrs IfInetAddress {..} = messageAttrs ifInetAddress- messageHeader IfInetAddress {..} = IfAddrMsg- { addrFamily = #{const AF_INET}- , addrPrefix = ifPrefix ifInetPrefix- , addrFlags = 0- , addrScope = 0- , addrIndex = fromIntegral $ ifIndex ifInetIfIndex- }-instance Create IfInetAddress where- createTypeNumber = const #{const RTM_NEWADDR}-instance Destroy IfInetAddress where- destroyTypeNumber = const #{const RTM_DELADDR}+ type MessageHeader IfInetAddress = IfAddrMsg+ messageAttrs IfInetAddress {..} = messageAttrs ifInetAddress+ messageHeaderParts IfInetAddress {..} =+ [ IfAddrMsgFamily #{const AF_INET}+ , IfAddrMsgPrefix $ fromIntegral ifInetPrefix+ , IfAddrMsgIndex . fromIntegral $ ifIndex ifInetIfIndex+ ]+instance Create IfInetAddress+instance Destroy IfInetAddress instance Reply IfInetAddress where type ReplyHeader IfInetAddress = IfAddrMsg- replyTypeNumbers _ = [#{const RTM_NEWADDR}]- fromNLMessage m =+ fromNLMessage m = do+ guard $ (addrFamily . nlmHeader) m == #{const AF_INET} IfInetAddress <$> fromNLMessage m <*> fromNLMessage m <*> fromNLMessage m -- | An ipv6 address and netmask associated with an interface.@@ -172,23 +426,19 @@ , ifInet6IfIndex :: IfIndex -- ^ Index of the associated interface. } deriving (Show, Eq) instance Message IfInet6Address where- type MessageHeader IfInet6Address = IfAddrMsg- messageAttrs IfInet6Address {..} = messageAttrs ifInet6Address- messageHeader IfInet6Address {..} = IfAddrMsg- { addrFamily = #{const AF_INET6}- , addrPrefix = ifPrefix ifInet6Prefix- , addrFlags = 0- , addrScope = 0- , addrIndex = fromIntegral $ ifIndex ifInet6IfIndex- }-instance Create IfInet6Address where- createTypeNumber = const #{const RTM_NEWADDR}-instance Destroy IfInet6Address where- destroyTypeNumber = const #{const RTM_DELADDR}+ type MessageHeader IfInet6Address = IfAddrMsg+ messageAttrs IfInet6Address {..} = messageAttrs ifInet6Address+ messageHeaderParts IfInet6Address {..} =+ [ IfAddrMsgFamily #{const AF_INET6}+ , IfAddrMsgPrefix $ fromIntegral ifInet6Prefix+ , IfAddrMsgIndex . fromIntegral $ ifIndex ifInet6IfIndex+ ]+instance Create IfInet6Address+instance Destroy IfInet6Address instance Reply IfInet6Address where type ReplyHeader IfInet6Address = IfAddrMsg- replyTypeNumbers _ = [#{const RTM_NEWADDR}]- fromNLMessage m =+ fromNLMessage m = do+ guard $ (addrFamily . nlmHeader) m == #{const AF_INET6} IfInet6Address <$> fromNLMessage m <*> fromNLMessage m <*> fromNLMessage m -- | The header corresponding to address messages, based on 'struct ifaddrmsg'@@ -216,4 +466,29 @@ <*> getWord8 <*> getWord32host instance Header IfAddrMsg where+ type HeaderPart IfAddrMsg = IfAddrMsgPart+ fromHeaderParts = toHeader . foldr modify (0,0,mempty,0,0)+ where+ toHeader (a,b,c,d,e) = IfAddrMsg a b (cfFlags c) d e+ modify (IfAddrMsgFamily a) (_,b,c,d,e) = (a, b, c, d, e)+ modify (IfAddrMsgPrefix b) (a,_,c,d,e) = (a, b, c, d, e)+ modify (IfAddrMsgFlags f) (a,b,c,d,e) = (a, b, f<>c, d, e)+ modify (IfAddrMsgScope d) (a,b,c,_,e) = (a, b, c, d, e)+ modify (IfAddrMsgIndex e) (a,b,c,d,_) = (a, b, c, d, e) emptyHeader = IfAddrMsg 0 0 0 0 0+instance CreateMessageHeader IfAddrMsg where+ createTypeNumber = const #{const RTM_NEWADDR}+instance DestroyMessageHeader IfAddrMsg where+ destroyTypeNumber = const #{const RTM_DELADDR}+instance RequestMessageHeader IfAddrMsg where+ requestTypeNumber = const #{const RTM_GETADDR}+instance ReplyMessageHeader IfAddrMsg where+ replyTypeNumbers = const [#{const RTM_NEWADDR}]++data IfAddrMsgPart+ = IfAddrMsgFamily Word8+ | IfAddrMsgPrefix Word8+ | IfAddrMsgFlags (ChangeFlags Word8)+ | IfAddrMsgScope Word8+ | IfAddrMsgIndex Word32+ deriving (Show, Eq)
src/System/Linux/RTNetlink/Link.hsc view
@@ -9,6 +9,7 @@ Portability : Linux -} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -17,141 +18,377 @@ {-# LANGUAGE TypeFamilies #-} module System.Linux.RTNetlink.Link where -import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>), (<*>), (<|>))+import Control.Monad (guard) import Data.Bits ((.&.)) import Data.Int (Int32)+import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Serialize-import Data.Word (Word8, Word32)+import Data.String (IsString)+import Data.Word (Word8, Word16, Word32, Word64) import qualified Data.ByteString as S -import System.Linux.RTNetlink.Packet import System.Linux.RTNetlink.Message+import System.Linux.RTNetlink.Packet+import System.Linux.RTNetlink.Util +#include <linux/if_ether.h> #include <linux/if_link.h> #include <linux/rtnetlink.h> #include <net/if.h> -- | A link identified by its index. newtype LinkIndex = LinkIndex Int- deriving (Show, Eq, Num, Ord)+ deriving (Show, Eq, Num, Ord, Enum, Real, Integral)+instance Serialize LinkIndex where+ put ix = putWord32host $ fromIntegral ix+ get = fromIntegral <$> getWord32host instance Message LinkIndex where- type MessageHeader LinkIndex = IfInfoMsg- messageHeader (LinkIndex ix) = IfInfoMsg (fromIntegral ix) 0 0-instance Destroy LinkIndex where- destroyTypeNumber = const #{const RTM_DELLINK}+ type MessageHeader LinkIndex = IfInfoMsg+ messageHeaderParts (LinkIndex ix) = [IfInfoMsgIndex (fromIntegral ix)]+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkIndex)+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkIndex,c)+instance Destroy LinkIndex instance Request LinkIndex where- requestTypeNumber = const #{const RTM_GETLINK}+ requestNLFlags = dumpOne instance Reply LinkIndex where type ReplyHeader LinkIndex = IfInfoMsg- replyTypeNumbers = const [#{const RTM_NEWLINK}]- fromNLMessage = Just . LinkIndex . fromIntegral . ifIndex . nlmHeader+ fromNLMessage = Just . LinkIndex . fromIntegral . ifIndex . nlmHeader -- | A link identified by its name. newtype LinkName = LinkName S.ByteString- deriving (Show, Eq)+ deriving (Show, Eq, IsString) instance Message LinkName where type MessageHeader LinkName = IfInfoMsg messageAttrs (LinkName bs) = AttributeList- [cStringAttr #{const IFLA_IFNAME} $ S.take #{const IFNAMSIZ} bs]-instance Destroy LinkName where- destroyTypeNumber = const #{const RTM_DELLINK}+ [ cStringAttr #{const IFLA_IFNAME} $ S.take #{const IFNAMSIZ} bs ]+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkName)+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkName,c)+instance Change LinkIndex LinkName where+ changeAttrs n m = messageAttrs n <> messageAttrs m+instance Destroy LinkName instance Request LinkName where- requestTypeNumber = const #{const RTM_GETLINK}+ requestNLFlags = dumpOne instance Reply LinkName where type ReplyHeader LinkName = IfInfoMsg- replyTypeNumbers = const [#{const RTM_NEWLINK}]- fromNLMessage m = do- a <- findAttribute [#{const IFLA_IFNAME}] . nlmAttrs $ m- n <- S.takeWhile (/=0) <$> attributeData a- return $ LinkName n+ fromNLMessage NLMessage {..} =+ LinkName <$> findAttributeCString [#{const IFLA_IFNAME}] nlmAttrs -- | An ethernet address. data LinkEther = LinkEther Word8 Word8 Word8 Word8 Word8 Word8 deriving Eq instance Show LinkEther where- show (LinkEther a b c d e f) = hex a <:> hex b <:> hex c <:> hex d <:> hex e <:> hex f- where- hex w = hexdig (w `div` 0x10) : hexdig (w `rem` 0x10) : []- hexdig = (!!) "0123456789abcdef" . fromIntegral- s <:> t = s ++ ":" ++ t :: String+ show (LinkEther a b c d e f) = showMac a b c d e f instance Serialize LinkEther where- put (LinkEther a b c d e f) = put a >> put b >> put c >> put d >> put e >> put f+ put (LinkEther a b c d e f) = mapM_ put [a,b,c,d,e,f] get = LinkEther <$> get <*> get <*> get <*> get <*> get <*> get instance Message LinkEther where type MessageHeader LinkEther = IfInfoMsg- messageAttrs e = AttributeList [Attribute #{const IFLA_ADDRESS} $ encode e]+ messageAttrs e = AttributeList [Attribute #{const IFLA_ADDRESS} $ encode e]+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkEther)+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkEther,c)+instance Change LinkName LinkEther where+ changeAttrs n m = messageAttrs n <> messageAttrs m+instance Change LinkIndex LinkEther where+ changeAttrs n m = messageAttrs m instance Reply LinkEther where type ReplyHeader LinkEther = IfInfoMsg- replyTypeNumbers = const [#{const RTM_NEWLINK}]- fromNLMessage m = do- a <- findAttribute [#{const IFLA_ADDRESS}] . nlmAttrs $ m- d <- attributeData a- decodeMaybe d+ fromNLMessage m = findAttributeDecode [#{const IFLA_ADDRESS}] $ nlmAttrs m +-- | An ethernet broadcast address.+data LinkBroadcastEther = LinkBroadcastEther Word8 Word8 Word8 Word8 Word8 Word8+ deriving Eq+instance Show LinkBroadcastEther where+ show (LinkBroadcastEther a b c d e f) = showMac a b c d e f+instance Serialize LinkBroadcastEther where+ put (LinkBroadcastEther a b c d e f) = mapM_ put [a,b,c,d,e,f]+ get = LinkBroadcastEther <$> get <*> get <*> get <*> get <*> get <*> get+instance Message LinkBroadcastEther where+ type MessageHeader LinkBroadcastEther = IfInfoMsg+ messageAttrs e = AttributeList [Attribute #{const IFLA_BROADCAST} $ encode e]+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkBroadcastEther)+instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkBroadcastEther,c)+instance Change LinkName LinkBroadcastEther where+ changeAttrs n m = messageAttrs n <> messageAttrs m+instance Change LinkIndex LinkBroadcastEther where+ changeAttrs n m = messageAttrs m+instance Reply LinkBroadcastEther where+ type ReplyHeader LinkBroadcastEther = IfInfoMsg+ fromNLMessage m = findAttributeDecode [#{const IFLA_BROADCAST}] $ nlmAttrs m+ -- | Link wildcard. data AnyLink = AnyLink deriving (Show, Eq) instance Message AnyLink where type MessageHeader AnyLink = IfInfoMsg instance Request AnyLink where- requestTypeNumber = const #{const RTM_GETLINK}- requestNLFlags = const dumpNLFlags+ requestNLFlags = dumpMany --- | A dummy interface.-newtype Dummy = Dummy LinkName+-- | The type of a link.+data LinkType+ = Dummy -- ^ A dummy interface.+ | Bridge -- ^ A bridge interface.+ | Dot1QVlan LinkIndex VlanId -- ^ An 802.1Q vlan interface.+ | Dot1adVlan LinkIndex VlanId -- ^ An 802.1ad vlan interface.+ | NamedLinkType S.ByteString -- ^ Specify the link type name as a string. deriving (Show, Eq)-instance Message Dummy where- type MessageHeader Dummy = IfInfoMsg- messageHeader (Dummy name) = messageHeader name- messageAttrs (Dummy name) = messageAttrs name <> AttributeList+instance Message LinkType where+ type MessageHeader LinkType = IfInfoMsg+ messageAttrs t = case t of+ Dummy -> setTypeName "dummy"+ Bridge -> setTypeName "bridge"+ NamedLinkType n -> setTypeName n+ Dot1QVlan ix vid -> messageAttrs vid+ <> setVlanProto #{const ETH_P_8021Q}+ <> setTypeName "vlan"+ <> setVlanLink ix+ Dot1adVlan ix vid -> messageAttrs vid + <> setVlanProto #{const ETH_P_8021AD}+ <> setTypeName "vlan"+ <> setVlanLink ix+ where+ setTypeName n = AttributeList+ [ AttributeNest #{const IFLA_LINKINFO}+ [ cStringAttr #{const IFLA_INFO_KIND} n ]+ ]+ setVlanProto p = AttributeList+ [ AttributeNest #{const IFLA_LINKINFO}+ [ AttributeNest #{const IFLA_INFO_DATA}+ -- Weirdly, the kernel seems to want the vlan proto in BE.+ [ word16Attr #{const IFLA_VLAN_PROTOCOL} (byteSwap16 p) ]+ ]+ ]+ setVlanLink ix = AttributeList+ [ word32Attr #{const IFLA_LINK} (fromIntegral ix) ]+instance Create LinkType+instance Request LinkType where+ requestNLFlags = dumpMany+instance Reply LinkType where+ type ReplyHeader LinkType = IfInfoMsg+ fromNLMessage m@(NLMessage {..}) = do+ info <- findAttributeDecode [#{const IFLA_LINKINFO}] nlmAttrs+ typ <- findAttributeCString [#{const IFLA_INFO_KIND}] info+ handleTypeName info typ+ where+ handleTypeName info t = case t of+ "dummy" -> return Dummy+ "bridge" -> return Bridge+ "vlan" -> handleVlan info+ _ -> return $ NamedLinkType t+ handleVlan info = do+ idata <- findAttributeDecode [#{const IFLA_INFO_DATA}] info+ proto <- findAttributeDecode [#{const IFLA_VLAN_PROTOCOL}] idata+ case (proto::Word16) of+ (#{const ETH_P_8021Q}) -> Dot1QVlan+ <$> getVlanLink <*> fromNLMessage m+ (#{const ETH_P_8021AD}) -> Dot1adVlan+ <$> getVlanLink <*> fromNLMessage m+ _ -> return $ NamedLinkType "vlan"+ getVlanLink = findAttributeDecode [#{const IFLA_LINK}] nlmAttrs++-- | Tag id for a vlan interface.+newtype VlanId = VlanId Word16+ deriving (Show, Eq, Num, Ord, Real, Enum, Integral)+instance Message VlanId where+ type MessageHeader VlanId = IfInfoMsg+ messageAttrs (VlanId vid) = AttributeList [ AttributeNest #{const IFLA_LINKINFO}- [ cStringAttr #{const IFLA_INFO_KIND} "dummy" ]+ [ AttributeNest #{const IFLA_INFO_DATA}+ [ word16Attr #{const IFLA_VLAN_ID} vid ]+ ] ]-instance Create Dummy where- createTypeNumber = const #{const RTM_NEWLINK}+instance Reply VlanId where+ type ReplyHeader VlanId = IfInfoMsg+ fromNLMessage NLMessage {..} = do+ info <- findAttributeDecode [#{const IFLA_LINKINFO}] nlmAttrs+ idata <- findAttributeDecode [#{const IFLA_INFO_DATA}] info+ vid <- findAttributeGet getWord16host [#{const IFLA_VLAN_ID}] idata+ return $ VlanId vid --- | A bridge interface.-newtype Bridge = Bridge LinkName+-- | The master interface for this interface for this one. For example, a bridge+-- interface.+data LinkMaster = Master LinkIndex | NoMaster deriving (Show, Eq)-instance Message Bridge where- type MessageHeader Bridge = IfInfoMsg- messageAttrs (Bridge name) = messageAttrs name <> AttributeList- [ AttributeNest #{const IFLA_LINKINFO}- [ cStringAttr #{const IFLA_INFO_KIND} "bridge" ]- ]-instance Create Bridge where- createTypeNumber = const #{const RTM_NEWLINK}+instance Message LinkMaster where+ type MessageHeader LinkMaster = IfInfoMsg+ messageAttrs (Master n) = AttributeList [word32Attr #{const IFLA_MASTER} $ fromIntegral n]+ messageAttrs NoMaster = AttributeList [word32Attr #{const IFLA_MASTER} 0]+instance Reply LinkMaster where+ type ReplyHeader LinkMaster = IfInfoMsg+ fromNLMessage NLMessage {..} = Just . fromMaybe NoMaster $ do+ ix <- findAttributeDecode [#{const IFLA_MASTER}] nlmAttrs+ guard $ ix > 0+ return $ Master ix+instance Change LinkName LinkMaster where+ changeAttrs n m = messageAttrs n <> messageAttrs m+instance Change LinkIndex LinkMaster where+ changeAttrs n m = messageAttrs m -- | The state of a link. data LinkState = Up | Down deriving (Show, Eq) instance Reply LinkState where type ReplyHeader LinkState = IfInfoMsg- replyTypeNumbers = const [#{const RTM_NEWLINK}]- fromNLMessage m = Just $ if flag == 0 then Down else Up+ fromNLMessage m = Just $ if flag == 0 then Down else Up where flag = ifFlags (nlmHeader m) .&. #{const IFF_UP} instance Change LinkName LinkState where- changeTypeNumber _ _ = #{const RTM_SETLINK}- changeAttrs n _ = messageAttrs n- changeHeader n s = IfInfoMsg ix flag #{const IFF_UP}- where- ix = ifIndex $ messageHeader n- flag = if s == Up then #{const IFF_UP} else 0+ changeHeaderParts n s =+ [ IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == Up then #{const IFF_UP} else 0+ , cfMask = #{const IFF_UP}+ }+ ] instance Change LinkIndex LinkState where- changeTypeNumber _ _ = #{const RTM_SETLINK}- changeAttrs n _ = messageAttrs n- changeHeader n s = IfInfoMsg ix flag #{const IFF_UP}+ changeHeaderParts n s =+ [ IfInfoMsgIndex $ fromIntegral n+ , IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == Up then #{const IFF_UP} else 0+ , cfMask = #{const IFF_UP}+ }+ ]++-- | A 'Promiscuous' link accepts all frames at layer 2; a 'Chaste' one accepts+-- just those addressed to it and possibly ones sent to the broadcast address.+data LinkPromiscuity = Promiscuous | Chaste+ deriving (Show, Eq)+instance Reply LinkPromiscuity where+ type ReplyHeader LinkPromiscuity = IfInfoMsg+ fromNLMessage m = Just $ if flag == 0 then Chaste else Promiscuous+ where flag = ifFlags (nlmHeader m) .&. #{const IFF_PROMISC}+instance Change LinkName LinkPromiscuity where+ changeHeaderParts n s =+ [ IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == Promiscuous then #{const IFF_PROMISC} else 0+ , cfMask = #{const IFF_PROMISC}+ }+ ]+instance Change LinkIndex LinkPromiscuity where+ changeHeaderParts n s =+ [ IfInfoMsgIndex $ fromIntegral n+ , IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == Promiscuous then #{const IFF_PROMISC} else 0+ , cfMask = #{const IFF_PROMISC}+ }+ ]++-- | Whether to use ARP on the interface to resolve L3 addresses to L2 ones.+data LinkArp = Arp | NoArp+ deriving (Show, Eq)+instance Reply LinkArp where+ type ReplyHeader LinkArp = IfInfoMsg+ fromNLMessage m = Just $ if flag == 0 then Arp else NoArp+ where flag = ifFlags (nlmHeader m) .&. #{const IFF_NOARP}+instance Change LinkName LinkArp where+ changeHeaderParts n s =+ [ IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == NoArp then #{const IFF_NOARP} else 0+ , cfMask = #{const IFF_NOARP}+ }+ ]+instance Change LinkIndex LinkArp where+ changeHeaderParts n s =+ [ IfInfoMsgIndex $ fromIntegral n+ , IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == NoArp then #{const IFF_NOARP} else 0+ , cfMask = #{const IFF_NOARP}+ }+ ]++-- | Internal debug flag. If this is supported by the driver, it will generally+-- spew some extra information into @dmesg@.+data LinkDebug = Debug | NoDebug+ deriving (Show, Eq)+instance Reply LinkDebug where+ type ReplyHeader LinkDebug = IfInfoMsg+ fromNLMessage m = Just $ if flag == 0 then NoDebug else Debug+ where flag = ifFlags (nlmHeader m) .&. #{const IFF_DEBUG}+instance Change LinkName LinkDebug where+ changeHeaderParts _ s =+ [ IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == Debug then #{const IFF_DEBUG} else 0+ , cfMask = #{const IFF_DEBUG}+ }+ ]+instance Change LinkIndex LinkDebug where+ changeHeaderParts n s =+ [ IfInfoMsgIndex $ fromIntegral n+ , IfInfoMsgFlags $ ChangeFlags+ { cfFlags = if s == Debug then #{const IFF_DEBUG} else 0+ , cfMask = #{const IFF_DEBUG}+ }+ ]++-- | Maximum transmission unit for a link. Note that some interface types, such+-- as 'Bridge's, don't allow this to be changed.+newtype LinkMTU = LinkMTU Word32+ deriving (Show, Eq, Num, Ord, Enum, Real, Integral)+instance Message LinkMTU where+ type MessageHeader LinkMTU = IfInfoMsg+ messageAttrs (LinkMTU mtu) =+ AttributeList [word32Attr #{const IFLA_MTU} mtu]+instance Change LinkName LinkMTU where+ changeAttrs n m = messageAttrs n <> messageAttrs m+instance Change LinkIndex LinkMTU where+ changeAttrs _ m = messageAttrs m+instance Reply LinkMTU where+ type ReplyHeader LinkMTU = IfInfoMsg+ fromNLMessage NLMessage{..} = LinkMTU+ <$> findAttributeGet getWord32host [#{const IFLA_MTU}] nlmAttrs++newtype LinkGroup = LinkGroup Word32+ deriving (Show, Eq, Num, Ord, Enum, Real, Integral)+instance Change LinkName LinkGroup where+ changeAttrs n (LinkGroup g) = messageAttrs n <> + AttributeList [word32Attr #{const IFLA_GROUP} g]+instance Change LinkIndex LinkGroup where+ changeAttrs _ (LinkGroup g) = AttributeList [word32Attr #{const IFLA_GROUP} g]+instance Reply LinkGroup where+ type ReplyHeader LinkGroup = IfInfoMsg+ fromNLMessage NLMessage {..} = LinkGroup+ <$> findAttributeGet getWord32host [#{const IFLA_GROUP}] nlmAttrs++data LinkStats = LinkStats+ { lsRxPackets :: Word64 -- ^ Total packets received.+ , lsTxPackets :: Word64 -- ^ Total packets transmitted.+ , lsRxBytes :: Word64 -- ^ Total bytes received.+ , lsTxBytes :: Word64 -- ^ Total bytes transmitted.+ , lsRxErrors :: Word64 -- ^ Bad packets received.+ , lsTxErrors :: Word64 -- ^ Packet transmission problems.+ , lsRxDropped :: Word64 -- ^ Dropped due to full buffers.+ , lsTxDropped :: Word64 -- ^ Out of memory.+ , lsMulticast :: Word64 -- ^ Multicast packets received.+ , lsCollisions :: Word64 -- ^ Packet collisions.+ , lsRxLengthErrors :: Word64 -- ^ Size/header mismatch.+ , lsRxOverErrors :: Word64 -- ^ Receive ring-buffer overflow.+ , lsRxCRCErrors :: Word64 -- ^ CRC errors.+ , lsRxFrameErrors :: Word64 -- ^ Frame-alignment errors.+ , lsRxFIFOErrors :: Word64 -- ^ Receiver FIFO overrun.+ , lsRxMissedErrors :: Word64 -- ^ Receiver missed packets.+ , lsTxAbortedErrors :: Word64+ , lsTxCarrierErrors :: Word64+ , lsTxFIFOErrors :: Word64+ , lsTxHeartbeatErrors :: Word64+ , lsTxWindowErrors :: Word64+ , lsRxCompressed :: Word64+ , lsTxCompressed :: Word64+ , lsRxNoHandler :: Word64 -- ^ Dropped due to lack of handler.+ } deriving (Show, Eq)+instance Reply LinkStats where+ type ReplyHeader LinkStats = IfInfoMsg+ fromNLMessage NLMessage {..} =+ findAttributeGet (get' getWord64host) [#{const IFLA_STATS64}] nlmAttrs+ <|> findAttributeGet (get' getWord32host) [#{const IFLA_STATS}] nlmAttrs where- ix = ifIndex $ messageHeader n- flag = if s == Up then #{const IFF_UP} else 0+ get' getter = let g = fromIntegral <$> getter in LinkStats+ <$>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g+ <*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g --- | The header corresponding to link messages, based on 'struct ifinfomsg'--- from 'linux/if_link.h'.+-- | The header corresponding to link messages, based on @struct ifinfomsg@+-- from @linux/if_link.h@. data IfInfoMsg = IfInfoMsg { ifIndex :: Int32 -- ^ The index of the link. , ifFlags :: Word32 -- ^ Operational flags of the link.- , ifChange :: Word32 -- ^ Change mask for link flags. } deriving (Show, Eq) instance Sized IfInfoMsg where size = const #{const sizeof(struct ifinfomsg)}@@ -162,12 +399,34 @@ putWord16host 0 putInt32host ifIndex putWord32host ifFlags- putWord32host ifChange+ putWord32host 0xffffffff get = do skip 4- ifIndex <- getInt32le- ifFlags <- getWord32host- ifChange <- getWord32host+ ifIndex <- getInt32le+ ifFlags <- getWord32host+ _change <- getWord32host return $ IfInfoMsg {..} instance Header IfInfoMsg where- emptyHeader = IfInfoMsg 0 0 0+ type HeaderPart IfInfoMsg = IfInfoMsgPart+ fromHeaderParts = toHeader . foldr modify (0,mempty)+ where+ toHeader (ix,f) = IfInfoMsg ix $ cfFlags f+ modify (IfInfoMsgIndex ix) (_, f) = (ix, f)+ modify (IfInfoMsgFlags f) (ix,g) = (ix, f <> g)+ emptyHeader = IfInfoMsg 0 0+instance CreateMessageHeader IfInfoMsg where+ createTypeNumber = const #{const RTM_NEWLINK}+instance DestroyMessageHeader IfInfoMsg where+ destroyTypeNumber = const #{const RTM_DELLINK}+instance ChangeMessageHeader IfInfoMsg where+ changeTypeNumber = const #{const RTM_SETLINK}+instance RequestMessageHeader IfInfoMsg where+ requestTypeNumber = const #{const RTM_GETLINK}+instance ReplyMessageHeader IfInfoMsg where+ replyTypeNumbers = const [#{const RTM_NEWLINK}]++-- | Combinable components of an IfInfoMsg.+data IfInfoMsgPart+ = IfInfoMsgIndex Int32+ | IfInfoMsgFlags (ChangeFlags Word32)+ deriving (Show, Eq)
src/System/Linux/RTNetlink/Message.hsc view
@@ -28,11 +28,11 @@ {-# LANGUAGE TypeFamilies #-} module System.Linux.RTNetlink.Message where -import Control.Applicative ((<$>), (<*>))+import Control.Applicative ((<$>), (<*>), (<|>)) import Control.Monad (guard) import Data.Int (Int32) import Data.List (nub)-import Data.Monoid (mempty)+import Data.Monoid (mempty, (<>)) import Data.Serialize import Data.Word (Word16, Word32) import qualified Data.ByteString as S@@ -49,8 +49,8 @@ sequenceNumber :: S.ByteString -> SequenceNumber sequenceNumber = either (const 0) nlMsgSeqNum . decode -type TypeNumber = Word16 -- ^ Message type for an 'NlMsgHdr'.-type NLFlags = Word16 -- ^ Top-level flags for an 'NlMsgHdr'.+type TypeNumber = Word16 -- ^ Message type for an 'NlMsgHdr'.+type NLFlags = Word16 -- ^ Top-level flags for an 'NlMsgHdr'. -- High-level representation of a netlink packet. data NLMessage header = NLMessage@@ -86,125 +86,225 @@ put NLMsgErr {..} = putInt32host nleError >> put nleHeader get = NLMsgErr <$> getInt32le <*> get instance Header NLMsgErr where+ type HeaderPart NLMsgErr = NLMsgErrPart+ fromHeaderParts = foldr modify emptyHeader+ where+ modify (NLMsgErrError e) h = h {nleError = e}+ modify (NLMsgErrHeader g) h = h {nleHeader = g} emptyHeader = NLMsgErr 0 $ NLMsgHdr 0 0 0 0 0+instance ReplyMessageHeader NLMsgErr where+ replyTypeNumbers _ = [#{const NLMSG_ERROR}] +data NLMsgErrPart+ = NLMsgErrError Int32+ | NLMsgErrHeader NLMsgHdr+ deriving (Show, Eq)+ -- | Class of things that can be used as second-level netlink headers. class (Show h, Eq h, Sized h, Serialize h) => Header h where+ -- | Components for a 'Header', so they can be combined.+ type HeaderPart h+ -- | How to construct a 'Header' from a list of @HeaderPart@s. An empty list+ -- should correspond to 'emptyHeader'.+ fromHeaderParts :: [HeaderPart h] -> h -- | Default header for a message, if none is specified. emptyHeader :: h instance Header () where- emptyHeader = ()+ type HeaderPart () = ()+ fromHeaderParts = mempty+ emptyHeader = () +-- | Class of headers that can be used to create things.+class Header h => CreateMessageHeader h where+ -- | The top-level type number associated with create messages with this+ -- header.+ createTypeNumber :: h -> TypeNumber++-- | Class of headers that can be used to destroy things.+class Header h => DestroyMessageHeader h where+ -- | The top-level type number associated with destroy messages with this+ -- header.+ destroyTypeNumber :: h -> TypeNumber++-- | Class of headers that can be used to change things.+class Header h => ChangeMessageHeader h where+ -- | The top-level type number associated with change messages with this+ -- header.+ changeTypeNumber :: h -> TypeNumber++-- | Class of headers that can be used to request things.+class Header h => RequestMessageHeader h where+ -- | The top-level type number associated with request messages with this+ -- header.+ requestTypeNumber :: h -> TypeNumber++-- | Class of headers that can be received in reply messages.+class Header h => ReplyMessageHeader h where+ -- | The expected top-level type number(s) that mark a packet replies with+ -- this header can be parsed from.+ replyTypeNumbers :: h -> [TypeNumber]+instance ReplyMessageHeader () where+ replyTypeNumbers () = []+ -- | Class of things that can be sent as messages. class Header (MessageHeader m) => Message m where -- | The type of header to attach to the message. type MessageHeader m- -- | Construct a header corresponding to a message. Defaults to `emptyHeader`.- messageHeader :: m -> MessageHeader m- messageHeader = const emptyHeader- -- | Construct netlink attributes corresponding to a message. Defaults to `mempty`.- messageAttrs :: m -> AttributeList- messageAttrs = mempty- -- | Produce an NLMessage suitable for sending over the wire.- toNLMessage ::- m -> TypeNumber -> NLFlags -> SequenceNumber -> NLMessage (MessageHeader m)- toNLMessage m = NLMessage (messageHeader m) (messageAttrs m)+ -- | Parts to construct a header corresponding to a message. Defaults+ -- to @[]@.+ messageHeaderParts :: m -> [HeaderPart (MessageHeader m)]+ messageHeaderParts = mempty+ -- | Construct netlink attributes corresponding to a message. Defaults+ -- to @[]@.+ messageAttrs :: m -> AttributeList+ messageAttrs = mempty {-# MINIMAL #-}+instance (Message m, Message n, MessageHeader m ~ MessageHeader n)+ => Message (m,n) where+ type MessageHeader (m,n) = MessageHeader m+ messageHeaderParts (m,n) = messageHeaderParts m <> messageHeaderParts n+ messageAttrs (m,n) = messageAttrs m <> messageAttrs n +-- | Produce a 'MessageHeader' from a 'Message' using 'messageHeaderParts'.+messageHeader :: Message m => m -> MessageHeader m+messageHeader = fromHeaderParts . messageHeaderParts++-- | Produce an 'NLMessage' suitable for sending over the wire.+toNLMessage :: Message m => m -> (MessageHeader m -> TypeNumber)+ -> NLFlags -> SequenceNumber -> NLMessage (MessageHeader m)+toNLMessage m typeNumber = NLMessage header (messageAttrs m) (typeNumber header)+ where header = messageHeader m+ -- | Class of 'Message's representing things that can be created.-class Message c => Create c where- -- | The top-level type number associated with creating with this message.- createTypeNumber :: c -> TypeNumber- -- | Produce an NLMessage suitable for sending over the wire.- createNLMessage :: c -> SequenceNumber -> NLMessage (MessageHeader c)- createNLMessage c = toNLMessage c (createTypeNumber c) flags- where flags = #{const NLM_F_REQUEST | NLM_F_ACK | NLM_F_CREATE | NLM_F_EXCL}- {-# MINIMAL createTypeNumber #-}+class (Message c, CreateMessageHeader (MessageHeader c)) => Create c+instance {-# Overlappable #-} (Create c, Create d,+ MessageHeader c ~ MessageHeader d) => Create (c,d) +-- | Produce an NLMessage suitable for sending over the wire.+createNLMessage :: Create c => c -> SequenceNumber -> NLMessage (MessageHeader c)+createNLMessage c = toNLMessage c createTypeNumber flags+ where flags = #{const NLM_F_REQUEST | NLM_F_ACK | NLM_F_CREATE | NLM_F_EXCL}+ -- | Class of 'Message's representing things that can be destroyed.-class Message d => Destroy d where- -- | The top-level type number associated with destroying with this- -- message.- destroyTypeNumber :: d -> TypeNumber- -- | Produce an NLMessage suitable for sending over the wire.- destroyNLMessage :: d -> SequenceNumber -> NLMessage (MessageHeader d)- destroyNLMessage d = toNLMessage d (destroyTypeNumber d) flags- where flags = #{const NLM_F_REQUEST | NLM_F_ACK}- {-# MINIMAL destroyTypeNumber #-}+class (Message d, DestroyMessageHeader (MessageHeader d)) => Destroy d+instance (Destroy d, Destroy e, MessageHeader d ~ MessageHeader e)+ => Destroy (d,e) +-- | Produce an NLMessage suitable for sending over the wire.+destroyNLMessage :: Destroy d => d -> SequenceNumber -> NLMessage (MessageHeader d)+destroyNLMessage d = toNLMessage d destroyTypeNumber flags+ where flags = #{const NLM_F_REQUEST | NLM_F_ACK}+ -- | Class of 'Message's representing pairs of identifying messages and -- quality that can be modified.-class Message id => Change id c where- -- | The top-level type number associated with changing things with this- -- message.- changeTypeNumber :: id -> c -> TypeNumber- -- | Construct a header from an identifier and a quality. Should probably- -- use the identifying message's 'messageHeader'.- changeHeader :: id -> c -> MessageHeader id- -- | Construct aattributes from an identifier and a quality. Should- -- probably use the identifying message's 'messageAttrs'.- changeAttrs :: id -> c -> AttributeList- -- | Produce an NLMessage suitable for sending over the wire.- changeNLMessage :: id -> c -> SequenceNumber -> NLMessage (MessageHeader id)- changeNLMessage i c = - NLMessage (changeHeader i c) (changeAttrs i c) (changeTypeNumber i c) flags- where flags = #{const NLM_F_REQUEST | NLM_F_ACK}- {-# MINIMAL changeTypeNumber, changeHeader, changeAttrs #-}+class (Message id, ChangeMessageHeader (MessageHeader id)) => Change id c where+ -- | Construct a list of 'HeaderPart's from an identifier and a quality. By+ -- default, use the identifying message's 'messageHeaderParts'.+ changeHeaderParts :: id -> c -> [HeaderPart (MessageHeader id)]+ changeHeaderParts i _ = messageHeaderParts i+ -- | Construct an 'AttributeList' from an identifier and a quality. By+ -- default, use the identifying message's 'messageAttrs'.+ changeAttrs :: id -> c -> AttributeList+ changeAttrs i _ = messageAttrs i+ {-# MINIMAL #-}+instance (Change id c, Change id d) => Change id (c,d) where+ changeHeaderParts id (c,d) =+ changeHeaderParts id c <> changeHeaderParts id d+ changeAttrs id (c,d) = changeAttrs id c <> changeAttrs id d+instance (Change id1 c, Change id2 c, MessageHeader id1 ~ MessageHeader id2)+ => Change (id1,id2) c where+ changeHeaderParts (id1,id2) c =+ changeHeaderParts id1 c <> changeHeaderParts id2 c+ changeAttrs (id1,id2) c = changeAttrs id1 c <> changeAttrs id2 c +-- | Produce an NLMessage suitable for sending over the wire.+changeNLMessage :: Change id c => id -> c -> SequenceNumber+ -> NLMessage (MessageHeader id)+changeNLMessage i c = + NLMessage header (changeAttrs i c) (changeTypeNumber header) flags+ where+ header = fromHeaderParts $ changeHeaderParts i c+ flags = #{const NLM_F_REQUEST | NLM_F_ACK}+ -- | Class of 'Message's that can serve as requests.-class Message r => Request r where- -- | The top-level type number associated with requesting things with this- -- message.- requestTypeNumber :: r -> TypeNumber+class (Message r, RequestMessageHeader (MessageHeader r)) => Request r where -- | The top-level flags associated with this request.- requestNLFlags :: r -> NLFlags- requestNLFlags = const #{const NLM_F_REQUEST}- -- | Produce an NLMessage suitable for sending over the wire.- requestNLMessage :: r -> SequenceNumber -> NLMessage (MessageHeader r)- requestNLMessage r = toNLMessage r (requestTypeNumber r) (requestNLFlags r)- {-# MINIMAL requestTypeNumber #-}+ requestNLFlags :: r -> ChangeFlags NLFlags+ {-# MINIMAL requestNLFlags #-}+instance (Request r, Request s, MessageHeader r ~ MessageHeader s)+ => Request (r,s) where+ -- | If either 'Request' instance demands a single 'Reply', any tuple+ -- containing it should also demand a single 'Reply'. Otherwise we combine+ -- the 'requestNLFlags' of each tuple element.+ requestNLFlags (r,s) = if rFlags == dumpOne r || sFlags == dumpOne s+ then dumpOne r+ else rFlags <> sFlags+ where+ rFlags = requestNLFlags r+ sFlags = requestNLFlags s --- | The default request flags assume that the request identifies a single--- entity. When requesting information for multiple entities, overload--- 'requestNLFlags' with these.-dumpNLFlags :: NLFlags-dumpNLFlags = #{const NLM_F_REQUEST | NLM_F_DUMP}+-- | Produce an 'NLMessage' suitable for sending over the wire.+requestNLMessage :: Request r => r -> SequenceNumber+ -> NLMessage (MessageHeader r)+requestNLMessage r = toNLMessage r requestTypeNumber flags+ where flags = applyChangeFlags' $ requestNLFlags r +-- | Top-level flags to indicate that calling 'dump' is expected to yield a+-- single 'Reply'.+dumpOne :: a -> ChangeFlags NLFlags+dumpOne = const $+ ChangeFlags #{const NLM_F_REQUEST} #{const NLM_F_REQUEST | NLM_F_DUMP}++-- | Top-level flags to indicate that calling 'dump' is expected to yield a+-- multiple 'Reply's.+dumpMany :: a -> ChangeFlags NLFlags+dumpMany = const $ setChangeFlags #{const NLM_F_REQUEST | NLM_F_DUMP}+ -- | Class of things that can be received.-class Header (ReplyHeader r) => Reply r where+class ReplyMessageHeader (ReplyHeader r) => Reply r where -- | The type of header associated with this 'Reply'. type ReplyHeader r- -- | The expected top-level type number(s) that mark a packet this reply- -- can be parsed from.- replyTypeNumbers :: r -> [TypeNumber] -- | Interpret a received NLMessage.- fromNLMessage :: NLMessage (ReplyHeader r) -> Maybe r+ fromNLMessage :: NLMessage (ReplyHeader r) -> Maybe r -- | Like 'fromNLMessage', but checks to make sure the top-level type -- number is in 'replyTypeNumbers', first.- {-# MINIMAL replyTypeNumbers, fromNLMessage #-}+ {-# MINIMAL fromNLMessage #-} instance Reply () where type ReplyHeader () = ()- replyTypeNumbers () = [] fromNLMessage _ = Nothing-instance (Reply r, Reply s, ReplyHeader r ~ ReplyHeader s) => Reply (r,s) where- type ReplyHeader (r,s) = ReplyHeader r- replyTypeNumbers (r,s) = nub $ replyTypeNumbers r ++ replyTypeNumbers s- fromNLMessage m = (,) <$> fromNLMessage m <*> fromNLMessage m instance Reply C.Errno where type ReplyHeader C.Errno = NLMsgErr- replyTypeNumbers _ = [#{const NLMSG_ERROR}]- fromNLMessage = Just . C.Errno . abs . fromIntegral . nleError . nlmHeader+ fromNLMessage = Just . C.Errno . abs . fromIntegral . nleError . nlmHeader+instance Reply r => Reply (Maybe r) where+ type ReplyHeader (Maybe r) = ReplyHeader r+ fromNLMessage m = return $ fromNLMessage m+instance (Reply r, Reply s, ReplyHeader r ~ ReplyHeader s)+ => Reply (Either r s) where+ type ReplyHeader (Either r s) = ReplyHeader r+ fromNLMessage m = Left <$> fromNLMessage m <|> Right <$> fromNLMessage m+instance (Reply r, Reply s, ReplyHeader r ~ ReplyHeader s) => Reply (r,s) where+ type ReplyHeader (r,s) = ReplyHeader r+ fromNLMessage m = (,) <$> fromNLMessage m <*> fromNLMessage m +class (Request q, Reply r) => Dump q r+instance Request q => Dump q ()+instance Request q => Dump q C.Errno+instance (Request r, Reply r) => Dump r r+instance Dump q r => Dump q (Maybe r)+instance (Dump q r, Dump q s, ReplyHeader r ~ ReplyHeader s)+ => Dump q (Either r s)+instance (Dump q r1, Dump q r2, ReplyHeader r1 ~ ReplyHeader r2)+ => Dump q (r1,r2)+instance (Dump q1 r, Dump q2 r, MessageHeader q1 ~ MessageHeader q2)+ => Dump (q1,q2) r+instance {-# Overlapping #-} (Dump q1 r1, Dump q2 r2,+ MessageHeader q1 ~ MessageHeader q2, ReplyHeader r1 ~ ReplyHeader r2)+ => Dump (q1,q2) (r1,r2)+instance {-# Overlappable #-} (Request q, Reply r,+ MessageHeader q ~ ReplyHeader r) => Dump q r+ fromNLMessage' :: Reply r => NLMessage (ReplyHeader r) -> Maybe r fromNLMessage' m = do r <- fromNLMessage m- guard $ nlmType m `elem` replyTypeNumbers r+ guard $ nlmType m `elem` replyTypeNumbers (nlmHeader m) return r---- Util--decodeMaybe :: Serialize a => S.ByteString -> Maybe a-decodeMaybe = either (const Nothing) Just . decode--runGetMaybe :: Get a -> S.ByteString -> Maybe a-runGetMaybe g = either (const Nothing) Just . runGet g
src/System/Linux/RTNetlink/Packet.hsc view
@@ -13,6 +13,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-} module System.Linux.RTNetlink.Packet ( -- * Low-level headers NLMsgHdr(..)@@ -25,27 +26,41 @@ , attributeType , attributeData , findAttribute+ , findAttributeData+ , findAttributeDecode+ , findAttributeGet+ , findAttributeCString , cStringAttr , word32Attr+ , word32AttrPart , word16Attr+ , word16AttrPart -- * Sized data , Sized(..) , putAligned+ -- * Monoidal bit flags+ , ChangeFlags(..)+ , applyChangeFlags+ , applyChangeFlags'+ , setChangeFlags ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (guard)-import Control.Monad.Loops (unfoldM)-import Control.Monad.Trans (lift)+import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (runMaybeT)-import Data.Bits ((.|.), (.&.), xor)-import Data.List (unfoldr, find)+import Data.Bits (Bits((.|.), (.&.), complement, xor, zeroBits), FiniteBits)+import Data.Bits.ByteString ()+import Data.List (unfoldr, find, sort) import Data.Maybe (listToMaybe) import Data.Monoid (Monoid, mempty, mappend)+import Data.Semigroup (Semigroup(..)) import Data.Serialize import Data.Word (Word16,Word32) import qualified Data.ByteString as S +import System.Linux.RTNetlink.Util+ #include <linux/netlink.h> -- | ADT corresponding to @struct nlmsghdr@ from @linux/netlink.h@.@@ -96,7 +111,7 @@ -- constructing headers. class Sized s where -- | Size of data.- size :: Integral i => s -> i+ size :: Integral i => s -> i -- | Size of data with alignment padding added. sizeAligned :: Integral a => a -> s -> a sizeAligned a s = ((size s + (a-1)) `div` a) * a@@ -117,12 +132,25 @@ -- | ADT representing a possibly nested netlink attribute. data Attribute- = Attribute AttributeType S.ByteString -- ^ Simple attribute.- | AttributeNest AttributeType [Attribute] -- ^ Nested attribute.+ = Attribute AttributeType S.ByteString+ -- ^ Simple attribute.+ | AttributeNest AttributeType [Attribute]+ -- ^ Nested attribute.+ | AttributePart AttributeType S.ByteString S.ByteString+ -- ^ Composable attribute. deriving (Show, Eq)+instance Ord Attribute where+ Attribute n _ `compare` Attribute m _ = n `compare` m+ AttributeNest n _ `compare` AttributeNest m _ = n `compare` m+ AttributePart n _ _ `compare` AttributePart m _ _ = n `compare` m+ Attribute _ _ `compare` _ = GT+ _ `compare` Attribute _ _ = LT+ AttributeNest _ _ `compare` _ = LT+ _ `compare` AttributeNest _ _ = GT instance Sized Attribute where- size (Attribute _ bs) = #{const sizeof(struct nlattr)} + size bs- size (AttributeNest _ as) = #{const sizeof(struct nlattr)} + size (AttributeList as)+ size (Attribute _ bs) = #{const sizeof(struct nlattr)} + size bs+ size (AttributeNest _ as) = #{const sizeof(struct nlattr)} + size (AttributeList as)+ size (AttributePart _ bs m) = #{const sizeof(struct nlattr)} + min (size bs) (size m) instance Serialize Attribute where put a = do putWord16host $ size a@@ -133,11 +161,17 @@ AttributeNest t as -> do putWord16host $ t .|. #{const NLA_F_NESTED} put $ AttributeList as+ AttributePart t bs mask -> do+ putWord16host t+ putAligned (4::Integer) $ bs .&. mask get = do nla_len <- fromIntegral <$> getWord16host nla_type <- getWord16host nla_data <- getByteString $ nla_len - #{const sizeof(struct nlattr)} skip $ sizeAligned 4 nla_data - size nla_data+ -- Note: The kernel does not presently seem to set NLA_F_NESTED, so+ -- this doesn't work. Instead, we need to handle getting nested+ -- attributes manually. if nla_type .&. #{const NLA_F_NESTED} == 0 then return $ Attribute nla_type nla_data else do@@ -147,10 +181,15 @@ -- | A collection of netlink attributes. newtype AttributeList = AttributeList [Attribute] deriving (Show, Eq)+instance Semigroup AttributeList where+ AttributeList l1 <> AttributeList l2 = AttributeList $ l1 <> l2+instance Monoid AttributeList where+ mempty = AttributeList []+ mappend = (<>) instance Sized AttributeList where- size (AttributeList as) = sum $ fmap (sizeAligned 4) as+ size l = let AttributeList as = combineAttrs l in sum $ fmap (sizeAligned 4) as instance Serialize AttributeList where- put (AttributeList as) = mapM_ put as+ put l = let AttributeList as = combineAttrs l in mapM_ put as get = AttributeList <$> unfoldM getMaybeAttribute where getMaybeAttribute = runMaybeT $ do@@ -159,34 +198,58 @@ l <- lift $ lookAhead getWord16host guard $ l >= #{const sizeof(struct nlattr)} && r >= l lift get-instance Monoid AttributeList where- mempty = AttributeList []- AttributeList a `mappend` AttributeList b = AttributeList $ a ++ b +combineAttrs (AttributeList as) = AttributeList $ go as+ where+ go = foldr combine mempty . sort+ combine (AttributeNest m l1) (AttributeNest n l2 : as)+ | m == n = (AttributeNest n . go $ l1 <> l2) : as+ combine (AttributePart m bs1 m1) (AttributePart n bs2 m2 : as)+ | m == n = (AttributePart n ((bs1.&.m1) .|. (bs2.&.m2)) (m1.|.m2)) : as+ combine a as = a : as+ -- | Construct an 'Attribute' with a null-byte-terminated string as data. cStringAttr :: AttributeType -> S.ByteString -> Attribute cStringAttr t bs = Attribute t $ bs `S.snoc` 0 --- | Construct an 'Attribute' with a 32-bit word as data.+-- | Construct an 'Attribute' with a 32-bit word in host byte-order as data. word32Attr :: AttributeType -> Word32 -> Attribute word32Attr t = Attribute t . runPut . putWord32host --- | Construct an 'Attribute' with a 16-bit word as data.+-- | Composable 'Attribute' with a 32-bit word in host byte-order as data. The+-- second 'Word32' argument is a mask of bits we care about so that this+-- attribute can be combined with others of the same type.+word32AttrPart :: AttributeType -> Word32 -> Word32 -> Attribute+word32AttrPart t bits mask = AttributePart t (put' bits) (put' mask)+ where put' = runPut . putWord32host++-- | Construct an 'Attribute' with a 16-bit word in host byte-order as data. word16Attr :: AttributeType -> Word16 -> Attribute word16Attr t = Attribute t . runPut . putWord16host +-- | Composable 'Attribute' with a 16-bit word in host byte-order as data. The+-- second 'Word16' argument is a mask of bits we care about so that this+-- attribute can be combined with others of the same type.+word16AttrPart :: AttributeType -> Word16 -> Word16 -> Attribute+word16AttrPart t bits mask = AttributePart t (put' bits) (put' mask)+ where put' = runPut . putWord16host+ -- | Get the type of an 'Attribute'. attributeType :: Attribute -> AttributeType-attributeType (Attribute t _) = t-attributeType (AttributeNest t _) = t+attributeType (Attribute t _) = t+attributeType (AttributeNest t _) = t+attributeType (AttributePart t _ _) = t -- | Get the data from a simple 'Attribute'. attributeData :: Attribute -> Maybe S.ByteString-attributeData (Attribute _ bs) = Just bs-attributeData (AttributeNest _ _) = Nothing+attributeData (Attribute _ bs) = Just bs+attributeData (AttributeNest _ _) = Nothing+attributeData (AttributePart _ bs m) = Just $ bs .&. m -- | Search for an 'Attribute' in a possibly nested list using the--- 'AttributeType' to look for at each level.+-- 'AttributeType' to look for at each level. Unfortunately, the kernel does+-- not presently seem to set NLA_F_NESTED on nested attribute types. Until+-- this is changed in the kernel, we need to traverse nested elements manually. findAttribute :: [AttributeType] -> AttributeList -> Maybe Attribute findAttribute ts (AttributeList as) = do t <- listToMaybe ts@@ -194,5 +257,52 @@ case tail ts of [] -> return a ts' -> case a of- Attribute _ _ -> Nothing AttributeNest _ as' -> findAttribute ts' (AttributeList as')+ _ -> Nothing++-- | Search for an 'Attribute' and return its data field.+findAttributeData :: [AttributeType] -> AttributeList -> Maybe S.ByteString+findAttributeData ts l = attributeData =<< findAttribute ts l++-- | Search for an 'Attribute'; decode and return its data field.+findAttributeDecode :: Serialize a => [AttributeType] -> AttributeList -> Maybe a+findAttributeDecode ts l = decodeMaybe =<< attributeData =<< findAttribute ts l++-- | Search for an 'Attribute' and return its data field, minus any null bytes.+findAttributeCString :: [AttributeType] -> AttributeList -> Maybe S.ByteString+findAttributeCString ts l = S.takeWhile (/=0) <$> findAttributeData ts l++-- | Search for an 'Attribute', run a getter on it, and return the result.+findAttributeGet :: Get a -> [AttributeType] -> AttributeList -> Maybe a+findAttributeGet g ts l = runGetMaybe g =<< attributeData =<< findAttribute ts l++-- | A flags bitfield encoded as a set of changes to an initial value, which can+-- can be combined using the 'Monoid' instance. This 'Monoid' instance is *not*+-- commutative. Flags set or cleared on the right will override those on the+-- left.+data ChangeFlags a = ChangeFlags+ { cfFlags :: a -- ^ Flag bits+ , cfMask :: a -- ^ Mask of flag bits to use. Other bits will be ignored.+ } deriving Show+instance Bits a => Eq (ChangeFlags a) where+ ChangeFlags f m == ChangeFlags g n = m == n && (f .&. m) == (g .&. n)+instance (Bits a, FiniteBits a) => Semigroup (ChangeFlags a) where+ f <> g = ChangeFlags+ { cfFlags = applyChangeFlags g $ applyChangeFlags f zeroBits+ , cfMask = cfMask f .|. cfMask g+ }+instance (Bits a, FiniteBits a) => Monoid (ChangeFlags a) where+ mempty = ChangeFlags zeroBits zeroBits+ mappend = (<>)++-- | Apply a change to an existing flags bitfield.+applyChangeFlags :: Bits a => ChangeFlags a -> a -> a+applyChangeFlags ChangeFlags {..} b = (cfFlags .&. cfMask) `xor` (b .&. complement cfMask)++-- | Apply a change to the all-zeroes bit field.+applyChangeFlags' :: Bits a => ChangeFlags a -> a+applyChangeFlags' f = applyChangeFlags f zeroBits++-- | Set 'cfFlags' and 'cfMask' to the same value.+setChangeFlags :: Bits a => a -> ChangeFlags a+setChangeFlags a = ChangeFlags a a
+ src/System/Linux/RTNetlink/Util.hs view
@@ -0,0 +1,45 @@+{-|+Module : System.Linux.RTNetlink.Util+Description : Internal utility functions.+Copyright : (c) Formaltech Inc. 2017+License : BSD3+Maintainer : protob3n@gmail.com+Stability : experimental+Portability : Linux+-}+module System.Linux.RTNetlink.Util where++import Data.Bits (Bits(complement, zeroBits, (.&.), (.|.), shiftL, shiftR))+import Data.Bits (FiniteBits(finiteBitSize))+import Data.Serialize (Serialize, Get, runGet, decode)+import Data.Word (Word8, Word16)+import Numeric (showHex)+import qualified Data.ByteString as S++left :: (a -> b) -> Either a c -> Either b c+left f = either (Left . f) Right++unfoldM :: Monad m => m (Maybe a) -> m [a]+unfoldM m = do+ mb <- m+ case mb of+ Nothing -> return []+ Just a -> (a:) <$> unfoldM m++showMac :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> String+showMac a b c d e f = hex a <:> hex b <:> hex c <:> hex d <:> hex e <:> hex f+ where+ hex w = showHex w ""+ s <:> t = s ++ ":" ++ t :: String++oneBits :: Bits a => a+oneBits = complement zeroBits++decodeMaybe :: Serialize a => S.ByteString -> Maybe a+decodeMaybe = either (const Nothing) Just . decode++runGetMaybe :: Get a -> S.ByteString -> Maybe a+runGetMaybe g = either (const Nothing) Just . runGet g++byteSwap16 :: Word16 -> Word16+byteSwap16 b = ((b .&. 0x00ff) `shiftL` 8) .|. ((b .&. 0xff00) `shiftR` 8)
src/System/Socket/Family/Netlink.hsc view
@@ -21,7 +21,7 @@ , netlinkKernel ) where -import Data.Bits ((.|.))+import Data.Bits ((.|.), (.&.), shiftL) import Data.Functor ((<$>)) import Data.Serialize (Serialize(..), encode, decode) import Data.Serialize (putWord16host, putWord32host, getWord16host, getWord32host)@@ -29,6 +29,7 @@ import Foreign.Storable (Storable(..)) import GHC.Word (Word32) import System.Posix (getProcessID)+import System.Random (randomRIO) import qualified Data.ByteString.Char8 as S import System.Socket@@ -85,7 +86,13 @@ netlinkAddress :: NetlinkGroup g => [g] -> IO (SocketAddress Netlink) netlinkAddress gs = do pid <- fromIntegral <$> getProcessID- return $ SocketAddressNetlink pid (netlinkGroupMask gs)+ rid <- randomRIO (linuxPidMax, maxBound)+ let id' = (pid .&. linuxPidMask) .|. linuxPidShift rid+ return $ SocketAddressNetlink id' (netlinkGroupMask gs)+ where+ linuxPidMax = 0x00400000 -- Max pid for 64-bit Linux is 2^22 - 1+ linuxPidMask = 0x003fffff+ linuxPidShift = (`shiftL` 22) -- | Like 'netlinkAddress', but with a configurable source address. netlinkAddressPid :: NetlinkGroup g => Word32 -> [g] -> SocketAddress Netlink
tests/Main.hs view
@@ -1,11 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Exception (bracket)+import Control.Monad.Catch (throwM, bracket) import Data.Functor ((<$>))+import Data.List ((\\)) import System.Posix (getEffectiveUserID) import System.Socket.Family.Inet (inetAddressFromTuple) import System.Socket.Family.Inet6 (inet6AddressFromTuple)+import System.Linux.Namespaces (Namespace(..), UserMapping(..))+import System.Linux.Namespaces (writeUserMappings, unshare)+import qualified Data.ByteString.Char8 as S import Test.Hspec @@ -13,206 +17,478 @@ import System.Linux.RTNetlink.Link import System.Linux.RTNetlink.Address -loopback :: LinkName-loopback = LinkName "lo"- testLink :: LinkName-testLink = LinkName "foobazblargle"+testLink = "test-link" -notALink :: LinkName-notALink = LinkName "notalink"+testLinkEther :: LinkEther+testLinkEther = LinkEther 0xaa 0xbb 0xcc 0xdd 0xee 0xff -localhost4 :: InetAddress-localhost4 = inetAddressFromTuple (127,0,0,1)+testLinkBroadcastEther :: LinkBroadcastEther+testLinkBroadcastEther = LinkBroadcastEther 0xff 0xff 0xff 0x00 0x00 0x00 -localhost6 :: Inet6Address-localhost6 = inet6AddressFromTuple (0,0,0,0,0,0,0,1)+testLinkIndex :: LinkIndex+testLinkIndex = 9001 +testVlan :: LinkName+testVlan = "test-vlan"++testVlanId :: VlanId+testVlanId = 101++testVlanIndex :: LinkIndex+testVlanIndex = 9002++testBridge :: LinkName+testBridge = "test-bridge"++testBridgeIndex :: LinkIndex+testBridgeIndex = 9003++notALink :: LinkName+notALink = "not-a-link"+ testAddress4 :: InetAddress testAddress4 = inetAddressFromTuple (169,254,42,42) +testIfPrefix4 :: IfPrefix+testIfPrefix4 = 17++testIfInetAddress :: IfIndex -> IfInetAddress+testIfInetAddress = IfInetAddress testAddress4 testIfPrefix4+ testAddress6 :: Inet6Address testAddress6 = inet6AddressFromTuple (0xfe80,42,42,42,42,42,42,42) -createTestInterface :: IO ()-createTestInterface = runRTNL $ do- create $ Bridge testLink- [LinkIndex n] <- dump testLink- let prefix4 = IfPrefix 24- prefix6 = IfPrefix 64- index = IfIndex n- create $ IfInetAddress testAddress4 prefix4 index- create $ IfInet6Address testAddress6 prefix6 index+testIfPrefix6 :: IfPrefix+testIfPrefix6 = 64 -withTestInterface :: IO a -> IO a-withTestInterface = bracket createTestInterface (const destroyTestLink) . const+testIfInet6Address :: IfIndex -> IfInet6Address+testIfInet6Address = IfInet6Address testAddress6 testIfPrefix6 -createTestLink :: IO ()-createTestLink = runRTNL (create $ Bridge testLink)+testIfIndex :: IfIndex+testIfIndex = fromIntegral testLinkIndex -destroyTestLink :: IO ()-destroyTestLink = runRTNL $ destroy testLink+withTestInterface_ :: (IfIndex -> RTNL a) -> RTNL a+withTestInterface_ m = withTestLink_ $ \(LinkIndex n) -> do+ let ix = IfIndex n+ create $ testIfInetAddress ix+ create $ testIfInet6Address ix+ m ix -withTestLink :: IO a -> IO a-withTestLink = bracket createTestLink (const destroyTestLink) . const+withTestInterface :: RTNL a -> RTNL a+withTestInterface = withTestInterface_ . const +createTestLink :: RTNL LinkIndex+createTestLink = testLinkIndex <$+ create (testLink+ , (testLinkEther+ , (testLinkBroadcastEther+ , (testLinkIndex+ , (Dummy+ )))))++withTestLink_ :: (LinkIndex -> RTNL a) -> RTNL a+withTestLink_ = bracket createTestLink destroy++withTestLink :: RTNL a -> RTNL a+withTestLink = withTestLink_ . const++withTestVlan_ :: (LinkIndex -> RTNL a) -> RTNL a+withTestVlan_ m = withTestLink_ $ \ix -> do+ create ((Dot1QVlan ix testVlanId, testVlan), testVlanIndex)+ m testVlanIndex++withTestVlan :: RTNL a -> RTNL a+withTestVlan = withTestVlan_ . const++createTestBridge :: RTNL LinkIndex+createTestBridge = testBridgeIndex <$+ create ((Bridge, testBridge), testBridgeIndex)++withTestBridge_ :: (LinkIndex -> RTNL a) -> RTNL a+withTestBridge_ = bracket createTestBridge destroy++withTestBridge :: RTNL a -> RTNL a+withTestBridge = withTestBridge_ . const++rtnlShouldReturn :: (HasCallStack, Show a, Eq a) => RTNL a -> a -> RTNL ()+rtnlShouldReturn m a = do+ a' <- m+ liftIO $ a `shouldBe` a'+ main :: IO () main = do- haveRoot <- (0 ==) <$> getEffectiveUserID+ euid <- getEffectiveUserID+ unshare [User, Network]+ writeUserMappings Nothing [UserMapping 0 euid 1] hspec $ do describe "dump" testDump- describe "create" $- if haveRoot- then testCreate- else it "should create things" $ pendingWith "requires root"- describe "change" $- if haveRoot- then testChange- else it "should change things" $ pendingWith "requires root"- describe "destroy" $- if haveRoot- then testDestroy- else it "should destroy things" $ pendingWith "requires root"+ describe "create" testCreate+ describe "change" testChange+ describe "destroy" testDestroy testDump :: Spec testDump = do context "when operating on layer-2 links" $ do- it "gets link names" $ do- links <- runRTNL $ dump AnyLink- links `shouldSatisfy` elem loopback+ it "gets link names" . runRTNL . withTestLink $+ dump' testLinkIndex `rtnlShouldReturn` testLink - it "gets link indices" $ do- runRTNL (dump loopback) `shouldReturn` [LinkIndex 1]+ it "gets link indices" . runRTNL . withTestLink $+ dump' testLinkIndex `rtnlShouldReturn` testLinkIndex - it "gets link states" $ do- runRTNL (dump loopback) `shouldReturn` [Up]+ it "gets link ethernet addresses" . runRTNL . withTestLink $+ dump' testLinkIndex `rtnlShouldReturn` testLinkEther + it "gets link broadcast ethernets" . runRTNL . withTestLink $+ dump' testLinkIndex `rtnlShouldReturn` testLinkBroadcastEther++ it "gets link states" . runRTNL . withTestLink $+ dump' testLinkIndex `rtnlShouldReturn` Down++ it "gets link promiscuity" . runRTNL . withTestLink $ + dump' testLinkIndex `rtnlShouldReturn` Chaste++ it "gets link arp state" . runRTNL . withTestLink $ + dump' testLinkIndex `rtnlShouldReturn` Arp++ it "gets link debug state" . runRTNL . withTestLink $ + dump' testLinkIndex `rtnlShouldReturn` NoDebug++ it "gets link MTUs" . runRTNL . withTestLink $ + dump' testLinkIndex `rtnlShouldReturn` LinkMTU 1500++ it "gets link stats" . runRTNL . withTestLink $ + dump testLinkIndex `rtnlShouldReturn`+ [LinkStats 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]++ it "gets link groups" . runRTNL . withTestLink $ + dump' testLinkIndex `rtnlShouldReturn` LinkGroup 0++ it "gets link types" . runRTNL . withTestLink $+ dump' testLinkIndex `rtnlShouldReturn` Dummy++ it "gets link vlan ids" . runRTNL . withTestVlan $+ dump' testVlanIndex `rtnlShouldReturn` testVlanId++ it "gets link masters" . runRTNL . withTestLink . withTestBridge $ do+ change testLinkIndex $ Master testBridgeIndex+ dump' testLinkIndex `rtnlShouldReturn` Master testBridgeIndex+ context "when given a non-existent link name" $ do it "throws an exception" $ do- runRTNL (dump notALink :: RTNL [()]) `shouldThrow` anyIOException+ runRTNL (dump notALink :: RTNL [()])+ `shouldThrow` anyIOException context "when operating on layer-3 interfaces" $ do- it "gets link ethernet addresses" $ do- runRTNL (dump loopback) `shouldReturn` [LinkEther 0 0 0 0 0 0]+ it "gets interface ipv4 addresses" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [testAddress4] - it "gets interface ipv4 addresses" $ do- addresses <- runRTNL $ dump AnyInterface- addresses `shouldSatisfy` elem localhost4+ it "gets interface ipv6 addresses" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [testAddress6] - it "gets interface ipv6 addresses" $ do- addresses <- runRTNL $ dump AnyInterface- addresses `shouldSatisfy` elem localhost6+ it "gets interface indices" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, testIfIndex)] + it "gets interface prefixes" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, testIfPrefix4)]++ it "gets interface scopes" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, IfUniverse)]++ it "gets interface labels" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, (\(LinkName s) -> IfLabel s) testLink)]++ it "gets interface precedence" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, Primary)]++ it "gets interface duplicate address detection" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6, DadEnabled)]++ it "gets interface duplicate address detection flags" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6,+ DuplicateAddressDetectionFlags+ { dadOptimistic = False+ , dadTentative = False+ , dadFailed = False+ })]++ it "gets interface MIP6 homing" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6, Home)]++ it "gets interface preferences" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6, Prefered)]++ it "gets interface permanence" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6, Permanent)]++ it "gets interface prefix-route creation" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, PREnabled)]++ it "gets interface multicast autojoin status" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, NoAutoJoin)]++ it "gets interface cache lifetimes" . runRTNL . withTestInterface $ do+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain`+ [(testAddress4, IfLifetime IfForever IfForever)]+ testCreate :: Spec testCreate = do- context "when operating on layer-2 links" $ after_ destroyTestLink $ do- it "creates bridge links" $ do- links <- runRTNL $ do- create $ Bridge testLink- dump AnyLink- links `shouldSatisfy` elem testLink+ context "when operating on layer-2 links" $ do+ it "creates named bridge links" . runRTNL $ do+ create (Bridge, testLink)+ links <- dump AnyLink+ destroy testLink+ liftIO $ links `shouldContain` [testLink] - it "creates dummy links" $ do- links <- runRTNL $ do- create $ Dummy testLink- dump AnyLink- links `shouldSatisfy` elem testLink+ it "creates named dummy links" . runRTNL $ do+ create (Dummy, testLink)+ links <- dump AnyLink+ destroy testLink+ liftIO $ links `shouldContain` [testLink] - context "when operating on layer-3 interfaces" $ around_ withTestLink $ do- it "creates ipv4 addresses" $ do- addresses <- runRTNL $ do- [LinkIndex n] <- dump testLink- let prefix = IfPrefix 24- index = IfIndex n- interface = IfInetAddress testAddress4 prefix index- create interface- dump AnyInterface- addresses `shouldSatisfy` elem testAddress4+ it "creates named 802.1Q vlans" . runRTNL . withTestLink $ do+ let vlan = (Dot1QVlan testLinkIndex testVlanId, testVlan)+ create vlan+ links <- dump AnyLink+ liftIO $ links `shouldContain` [vlan] - it "creates ipv6 addresses" $ do- addresses <- runRTNL $ do- [LinkIndex n] <- dump testLink- let prefix = IfPrefix 64- index = IfIndex n- interface = IfInet6Address testAddress6 prefix index- create interface- dump AnyInterface- addresses `shouldSatisfy` elem testAddress6+ it "creates named 802.1ad vlans" . runRTNL . withTestLink $ do+ let vlan = (Dot1adVlan testLinkIndex testVlanId, testVlan)+ create vlan+ links <- dump AnyLink+ liftIO $ links `shouldContain` [vlan] + it "creates unnamed links" . runRTNL $ do+ before <- dump AnyLink+ create Dummy+ after <- dump AnyLink+ let dummy = head $ after \\ before+ destroy dummy+ liftIO $ dummy `shouldSatisfy`+ \(LinkName name) -> "dummy" `S.isPrefixOf` name++ it "creates numbered links" . runRTNL $ do+ ixs <- dump AnyLink :: RTNL [LinkIndex]+ let ix = maximum ixs + 42+ create (Dummy, ix)+ links <- dump AnyLink+ destroy ix+ liftIO $ links `shouldContain` [ix]++ it "creates links with ethernet addresses" . runRTNL $ do+ let mac = LinkEther 0xaa 0xbb 0xcc 0xdd 0xee 0xff+ create ((Dummy, testLink), mac)+ links <- dump AnyLink+ destroy testLink+ liftIO $ links `shouldContain` [mac]++ it "creates links with ethernet addresses" . runRTNL $ do+ let mac = LinkEther 0xaa 0xbb 0xcc 0xdd 0xee 0xff+ brd = LinkBroadcastEther 0xaa 0xbb 0xcc 0xff 0xff 0xff+ create (((Dummy, testLink), mac), brd)+ links <- dump AnyLink+ destroy testLink+ liftIO $ links `shouldContain` [(mac,brd)]++ context "when operating on layer-3 interfaces" $ do+ it "creates ipv4 addresses" . runRTNL . withTestLink $ do+ let prefix = 24+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInetAddress testAddress4 prefix index+ create interface+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [testAddress4]++ it "creates ipv6 addresses" . runRTNL . withTestLink $ do+ let prefix = 64+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInet6Address testAddress6 prefix index+ create interface+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [testAddress6]++ it "creates ipv6 addresses with DAD disabled" . runRTNL . withTestLink $ do+ let prefix = 64+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInet6Address testAddress6 prefix index+ create (interface, DadDisabled)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6, DadDisabled)]++ it "creates ipv4 addresses with scopes" . runRTNL . withTestLink $ do+ let prefix = 24+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInetAddress testAddress4 prefix index+ create (interface, IfHost)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, IfHost)]++ it "creates ipv4 addresses with labels" . runRTNL . withTestLink $ do+ let prefix = 24+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInetAddress testAddress4 prefix index+ label = IfLabel $ "test-link:foo"+ create (interface, label)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, label)]++ it "creates ipv4 addresses without prefix routes" . runRTNL . withTestLink $ do+ let prefix = 24+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInetAddress testAddress4 prefix index+ create (interface, PRDisabled)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress4, PRDisabled)]++ it "creates ipv6 addresses without prefix routes" . runRTNL . withTestLink $ do+ let prefix = 64+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInet6Address testAddress6 prefix index+ create (interface, PRDisabled)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [(testAddress6, PRDisabled)]++ it "creates ipv4 addresses with lifetimes" . runRTNL . withTestLink $ do+ let prefix = 24+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInetAddress testAddress4 prefix index+ lifetime = IfLifetime+ { ifPrefered = IfSeconds 300+ , ifValid = IfSeconds 300+ }+ create (interface, lifetime)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [testAddress4]++ it "creates ipv6 addresses with lifetimes" . runRTNL . withTestLink $ do+ let prefix = 64+ index = IfIndex $ fromIntegral testLinkIndex+ interface = IfInet6Address testAddress6 prefix index+ lifetime = IfLifetime+ { ifPrefered = IfSeconds 300+ , ifValid = IfSeconds 300+ }+ create (interface, lifetime)+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldContain` [testAddress6]+ context "when given a bad interface index" $ do it "throws an exception" $ do- indices <- runRTNL $ dump AnyLink- let LinkIndex n = maximum indices + 1+ ixs <- runRTNL $ dump AnyLink+ let LinkIndex n = maximum ixs + 1 badIx = IfIndex n- prefix = IfPrefix 24+ prefix = 24 interface = IfInetAddress testAddress4 prefix badIx runRTNL (create interface) `shouldThrow` anyIOException context "when given a silly prefix" $ do it "throws an exception" $ do- [LinkIndex n] <- runRTNL $ dump testLink- let index = IfIndex n- badPrefix = IfPrefix 42+ let index = IfIndex $ fromIntegral testLinkIndex+ badPrefix = 42 interface = IfInetAddress testAddress4 badPrefix index- runRTNL (create interface) `shouldThrow` anyIOException+ runRTNL (withTestLink $ create interface)+ `shouldThrow` anyIOException testChange :: Spec testChange = do- context "when operating on layer-2 links" $ around_ withTestLink $ do- it "brings links up" $ do- [state] <- runRTNL $ do- change testLink Up- dump testLink- state `shouldBe` Up+ context "when operating on layer-2 links" $ do+ it "brings links up" . runRTNL . withTestLink $ do+ change testLink Up+ dump' testLink `rtnlShouldReturn` Up - it "brings links down" $ do- [state] <- runRTNL $ do- change testLink Up- change testLink Down- dump testLink- state `shouldBe` Down+ it "brings links down" . runRTNL . withTestLink $ do+ change testLink Up+ change testLink Down+ dump' testLink `rtnlShouldReturn` Down + it "makes links promiscuous" . runRTNL . withTestLink $ do+ change testLink Promiscuous+ dump' testLink `rtnlShouldReturn` Promiscuous++ it "makes links chaste" . runRTNL . withTestLink $ do+ change testLink Promiscuous+ change testLink Chaste+ dump' testLink `rtnlShouldReturn` Chaste++ it "turns off arp on links" . runRTNL . withTestLink $ do+ change testLink NoArp+ dump' testLink `rtnlShouldReturn` NoArp++ it "turns on arp on links" . runRTNL . withTestLink $ do+ change testLink NoArp+ change testLink Arp+ dump' testLink `rtnlShouldReturn` Arp++ it "turns off debug on links" . runRTNL . withTestLink $ do+ change testLink Debug+ dump' testLink `rtnlShouldReturn` Debug++ it "turns on arp on links" . runRTNL . withTestLink $ do+ change testLink Debug+ change testLink NoDebug+ dump' testLink `rtnlShouldReturn` NoDebug++ it "changes link MTUs" . runRTNL . withTestLink $ do+ let weirdMTU = LinkMTU 9999+ change testLink weirdMTU+ dump' testLink `rtnlShouldReturn` weirdMTU++ it "changes link ethernet addresses" . runRTNL . withTestLink $ do+ let weirdEther = LinkEther 0xaa 0xbb 0xcc 0xdd 0xee 0xff+ change testLink weirdEther+ dump' testLink `rtnlShouldReturn` weirdEther+ context "when given a non-existent link name" $ do it "throws an exception" $ do runRTNL (change notALink Up) `shouldThrow` anyIOException testDestroy :: Spec testDestroy = do- context "when operating on layer-2 links" $ before_ createTestLink $ do- it "destroys links by name" $ do- links <- runRTNL $ do- destroy testLink- dump AnyLink- links `shouldSatisfy` not . elem testLink+ context "when operating on layer-2 links" $ do+ it "destroys links by name" . runRTNL $ do+ create (Dummy, testLink)+ destroy testLink+ links <- dump AnyLink+ liftIO $ links `shouldSatisfy` not . elem testLink - it "destroys links by index" $ do- links <- runRTNL $ do- [LinkIndex n] <- dump testLink- destroy $ LinkIndex n- dump AnyLink- links `shouldSatisfy` not . elem testLink+ it "destroys links by index" . runRTNL $ do+ create (Dummy, testLinkIndex)+ destroy testLinkIndex+ links <- dump AnyLink+ liftIO $ links `shouldSatisfy` not . elem testLink - context "when given a non-existent link name" $ after_ destroyTestLink $ do+ context "when given a non-existent link name" $ do it "throws an exception" $ do runRTNL (destroy notALink) `shouldThrow` anyIOException - context "when operating on layer-3 interfaces" $ around_ withTestInterface $ do- it "destroys ipv4 addresses" $ do- addresses <- runRTNL $ do- [LinkIndex n] <- dump testLink- let prefix = IfPrefix 24- index = IfIndex n- interface = IfInetAddress testAddress4 prefix index- destroy interface- dump AnyInterface- addresses `shouldSatisfy` not . elem testAddress4+ context "when operating on layer-3 interfaces" $ do+ it "destroys ipv4 addresses" . runRTNL . withTestLink_ $ \(LinkIndex n) -> do+ let index = IfIndex n+ interface = testIfInetAddress index+ create interface+ destroy interface+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldSatisfy` not . elem testAddress4 - it "destroys ipv6 addresses" $ do- addresses <- runRTNL $ do- [LinkIndex n] <- dump testLink- let prefix = IfPrefix 64- index = IfIndex n- interface = IfInet6Address testAddress6 prefix index- destroy interface- dump AnyInterface- addresses `shouldSatisfy` not . elem testAddress6+ it "destroys ipv6 addresses" . runRTNL . withTestLink_ $ \(LinkIndex n) -> do+ let index = IfIndex n+ interface = testIfInet6Address index+ create interface+ destroy interface+ addresses <- dump AnyInterface+ liftIO $ addresses `shouldSatisfy` not . elem testAddress6