summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBenHamlin <>2019-07-05 06:15:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-05 06:15:00 (GMT)
commit274b1c1e4346605eb0dfe9e10ea00d1323843d74 (patch)
tree629b6e976b704653c9280473d12b6704ef0e90bc
parent38168bfd4d842b98c256c06bdbfd0194c49f5f4c (diff)
version 0.2.0.00.2.0.0
-rw-r--r--ChangeLog.md32
-rw-r--r--examples/rtnl-address/Main.hs53
-rw-r--r--examples/rtnl-link/Main.hs173
-rw-r--r--rtnetlink.cabal45
-rw-r--r--src/System/Linux/RTNetlink.hs46
-rw-r--r--src/System/Linux/RTNetlink/Address.hsc389
-rw-r--r--src/System/Linux/RTNetlink/Link.hsc409
-rw-r--r--src/System/Linux/RTNetlink/Message.hsc272
-rw-r--r--src/System/Linux/RTNetlink/Packet.hsc154
-rw-r--r--src/System/Linux/RTNetlink/Util.hs45
-rw-r--r--src/System/Socket/Family/Netlink.hsc11
-rw-r--r--tests/Main.hs570
12 files changed, 1748 insertions, 451 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 597c355..f3dbb60 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -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
diff --git a/examples/rtnl-address/Main.hs b/examples/rtnl-address/Main.hs
index 12507ca..379a004 100644
--- a/examples/rtnl-address/Main.hs
+++ b/examples/rtnl-address/Main.hs
@@ -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 @@ usage = do
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
diff --git a/examples/rtnl-link/Main.hs b/examples/rtnl-link/Main.hs
index 32d5d18..fa68ca0 100644
--- a/examples/rtnl-link/Main.hs
+++ b/examples/rtnl-link/Main.hs
@@ -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 @@ usage = do
++ "\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"
diff --git a/rtnetlink.cabal b/rtnetlink.cabal
index a0f8162..21e4ccd 100644
--- a/rtnetlink.cabal
+++ b/rtnetlink.cabal
@@ -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 @@ category: Network, System
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 @@ test-suite rtnetlink-tests
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-link
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 @@ library
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 @@ library
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
diff --git a/src/System/Linux/RTNetlink.hs b/src/System/Linux/RTNetlink.hs
index fe05b36..642ab43 100644
--- a/src/System/Linux/RTNetlink.hs
+++ b/src/System/Linux/RTNetlink.hs
@@ -58,6 +58,7 @@ module System.Linux.RTNetlink (
, create
, destroy
, dump
+ , dump'
, change
, getBacklog
, clearBacklog
@@ -72,10 +73,11 @@ module System.Linux.RTNetlink (
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, MessageFlags, SocketException(..))
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 @@ data Handle = Handle
}
-- | 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 @@ runRTNL = runRTNLGroups []
-- | 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 @@ talk m = do
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 :: Destroy d => d -> RTNL ()
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 :: Socket f t p -> Int -> MessageFlags -> IO [S.ByteString]
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
diff --git a/src/System/Linux/RTNetlink/Address.hsc b/src/System/Linux/RTNetlink/Address.hsc
index be4d62e..f425f44 100644
--- a/src/System/Linux/RTNetlink/Address.hsc
+++ b/src/System/Linux/RTNetlink/Address.hsc
@@ -9,8 +9,10 @@ Stability : experimental
Portability : Linux
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
@@ -19,30 +21,54 @@ module System.Linux.RTNetlink.Address
, 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 @@ instance Message InetAddress where
] 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 @@ instance Message Inet6Address where
] 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,30 +132,270 @@ instance Message AnyInterface where
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
@@ -146,23 +404,19 @@ data IfInetAddress = IfInetAddress
, 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 @@ data IfInet6Address = IfInet6Address
, 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 @@ instance Serialize IfAddrMsg where
<*> 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)
diff --git a/src/System/Linux/RTNetlink/Link.hsc b/src/System/Linux/RTNetlink/Link.hsc
index e5544a2..6884984 100644
--- a/src/System/Linux/RTNetlink/Link.hsc
+++ b/src/System/Linux/RTNetlink/Link.hsc
@@ -9,6 +9,7 @@ Stability : experimental
Portability : Linux
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -17,77 +18,104 @@ Portability : Linux
{-# 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
@@ -95,63 +123,272 @@ data AnyLink = AnyLink
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 @@ instance Serialize IfInfoMsg where
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)
diff --git a/src/System/Linux/RTNetlink/Message.hsc b/src/System/Linux/RTNetlink/Message.hsc
index b0d7017..16a4f80 100644
--- a/src/System/Linux/RTNetlink/Message.hsc
+++ b/src/System/Linux/RTNetlink/Message.hsc
@@ -28,11 +28,11 @@ to perform.
{-# 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 @@ type SequenceNumber = Word32
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 @@ instance Serialize NLMsgErr where
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 #-}
-
--- | 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}
+ 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
+
+-- | 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
diff --git a/src/System/Linux/RTNetlink/Packet.hsc b/src/System/Linux/RTNetlink/Packet.hsc
index 428526a..62afbb7 100644
--- a/src/System/Linux/RTNetlink/Packet.hsc
+++ b/src/System/Linux/RTNetlink/Packet.hsc
@@ -13,6 +13,7 @@ Portability : Linux
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
module System.Linux.RTNetlink.Packet (
-- * Low-level headers
NLMsgHdr(..)
@@ -25,27 +26,41 @@ module System.Linux.RTNetlink.Packet (
, 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 @@ splitMessages = unfoldr $ \bs -> do
-- 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 @@ type AttributeType = Word16
-- | 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 @@ instance Serialize Attribute where
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 @@ instance Serialize Attribute where
-- | 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 @@ instance Serialize AttributeList where
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 @@ findAttribute ts (AttributeList as) = do
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
diff --git a/src/System/Linux/RTNetlink/Util.hs b/src/System/Linux/RTNetlink/Util.hs
new file mode 100644
index 0000000..d20005c
--- /dev/null
+++ b/src/System/Linux/RTNetlink/Util.hs
@@ -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)
diff --git a/src/System/Socket/Family/Netlink.hsc b/src/System/Socket/Family/Netlink.hsc
index 41d8d9c..b3b30d9 100644
--- a/src/System/Socket/Family/Netlink.hsc
+++ b/src/System/Socket/Family/Netlink.hsc
@@ -21,7 +21,7 @@ module System.Socket.Family.Netlink
, 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.Ptr (castPtr)
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 @@ netlinkGroupMask = foldr (.|.) 0 . fmap netlinkGroupNumber
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
diff --git a/tests/Main.hs b/tests/Main.hs
index 9ae9ef7..f7f18c4 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -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,164 +17,441 @@ import System.Linux.RTNetlink
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
+
+testLinkBroadcastEther :: LinkBroadcastEther
+testLinkBroadcastEther = LinkBroadcastEther 0xff 0xff 0xff 0x00 0x00 0x00
+
+testLinkIndex :: LinkIndex
+testLinkIndex = 9001
+
+testVlan :: LinkName
+testVlan = "test-vlan"
+
+testVlanId :: VlanId
+testVlanId = 101
-localhost4 :: InetAddress
-localhost4 = inetAddressFromTuple (127,0,0,1)
+testVlanIndex :: LinkIndex
+testVlanIndex = 9002
-localhost6 :: Inet6Address
-localhost6 = inet6AddressFromTuple (0,0,0,0,0,0,0,1)
+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" . runRTNL . withTestLink $
+ dump' testLinkIndex `rtnlShouldReturn` testLinkIndex
- it "gets link indices" $ do
- runRTNL (dump loopback) `shouldReturn` [LinkIndex 1]
+ it "gets link ethernet addresses" . runRTNL . withTestLink $
+ dump' testLinkIndex `rtnlShouldReturn` testLinkEther
- it "gets link states" $ do
- runRTNL (dump loopback) `shouldReturn` [Up]
+ 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" $ do
- addresses <- runRTNL $ dump AnyInterface
- addresses `shouldSatisfy` elem localhost4
-
- it "gets interface ipv6 addresses" $ do
- addresses <- runRTNL $ dump AnyInterface
- addresses `shouldSatisfy` elem localhost6
+ it "gets interface ipv4 addresses" . runRTNL . withTestInterface $ do
+ addresses <- dump AnyInterface
+ liftIO $ addresses `shouldContain` [testAddress4]
+
+ it "gets interface ipv6 addresses" . runRTNL . withTestInterface $ do
+ addresses <- dump AnyInterface
+ liftIO $ addresses `shouldContain` [testAddress6]
+
+ 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
-
- it "creates dummy links" $ do
- links <- runRTNL $ do
- create $ Dummy testLink
- dump AnyLink
- links `shouldSatisfy` elem 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 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
+ 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 named dummy links" . runRTNL $ do
+ create (Dummy, testLink)
+ links <- dump AnyLink
+ destroy testLink
+ liftIO $ links `shouldContain` [testLink]
+
+ 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 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
-
- it "brings links down" $ do
- [state] <- runRTNL $ do
- change testLink Up
- change testLink Down
- dump testLink
- state `shouldBe` Down
+ 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" . 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
@@ -178,41 +459,36 @@ testChange = do
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
-
- it "destroys links by index" $ do
- links <- runRTNL $ do
- [LinkIndex n] <- dump testLink
- destroy $ LinkIndex n
- dump AnyLink
- links `shouldSatisfy` not . elem testLink
-
- context "when given a non-existent link name" $ after_ destroyTestLink $ do
+ 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" . runRTNL $ do
+ create (Dummy, testLinkIndex)
+ destroy testLinkIndex
+ links <- dump AnyLink
+ liftIO $ links `shouldSatisfy` not . elem testLink
+
+ 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
-
- 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
+ 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" . 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