summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBenHamlin <>2017-03-26 00:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-03-26 00:21:00 (GMT)
commite70851920b25b069303b57c06c355d39ff80bd7e (patch)
treec5597e98fc95c4c1ee3fd07dfa4382af58ea3dee
version 0.1.0.00.1.0.0
-rw-r--r--ChangeLog.md5
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--examples/rtnl-address/Main.hs46
-rw-r--r--examples/rtnl-link/Main.hs68
-rw-r--r--rtnetlink.cabal100
-rw-r--r--src/System/Linux/RTNetlink.hs222
-rw-r--r--src/System/Linux/RTNetlink/Address.hsc217
-rw-r--r--src/System/Linux/RTNetlink/Link.hsc172
-rw-r--r--src/System/Linux/RTNetlink/Message.hsc209
-rw-r--r--src/System/Linux/RTNetlink/Packet.hsc196
-rw-r--r--src/System/Socket/Family/Netlink.hsc95
-rw-r--r--src/System/Socket/Protocol/RTNetlink.hsc89
-rw-r--r--tests/Main.hs216
14 files changed, 1667 insertions, 0 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..c1abd29
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Revision history for rtnetlink
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..faa990f
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2017, Formaltech Inc.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Formaltech Inc. nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/examples/rtnl-address/Main.hs b/examples/rtnl-address/Main.hs
new file mode 100644
index 0000000..12507ca
--- /dev/null
+++ b/examples/rtnl-address/Main.hs
@@ -0,0 +1,46 @@
+module Main where
+
+import Data.List.Split (splitOneOf)
+import System.Environment
+import System.Socket.Family.Inet (inetAddressFromTuple)
+
+import System.Linux.RTNetlink
+import System.Linux.RTNetlink.Address
+
+usage :: IO ()
+usage = do
+ prog <- getProgName
+ putStrLn $ "Usage: " ++ prog ++ " COMMAND\n"
+ ++ "\n"
+ ++ "COMMAND\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"
+
+main :: IO ()
+main = do
+ args <- getArgs
+ err <- tryRTNL $ case args of
+ "create":"ipv4":ipv4:"index":ix':[] -> do
+ let ix = IfIndex $ read ix'
+ [a,b,c,d,m] = fmap read . splitOneOf "./" $ ipv4
+ address = inetAddressFromTuple (a,b,c,d)
+ prefix = IfPrefix m
+ create $ IfInetAddress address prefix ix
+ "destroy":"ipv4":ipv4:"index":ix':[] -> do
+ let ix = IfIndex $ read ix'
+ [a,b,c,d,m] = fmap 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])
+ _ -> liftIO usage
+ case err of
+ Left s -> putStrLn $ "Error: " ++ s
+ Right () -> putStrLn $ "Success"
diff --git a/examples/rtnl-link/Main.hs b/examples/rtnl-link/Main.hs
new file mode 100644
index 0000000..32d5d18
--- /dev/null
+++ b/examples/rtnl-link/Main.hs
@@ -0,0 +1,68 @@
+module Main where
+
+import System.Environment
+import qualified Data.ByteString.Char8 as S
+
+import System.Linux.RTNetlink
+import System.Linux.RTNetlink.Link
+
+usage :: IO ()
+usage = do
+ prog <- getProgName
+ putStrLn $ "Usage: " ++ prog ++ " COMMAND\n"
+ ++ "\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"
+ ++ "\n"
+ ++ "CREATE\n"
+ ++ "\t= TYPE <ifname> BRIDGE_OPTS\n"
+ ++ "\n"
+ ++ "TYPE\n"
+ ++ "\t= bridge\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":"dummy":name':[] -> do
+ let name = LinkName $ S.pack name'
+ create $ Dummy 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))])
+ "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)])
+ "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
+ _ -> liftIO usage
+ case err of
+ Left s -> putStrLn $ "Error: " ++ s
+ Right () -> putStrLn $ "Success"
diff --git a/rtnetlink.cabal b/rtnetlink.cabal
new file mode 100644
index 0000000..9f327de
--- /dev/null
+++ b/rtnetlink.cabal
@@ -0,0 +1,100 @@
+name: rtnetlink
+version: 0.1.0.0
+synopsis: Manipulate network devices, addresses, and routes on Linux
+description: A high-level, extensible, pure Haskell interface to the
+ ROUTE_NETLINK subsystem of netlink for manipulating
+ network devices on Linux.
+
+ RTNetlink provides the RTNL monad to simplify sending
+ and receiving messages, pre-built types for manipulating
+ devices and addresses, and typeclasses for creating your
+ own messages, based on linux\/netlink.h,
+ linux\/rtnetlink.h, et al.
+license: BSD3
+license-file: LICENSE
+author: Ben Hamlin
+maintainer: Ben Hamlin <protob3n@gmail.com>
+copyright: Formaltech Inc.
+category: Network, System
+build-type: Simple
+extra-source-files: ChangeLog.md
+cabal-version: >=1.10
+homepage: https://gitlab.com/formaltech/rtnetlink-hs
+
+flag examples
+ description: Build example programs
+ default: False
+
+test-suite rtnetlink-tests
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+ hs-source-dirs: tests
+ main-is: Main.hs
+ build-depends:
+ base >=4.9 && <4.10,
+ hspec >=2.4 && <2.5,
+ socket >=0.8 && <0.9,
+ unix >=2.7 && <2.8,
+ rtnetlink
+
+executable rtnl-link
+ if flag(examples)
+ build-depends:
+ base >=4.9 && <4.10,
+ bytestring >=0.10 && <0.11,
+ rtnetlink
+ else
+ buildable: False
+ main-is: examples/rtnl-link/Main.hs
+ default-language: Haskell2010
+
+executable rtnl-address
+ if flag(examples)
+ build-depends:
+ base >=4.9 && <4.10,
+ socket >=0.8 && <0.9,
+ split >=0.2 && <0.3,
+ rtnetlink
+ else
+ buildable: False
+ main-is: examples/rtnl-address/Main.hs
+ default-language: Haskell2010
+
+library
+ exposed-modules:
+ System.Linux.RTNetlink,
+ System.Linux.RTNetlink.Address,
+ System.Linux.RTNetlink.Link,
+ System.Linux.RTNetlink.Message,
+ System.Linux.RTNetlink.Packet,
+ System.Socket.Family.Netlink,
+ System.Socket.Protocol.RTNetlink
+ other-extensions:
+ CPP,
+ FlexibleContexts,
+ FlexibleInstances,
+ ForeignFunctionInterface,
+ GeneralizedNewtypeDeriving,
+ MultiParamTypeClasses,
+ OverloadedStrings,
+ RecordWildCards,
+ TypeFamilies
+ build-depends:
+ base >=4.9 && <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.5 && <0.6,
+ random >=1.1 && <1.2,
+ socket >=0.8 && <0.9,
+ unix >=2.7 && <2.8,
+ pretty-hex >=1.0 && <1.1
+ default-language: Haskell2010
+ hs-source-dirs: src
+ build-tools: hsc2hs
+ default-language: Haskell2010
+
+source-repository head
+ type: git
+ location: https://gitlab.com/formaltech/rtnetlink-hs
diff --git a/src/System/Linux/RTNetlink.hs b/src/System/Linux/RTNetlink.hs
new file mode 100644
index 0000000..39c7ec6
--- /dev/null
+++ b/src/System/Linux/RTNetlink.hs
@@ -0,0 +1,222 @@
+{-|
+Module : System.Linux.RTNetlink
+Description : Basic high-level tools for speaking RTNetlink with the Linux
+ kernel.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+
+RTNetlink is an extensible, high-level, pure Haskell interface for manipulating
+network interfaces on Linux: creating and destroying interfaces, changing and
+dumping interface settings, adding and removing addresses.
+
+The core interface of RTNetlink is the 'RTNL' monad. 'RTNL' handles the heavy
+lifting of opening and closing netlink sockets, incrementing sequence numbers,
+and getting the responses for the current sequence number behind the scenes.
+Messages not that are not responses to a sent message, such as those sent to
+group subscribers, are stored in the backlog and can be retrieved with
+'getBacklog'.
+
+The basic way to use 'RTNL' is to use the 'create', 'destroy', 'dump', and
+'change' convenience functions. If you want more control, you can use 'talk'
+and 'talk_'. Import modules like "System.Linux.RTNetlink.Link" to get access
+to prefab instances of 'Create' and 'Destroy' messages, etc. Or import
+"System.Linux.RTNetlink.Message" to get access to the core typeclasses and
+create your own messages. "System.Linux.RTNetlink.Packet" has a number of
+functions to make this easier.
+
+= Example:
+
+> {-# LANGUAGE OverloadedStrings #-}
+> module Main where
+>
+> import System.Linux.RTNetlink
+> import System.Linux.RTNetlink.Link
+> import Control.Monad (when)
+>
+> main :: IO ()
+> main = runRTNL $ do
+> let mybridge = LinkName "mybridge"
+> create (Bridge mybridge)
+> change mybridge Up
+> state <- dump mybridge
+> when (head state == Up) $
+> liftIO (putStrLn "I did it, mom!")
+> destroy mybridge
+-}
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module System.Linux.RTNetlink (
+ -- * The RTNL monad
+ RTNL()
+ , tryRTNL
+ , runRTNL
+ , runRTNLGroups
+ -- * High-level communication
+ , create
+ , destroy
+ , dump
+ , change
+ , getBacklog
+ , clearBacklog
+ -- * Lower-level communication
+ , talk
+ , talk_
+ , talkRaw
+ , toggleVerbose
+ -- * Utility functions
+ , liftIO
+ ) where
+
+import Control.Monad (when, void)
+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 Data.Either (partitionEithers)
+import Data.List (partition)
+import Data.Serialize (encode)
+import Foreign.C.Error (Errno(..), eOK, errnoToIOError)
+import Hexdump (prettyHex)
+import System.Random (randomIO)
+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.Socket.Family.Netlink
+import System.Socket.Protocol.RTNetlink
+
+data Handle = Handle
+ { _handle :: Socket Netlink Raw RTNetlink
+ , backlog :: [S.ByteString]
+ , verbose :: Bool
+ , seqNum :: SequenceNumber
+ }
+
+-- | RTNL monad to simplify netlink communication.
+newtype RTNL a = RTNL {unRTNL :: StateT Handle IO a}
+ deriving (Functor, Applicative, Monad, MonadIO, MonadState Handle)
+
+-- | 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 -> X.displayException (e::IOError))) . X.try . runRTNL
+
+-- | Run an RTNL function. RTNL functions in this module throw exclusively
+-- @IOError@s.
+runRTNL :: RTNL a -> IO a
+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
+ rethrow "bind" $ bind s =<< netlinkAddress gs
+ h <- Handle s [] False <$> randomIO
+ evalStateT (unRTNL r) h
+
+-- | Lowest-level RTNL function. Send a @BytsString@ and receive all responses
+-- and queued messages as @ByteString@s.
+--
+-- _Note:_ This function does nothing to manage sequence numbers or distinguish
+-- between responses and queued messages. Nothing will be added to the backlog.
+talkRaw :: S.ByteString -> RTNL [S.ByteString]
+talkRaw packet = do
+ Handle h b v n <- RTNL get
+ when v $ liftIO . putStrLn $ "SEND:\n" ++ prettyHex packet
+ _ <- liftIO . rethrow "send" $ send h packet mempty
+ bss <- getResponses
+ when v $ liftIO . flip mapM_ bss $ \bs -> putStrLn ("RECV:\n" ++ prettyHex bs)
+ let (rs',ms) = partition ((==n) . sequenceNumber) bss
+ RTNL . put $ Handle h (ms++b) v n
+ return rs'
+
+-- | Send any 'NLMessage' and receive a list of 'Reply's.
+--
+-- If the 'ReplyTypeNumbers' of the return type do not include NLM_ERROR, any
+-- non-zero error messages received will be thrown as @IOError@s. Responses
+-- that don't parse as the return type will be ignored.
+talk :: (Header h, Reply r) => (SequenceNumber -> NLMessage h) -> RTNL [r]
+talk m = do
+ n <- RTNL $ gets seqNum
+ bss <- talkRaw . encode $ m n
+ RTNL . modify $ \h -> h {seqNum = n + 1}
+ 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
+ _ -> return rs
+
+-- | Like 'talk', but discards non-error 'Reply's.
+talk_ :: Header h => (SequenceNumber -> NLMessage h) -> RTNL ()
+talk_ m = void (talk m :: RTNL [()])
+
+-- | Send a 'Create' message and ignore non-error 'Reply's.
+create :: Create c => c -> RTNL ()
+create = talk_ . createNLMessage
+
+-- | Send a 'Destroy' message and ignore non-error 'Reply's.
+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 = talk . requestNLMessage
+
+-- | Send a 'Change' message and ignore non-error 'Reply's.
+change :: Change id c => id -> c -> RTNL ()
+change i c = talk_ $ changeNLMessage i c
+
+-- | Get all the 'Reply's of a particular type in the backlog and queued
+-- on the socket.
+getBacklog :: Reply r => RTNL [r]
+getBacklog = do
+ b <- RTNL $ gets backlog
+ ms <- getResponses
+ let (b',rs) = partitionEithers $ fmap tryDecodeReply (ms++b)
+ RTNL . modify' $ \h -> h {backlog = b'}
+ return rs
+
+-- | Clear the backlog.
+clearBacklog :: RTNL ()
+clearBacklog = RTNL . modify' $ \h -> h {backlog = []}
+
+toggleVerbose :: RTNL ()
+toggleVerbose = RTNL . modify $ \h -> h {verbose = not $ verbose h}
+
+-- Internal
+
+-- | Return all the responses for the current sequence number.
+getResponses :: RTNL [S.ByteString]
+getResponses = do
+ Handle h b v n <- RTNL get
+ ps <- liftIO $ receiveAll h 8192 mempty
+ let ms = concatMap splitMessages ps
+ (rs,ms') = partition ((==n) . sequenceNumber) ms
+ RTNL . put $ Handle h (b ++ ms') v n
+ return rs
+
+-- | Try to decode a 'Reply'. If that fails, send the original 'S.ByteString'
+-- back.
+tryDecodeReply :: Reply r => S.ByteString -> Either S.ByteString r
+tryDecodeReply bs = maybe (Left bs) Right $ fromNLMessage' =<< decodeMaybe bs
+
+-- Util
+
+-- | Receive all packets queued on the socket without blocking.
+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
diff --git a/src/System/Linux/RTNetlink/Address.hsc b/src/System/Linux/RTNetlink/Address.hsc
new file mode 100644
index 0000000..9b5d164
--- /dev/null
+++ b/src/System/Linux/RTNetlink/Address.hsc
@@ -0,0 +1,217 @@
+{-|
+Module : System.Linux.RTNetlink.Address
+Description : ADTs for creating, destroying, modifying, and getting info
+ about layer-3 addresses.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module System.Linux.RTNetlink.Address
+ ( IfInetAddress(..)
+ , IfInet6Address(..)
+ , IfIndex(..)
+ , IfPrefix(..)
+ , AnyInterface(..)
+ , IfAddrMsg(..)
+ -- * Re-exports
+ , InetAddress
+ , Inet6Address
+ ) where
+
+import Control.Monad (guard)
+import Data.Serialize (Serialize, Get, Putter, get, put, runPut)
+import Data.Serialize (getWord32host, putWord32host, getWord8)
+import Data.Serialize (putWord8, getWord16be, putWord16be)
+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 System.Linux.RTNetlink.Message
+import System.Linux.RTNetlink.Packet
+
+#include <linux/if_addr.h>
+#include <linux/rtnetlink.h>
+#include <netinet/in.h>
+
+-- | Construct a network-byte-order representation of an 'InetAddress'.
+putInetAddress :: Putter InetAddress
+putInetAddress i = putWord8 a >> putWord8 b >> putWord8 c >> putWord8 d
+ where (a,b,c,d) = inetAddressToTuple i
+
+-- | Parse a network-byte-order representation of an 'InetAddress'.
+getInetAddress :: Get InetAddress
+getInetAddress = inetAddressFromTuple <$> getTuple
+ where getTuple = (,,,) <$> getWord8 <*> getWord8 <*> getWord8 <*> getWord8
+
+instance Message InetAddress where
+ type MessageHeader InetAddress = IfAddrMsg
+ messageAttrs address = AttributeList
+ [ Attribute #{const RTA_SRC} ipv4
+ , Attribute #{const RTA_DST} ipv4
+ ] 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
+
+-- | Construct a network-byte-order representation of an 'InetAddress'.
+putInet6Address :: Putter Inet6Address
+putInet6Address i = mapM_ putWord16be [a,b,c,d,e,f,g,h]
+ where (a,b,c,d,e,f,g,h) = inet6AddressToTuple i
+
+-- | Parse a network-byte-order representation of an 'Inet6Address'.
+getInet6Address :: Get Inet6Address
+getInet6Address = inet6AddressFromTuple <$> getTuple
+ where
+ getTuple = (,,,,,,,)
+ <$> getWord16be
+ <*> getWord16be
+ <*> getWord16be
+ <*> getWord16be
+ <*> getWord16be
+ <*> getWord16be
+ <*> getWord16be
+ <*> getWord16be
+
+instance Message Inet6Address where
+ type MessageHeader Inet6Address = IfAddrMsg
+ messageAttrs address = AttributeList
+ [ Attribute #{const RTA_SRC} ipv6
+ , Attribute #{const RTA_DST} ipv6
+ ] 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
+
+-- | Interface wildcard. Use this to get information about all layer-3
+-- interfaces.
+data AnyInterface = AnyInterface
+ deriving (Show, Eq)
+instance Message AnyInterface where
+ type MessageHeader AnyInterface = IfAddrMsg
+ messageAttrs AnyInterface = mempty
+instance Request AnyInterface where
+ requestTypeNumber = const #{const RTM_GETADDR}
+ requestNLFlags = const dumpNLFlags
+
+-- | The index of a layer-3 interface.
+newtype IfIndex = IfIndex {ifIndex :: Int}
+ deriving (Show, Eq, Num, Ord)
+instance Message IfIndex where
+ type MessageHeader IfIndex = IfAddrMsg
+ messageHeader (IfIndex ix) = IfAddrMsg 0 0 0 0 (fromIntegral ix)
+instance Reply IfIndex where
+ type ReplyHeader IfIndex = IfAddrMsg
+ replyTypeNumbers _ = [#{const RTM_NEWADDR}]
+ fromNLMessage = Just . IfIndex . fromIntegral . addrIndex . nlmHeader
+
+-- | A netmask in CIDR notation.
+newtype IfPrefix = IfPrefix {ifPrefix :: Word8}
+ deriving (Show, Eq, Num, Ord)
+instance Message IfPrefix where
+ type MessageHeader IfPrefix = IfAddrMsg
+ messageHeader (IfPrefix p) = IfAddrMsg 0 p 0 0 0
+instance Reply IfPrefix where
+ type ReplyHeader IfPrefix = IfAddrMsg
+ replyTypeNumbers _ = [#{const RTM_NEWADDR}]
+ fromNLMessage = Just . IfPrefix . addrPrefix . nlmHeader
+
+-- | An ipv4 address and netmask associated with an interface.
+data IfInetAddress = IfInetAddress
+ { ifInetAddress :: InetAddress -- ^ The ip4v address itself.
+ , ifInetPrefix :: IfPrefix -- ^ The netmask in CIDR notation.
+ , 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}
+instance Reply IfInetAddress where
+ type ReplyHeader IfInetAddress = IfAddrMsg
+ replyTypeNumbers _ = [#{const RTM_NEWADDR}]
+ fromNLMessage m =
+ IfInetAddress <$> fromNLMessage m <*> fromNLMessage m <*> fromNLMessage m
+
+-- | An ipv6 address and netmask associated with an interface.
+data IfInet6Address = IfInet6Address
+ { ifInet6Address :: Inet6Address -- ^ The ip4v address itself.
+ , ifInet6Prefix :: IfPrefix -- ^ The netmask in CIDR notation.
+ , 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}
+instance Reply IfInet6Address where
+ type ReplyHeader IfInet6Address = IfAddrMsg
+ replyTypeNumbers _ = [#{const RTM_NEWADDR}]
+ fromNLMessage m =
+ IfInet6Address <$> fromNLMessage m <*> fromNLMessage m <*> fromNLMessage m
+
+-- | The header corresponding to address messages, based on 'struct ifaddrmsg'
+-- from 'linux/if_addr.h'.
+data IfAddrMsg = IfAddrMsg
+ { addrFamily :: Word8 -- ^ Address family (AF_* from @sys/socket.h@)
+ , addrPrefix :: Word8 -- ^ CIDR netmask for this address.
+ , addrFlags :: Word8 -- ^ Operational flags for this address.
+ , addrScope :: Word8 -- ^ Address scope.
+ , addrIndex :: Word32 -- ^ Index of the associated interface.
+ } deriving (Show, Eq)
+instance Sized IfAddrMsg where
+ size = const #{const sizeof(struct ifaddrmsg)}
+instance Serialize IfAddrMsg where
+ put IfAddrMsg {..} = do
+ putWord8 addrFamily
+ putWord8 addrPrefix
+ putWord8 addrFlags
+ putWord8 addrScope
+ putWord32host addrIndex
+ get = IfAddrMsg
+ <$> getWord8
+ <*> getWord8
+ <*> getWord8
+ <*> getWord8
+ <*> getWord32host
+instance Header IfAddrMsg where
+ emptyHeader = IfAddrMsg 0 0 0 0 0
diff --git a/src/System/Linux/RTNetlink/Link.hsc b/src/System/Linux/RTNetlink/Link.hsc
new file mode 100644
index 0000000..aa0ca02
--- /dev/null
+++ b/src/System/Linux/RTNetlink/Link.hsc
@@ -0,0 +1,172 @@
+{-|
+Module : System.Linux.RTNetlink.Link
+Description : ADTs for creating, destroying, modifying, and getting info
+ about links.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module System.Linux.RTNetlink.Link where
+
+import Data.Bits ((.&.))
+import Data.Int (Int32)
+import Data.Monoid ((<>))
+import Data.Serialize
+import Data.Word (Word8, Word32)
+import qualified Data.ByteString as S
+
+import System.Linux.RTNetlink.Packet
+import System.Linux.RTNetlink.Message
+
+#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)
+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}
+instance Request LinkIndex where
+ requestTypeNumber = const #{const RTM_GETLINK}
+instance Reply LinkIndex where
+ type ReplyHeader LinkIndex = IfInfoMsg
+ replyTypeNumbers = const [#{const RTM_NEWLINK}]
+ fromNLMessage = Just . LinkIndex . fromIntegral . ifIndex . nlmHeader
+
+-- | A link identified by its name.
+newtype LinkName = LinkName S.ByteString
+ deriving (Show, Eq)
+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}
+instance Request LinkName where
+ requestTypeNumber = const #{const RTM_GETLINK}
+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
+
+-- | 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
+instance Serialize LinkEther where
+ put (LinkEther a b c d e f) = put a >> put b >> put c >> put d >> put e >> put 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]
+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
+
+-- | Link wildcard.
+data AnyLink = AnyLink
+ deriving (Show, Eq)
+instance Message AnyLink where
+ type MessageHeader AnyLink = IfInfoMsg
+instance Request AnyLink where
+ requestTypeNumber = const #{const RTM_GETLINK}
+ requestNLFlags = const dumpNLFlags
+
+-- | A dummy interface.
+newtype Dummy = Dummy LinkName
+ deriving (Show, Eq)
+instance Message Dummy where
+ type MessageHeader Dummy = IfInfoMsg
+ messageHeader (Dummy name) = messageHeader name
+ messageAttrs (Dummy name) = messageAttrs name <> AttributeList
+ [ AttributeNest #{const IFLA_LINKINFO}
+ [ cStringAttr #{const IFLA_INFO_KIND} "dummy" ]
+ ]
+instance Create Dummy where
+ createTypeNumber = const #{const RTM_NEWLINK}
+
+-- | A bridge interface.
+newtype Bridge = Bridge LinkName
+ 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}
+
+-- | 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
+ 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
+instance Change LinkIndex 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
+
+-- | 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)}
+instance Serialize IfInfoMsg where
+ put IfInfoMsg {..} = do
+ putWord8 #{const AF_UNSPEC}
+ putWord8 0
+ putWord16host 0
+ putInt32host ifIndex
+ putWord32host ifFlags
+ putWord32host ifChange
+ get = do
+ skip 4
+ ifIndex <- getInt32le
+ ifFlags <- getWord32host
+ ifChange <- getWord32host
+ return $ IfInfoMsg {..}
+instance Header IfInfoMsg where
+ emptyHeader = IfInfoMsg 0 0 0
diff --git a/src/System/Linux/RTNetlink/Message.hsc b/src/System/Linux/RTNetlink/Message.hsc
new file mode 100644
index 0000000..8749481
--- /dev/null
+++ b/src/System/Linux/RTNetlink/Message.hsc
@@ -0,0 +1,209 @@
+{-|
+Module : System.Linux.RTNetlink.Message
+Description : High-level classes and ADTs for constructing netlink messages.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+
+A netlink packet contains a top-level header (@struct nlmsghdr@ from
+@linux/netlink.h@), a second-level header that depends on the message type
+(e.g., @struct ifinfomsg@ from @linux/if_link.h@), and a possibly nested
+collection of attributes (see "System.Linux.RTNetlink.Packet").
+
+The way to create a netlink packet in RTNetlink is to instantiate either the
+'Message' or the 'Reply' class, which entails specifying what the header type
+should be. You can then instantiate any of the 'Create', 'Destroy', 'Change',
+or 'Request' classes to indicate which kinds of actions the message can be used
+to perform.
+-}
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+module System.Linux.RTNetlink.Message where
+
+import Control.Monad (guard)
+import Data.Monoid (mempty)
+import Data.Int (Int32)
+import Data.List (nub)
+import Data.Serialize
+import Data.Word (Word16, Word32)
+import qualified Data.ByteString as S
+import qualified Foreign.C.Error as C
+
+import System.Linux.RTNetlink.Packet
+
+#include <linux/netlink.h>
+
+-- | Sequence number for an 'NlMsgHdr'.
+type SequenceNumber = Word32
+
+-- | Get the sequence number of a message started by an 'NLMsgHdr'.
+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'.
+
+-- High-level representation of a netlink packet.
+data NLMessage header = NLMessage
+ { nlmHeader :: header -- ^ The secondary header, determined by type.
+ , nlmAttrs :: AttributeList -- ^ The message's 'Attribute's.
+ , nlmType :: TypeNumber -- ^ Top-level message type.
+ , nlmFlags :: NLFlags -- ^ Top-level message flags.
+ , nlmSeqNum :: SequenceNumber -- ^ Message sequence number.
+ } deriving (Show, Eq)
+instance Sized header => Sized (NLMessage header) where
+ size NLMessage {..} = size nlmAttrs + size nlmHeader + #{const sizeof(struct nlmsghdr)}
+instance (Sized header, Serialize header) => Serialize (NLMessage header) where
+ put m@(NLMessage {..}) = do
+ put $ NLMsgHdr (size m) nlmType nlmFlags nlmSeqNum 0
+ put $ nlmHeader
+ put $ nlmAttrs
+ get = do
+ NLMsgHdr {..} <- get
+ header <- get
+ attributes <- get
+ return $ NLMessage header attributes nlMsgType nlMsgFlags nlMsgSeqNum
+
+-- | The header of an error sent in response to a bad netlink message. The
+-- numeric values correspond to negated values from "Foreign.C.Error". Try
+-- running @man 3 errno@ for more information.
+data NLMsgErr = NLMsgErr
+ { nleError :: Int32 -- ^ Negated numeric error code.
+ , nleHeader :: NLMsgHdr -- ^ The header of the offending message.
+ } deriving (Show, Eq)
+instance Sized NLMsgErr where
+ size = const #{const sizeof(struct nlmsgerr)}
+instance Serialize NLMsgErr where
+ put NLMsgErr {..} = putInt32host nleError >> put nleHeader
+ get = NLMsgErr <$> getInt32le <*> get
+instance Header NLMsgErr where
+ emptyHeader = NLMsgErr 0 $ NLMsgHdr 0 0 0 0 0
+
+-- | Class of things that can be used as second-level netlink headers.
+class (Show h, Eq h, Sized h, Serialize h) => Header h where
+ -- | Default header for a message, if none is specified.
+ emptyHeader :: h
+instance Header () where
+ emptyHeader = ()
+
+-- | 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)
+ {-# MINIMAL #-}
+
+-- | 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 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 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 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
+ -- | 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}
+
+-- | Class of things that can be received.
+class Header (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
+ -- | Like 'fromNLMessage', but checks to make sure the top-level type
+ -- number is in 'replyTypeNumbers', first.
+ {-# MINIMAL replyTypeNumbers, 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' :: Reply r => NLMessage (ReplyHeader r) -> Maybe r
+fromNLMessage' m = do
+ r <- fromNLMessage m
+ guard $ nlmType m `elem` replyTypeNumbers r
+ 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
new file mode 100644
index 0000000..7f273d8
--- /dev/null
+++ b/src/System/Linux/RTNetlink/Packet.hsc
@@ -0,0 +1,196 @@
+{-|
+Module : System.Linux.RTNetlink.Packet
+Description : Low-level typeclasses, functions and ADTs for making netlink
+ packets.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+-}
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE RecordWildCards #-}
+module System.Linux.RTNetlink.Packet (
+ -- * Low-level headers
+ NLMsgHdr(..)
+ , nlMsgHdrIsError
+ , splitMessages
+ -- * Attributes
+ , Attribute(..)
+ , AttributeList(..)
+ , AttributeType
+ , attributeType
+ , attributeData
+ , findAttribute
+ , cStringAttr
+ , word32Attr
+ , word16Attr
+ -- * Sized data
+ , Sized(..)
+ , putAligned
+ ) where
+
+import Control.Monad (guard)
+import Control.Monad.Loops (unfoldM)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Maybe (runMaybeT)
+import Data.Bits ((.|.), (.&.), xor)
+import Data.List (unfoldr, find)
+import Data.Serialize
+import Data.Word (Word16,Word32)
+import Data.Maybe (listToMaybe)
+import qualified Data.ByteString as S
+
+#include <linux/netlink.h>
+
+-- | ADT corresponding to @struct nlmsghdr@ from @linux/netlink.h@.
+data NLMsgHdr = NLMsgHdr
+ { nlMsgLength :: Word32 -- ^ Total message length (@nlmsg_len@).
+ , nlMsgType :: Word16 -- ^ Message type (@nlmsg_type@).
+ , nlMsgFlags :: Word16 -- ^ Top-level flags (@nlmsg_flags@).
+ , nlMsgSeqNum :: Word32 -- ^ Sequence number (@nlmsg_seq@).
+ , nlMsgPid :: Word32 -- ^ Destination address (@nlmsg_pid@).
+ } deriving (Show, Eq)
+instance Sized NLMsgHdr where
+ size = const #{const sizeof(struct nlmsghdr)}
+instance Serialize NLMsgHdr where
+ put NLMsgHdr {..} = do
+ putWord32host nlMsgLength
+ putWord16host nlMsgType
+ putWord16host nlMsgFlags
+ putWord32host nlMsgSeqNum
+ putWord32host nlMsgPid
+ get = NLMsgHdr
+ <$> getWord32host
+ <*> getWord16host
+ <*> getWord16host
+ <*> getWord32host
+ <*> getWord32host
+
+-- | Get the type of a message started by an 'NLMsgHdr'.
+nlMsgHdrType :: S.ByteString -> Word16
+nlMsgHdrType = either (const 0) nlMsgType . decode
+
+-- | Return @True@ iff the message is an error, assuming the provided
+-- 'S.ByteString' is headed by an 'NLMsgHdr'.
+nlMsgHdrIsError :: S.ByteString -> Bool
+nlMsgHdrIsError = (== #{const NLMSG_ERROR}) . nlMsgHdrType
+
+-- | Get the size of a message started by an 'NLMsgHdr'.
+nlMsgHdrSize :: Integral n => S.ByteString -> n
+nlMsgHdrSize = either (const 0) (fromIntegral . nlMsgLength) . decode
+
+-- | Split a ByteString into multiple messages using their 'NLMsgHdr's.
+splitMessages :: S.ByteString -> [S.ByteString]
+splitMessages = unfoldr $ \bs -> do
+ let sz = nlMsgHdrSize bs
+ guard $ sz > 0 && sz <= S.length bs
+ return . S.splitAt sz $ bs
+
+-- | Typeclass for data with a defined size. This lets us get sizes to use for
+-- constructing headers.
+class Sized s where
+ -- | Size of data.
+ 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
+ {-# MINIMAL size #-}
+instance Sized () where
+ size = const 0
+instance Sized S.ByteString where
+ size = fromIntegral . S.length
+
+-- | Pad a 'S.ByteString' to a given alignment.
+putAligned :: Integral a => a -> Putter S.ByteString
+putAligned a bs = do
+ putByteString $ bs
+ putByteString $ S.replicate (fromIntegral $ sizeAligned a bs - size bs) 0
+
+-- | Type identifier for an 'Attribute'.
+type AttributeType = Word16
+
+-- | ADT representing a possibly nested netlink attribute.
+data Attribute
+ = Attribute AttributeType S.ByteString -- ^ Simple attribute.
+ | AttributeNest AttributeType [Attribute] -- ^ Nested attribute.
+ deriving (Show, Eq)
+instance Sized Attribute where
+ size (Attribute _ bs) = #{const sizeof(struct nlattr)} + size bs
+ size (AttributeNest _ as) = #{const sizeof(struct nlattr)} + size (AttributeList as)
+instance Serialize Attribute where
+ put a = do
+ putWord16host $ size a
+ case a of
+ Attribute t bs -> do
+ putWord16host t
+ putAligned (4::Integer) bs
+ AttributeNest t as -> do
+ putWord16host $ t .|. #{const NLA_F_NESTED}
+ put $ AttributeList as
+ 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
+ if nla_type .&. #{const NLA_F_NESTED} == 0
+ then return $ Attribute nla_type nla_data
+ else do
+ AttributeList as <- get
+ return $ AttributeNest (nla_type `xor` #{const NLA_F_NESTED}) as
+
+-- | A collection of netlink attributes.
+newtype AttributeList = AttributeList [Attribute]
+ deriving (Show, Eq)
+instance Sized AttributeList where
+ size (AttributeList as) = sum $ fmap (sizeAligned 4) as
+instance Serialize AttributeList where
+ put (AttributeList as) = mapM_ put as
+ get = AttributeList <$> unfoldM getMaybeAttribute
+ where
+ getMaybeAttribute = runMaybeT $ do
+ r <- lift $ fmap fromIntegral remaining
+ guard $ r >= #{const sizeof(struct nlattr)}
+ 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
+
+-- | 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.
+word32Attr :: AttributeType -> Word32 -> Attribute
+word32Attr t = Attribute t . runPut . putWord32host
+
+-- | Construct an 'Attribute' with a 16-bit word as data.
+word16Attr :: AttributeType -> Word16 -> Attribute
+word16Attr t = Attribute t . runPut . putWord16host
+
+-- | Get the type of an 'Attribute'.
+attributeType :: Attribute -> AttributeType
+attributeType (Attribute t _) = t
+attributeType (AttributeNest t _) = t
+
+-- | Get the data from a simple 'Attribute'.
+attributeData :: Attribute -> Maybe S.ByteString
+attributeData (Attribute _ bs) = Just bs
+attributeData (AttributeNest _ _) = Nothing
+
+-- | Search for an 'Attribute' in a possibly nested list using the
+-- 'AttributeType' to look for at each level.
+findAttribute :: [AttributeType] -> AttributeList -> Maybe Attribute
+findAttribute ts (AttributeList as) = do
+ t <- listToMaybe ts
+ a <- find ((==t) . attributeType) as
+ case tail ts of
+ [] -> return a
+ ts' -> case a of
+ Attribute _ _ -> Nothing
+ AttributeNest _ as' -> findAttribute ts' (AttributeList as')
diff --git a/src/System/Socket/Family/Netlink.hsc b/src/System/Socket/Family/Netlink.hsc
new file mode 100644
index 0000000..ea06510
--- /dev/null
+++ b/src/System/Socket/Family/Netlink.hsc
@@ -0,0 +1,95 @@
+{-|
+Module : System.Socket.Family.Netlink
+Description : Extends System.Socket with the netlink socket family.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+-}
+{-# OPTIONS_HADDOCK prune #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeFamilies #-}
+module System.Socket.Family.Netlink
+ ( Netlink
+ , SocketAddress()
+ , NetlinkGroup(..)
+ , netlinkAddress
+ , netlinkAddressPid
+ , netlinkKernel
+ ) where
+
+import Data.Bits ((.|.))
+import Data.Serialize (Serialize(..), encode, decode)
+import Data.Serialize (putWord16host, putWord32host, getWord16host, getWord32host)
+import Foreign.Ptr (castPtr)
+import Foreign.Storable (Storable(..))
+import GHC.Word (Word32)
+import System.Posix (getProcessID)
+import qualified Data.ByteString.Char8 as S
+
+import System.Socket
+
+#include <linux/netlink.h>
+#include <sys/socket.h>
+
+-- | Netlink socket family.
+data Netlink
+instance Family Netlink where
+ -- | Netlink address corresponding to @struct sockaddr_nl@ from
+ -- @linux/netlink.h@.
+ data SocketAddress Netlink = SocketAddressNetlink
+ { netlinkPid :: Word32 -- ^ Netlink source address.
+ , netlinkGroups :: Word32 -- ^ Group subscription mask.
+ } deriving (Read, Show, Eq)
+ familyNumber _ = #{const AF_NETLINK}
+instance Serialize (SocketAddress Netlink) where
+ put nl = do
+ putWord16host $ #{const AF_NETLINK}
+ putWord16host $ 0
+ putWord32host $ netlinkPid nl
+ putWord32host $ netlinkGroups nl
+ putWord32host $ 0
+ get = do
+ _nl_family <- getWord16host
+ _nl_pad16 <- getWord16host
+ nl_pid <- getWord32host
+ nl_groups <- getWord32host
+ _nl_pad32 <- getWord32host
+ return $ SocketAddressNetlink nl_pid nl_groups
+instance Storable (SocketAddress Netlink) where
+ sizeOf _ = #{const sizeof(struct sockaddr_nl)}
+ alignment _ = 4
+ peek ptr = do
+ bs <- S.pack <$> mapM (peekByteOff ptr) [0..15]
+ case decode bs of
+ Left e -> fail e
+ Right nl -> return nl
+ poke ptr nl =
+ let pokePtr = pokeByteOff $ castPtr ptr
+ in mapM_ (uncurry pokePtr) $ [0..15] `zip` S.unpack (encode nl)
+
+-- | Class of netlink groups. This is extensible because groups vary by netlink
+-- subsystem.
+class NetlinkGroup g where
+ netlinkGroupNumber :: g -> Word32
+
+-- | Construct a group mask from a list of groups.
+netlinkGroupMask :: NetlinkGroup g => [g] -> Word32
+netlinkGroupMask = foldr (.|.) 0 . fmap netlinkGroupNumber
+
+-- | Construct a netlink socket from a collection of groups.
+netlinkAddress :: NetlinkGroup g => [g] -> IO (SocketAddress Netlink)
+netlinkAddress gs = do
+ pid <- fromIntegral <$> getProcessID
+ return $ SocketAddressNetlink pid (netlinkGroupMask gs)
+
+-- | Like 'netlinkAddress', but with a configurable source address.
+netlinkAddressPid :: NetlinkGroup g => Word32 -> [g] -> SocketAddress Netlink
+netlinkAddressPid pid = SocketAddressNetlink pid . netlinkGroupMask
+
+-- | The kernel's address.
+netlinkKernel :: SocketAddress Netlink
+netlinkKernel = SocketAddressNetlink 0 0
diff --git a/src/System/Socket/Protocol/RTNetlink.hsc b/src/System/Socket/Protocol/RTNetlink.hsc
new file mode 100644
index 0000000..89b8b6d
--- /dev/null
+++ b/src/System/Socket/Protocol/RTNetlink.hsc
@@ -0,0 +1,89 @@
+{-|
+Module : System.Socket.Protocol.RTNetlink
+Description : Extends System.Socket with the ROUTE_NETLINK socket protocol.
+Copyright : (c) Formaltech Inc. 2017
+License : BSD3
+Maintainer : protob3n@gmail.com
+Stability : experimental
+Portability : Linux
+-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
+module System.Socket.Protocol.RTNetlink
+ ( RTNetlink
+ , RTNetlinkGroup(..)
+ ) where
+
+import Data.Bits (shift)
+
+import System.Socket (Protocol(..))
+import System.Socket.Family.Netlink (NetlinkGroup(..))
+
+#include <linux/rtnetlink.h>
+
+-- | Protocol for the ROUTE_NETLINK subsystem of netlink.
+data RTNetlink
+instance Protocol RTNetlink where
+ protocolNumber _ = 0
+
+-- | Multicast groups the user of an RTNetlink socket can subscribe to.
+data RTNetlinkGroup
+ = RTNetlinkGroupNone
+ | RTNetlinkGroupLink
+ | RTNetlinkGroupNotify
+ | RTNetlinkGroupNeighbor
+ | RTNetlinkGroupTC
+ | RTNetlinkGroupIPv4IfAddr
+ | RTNetlinkGroupIPv4MRoute
+ | RTNetlinkGroupIPv4Route
+ | RTNetlinkGroupIPv4Rule
+ | RTNetlinkGroupIPv6IfAddr
+ | RTNetlinkGroupIPv6MRoute
+ | RTNetlinkGroupIPv6Route
+ | RTNetlinkGroupIPv6IfInfo
+ | RTNetlinkGroupDECnetIfAddr
+ | RTNetlinkGroupDECnetRoute
+ | RTNetlinkGroupDECnetRule
+ | RTNetlinkGroupIPv6Prefix
+ | RTNetlinkGroupIPv6Rule
+ | RTNetlinkGroupNDUserOpt
+ | RTNetlinkGroupPhonetIfAddr
+ | RTNetlinkGroupPhonetRoute
+ | RTNetlinkGroupDCB
+ | RTNetlinkGroupIPv4Netconf
+ | RTNetlinkGroupIPv6Netconf
+ | RTNetlinkGroupMDB
+ | RTNetlinkGroupMPLSRoute
+ | RTNetlinkGroupNSID
+ deriving (Read, Show, Eq)
+instance NetlinkGroup RTNetlinkGroup where
+ netlinkGroupNumber g = shift 1 $ bit g - 1
+
+bit :: RTNetlinkGroup -> Int
+bit RTNetlinkGroupNone = #const RTNLGRP_NONE
+bit RTNetlinkGroupLink = #const RTNLGRP_LINK
+bit RTNetlinkGroupNotify = #const RTNLGRP_NOTIFY
+bit RTNetlinkGroupNeighbor = #const RTNLGRP_NEIGH
+bit RTNetlinkGroupTC = #const RTNLGRP_TC
+bit RTNetlinkGroupIPv4IfAddr = #const RTNLGRP_IPV4_IFADDR
+bit RTNetlinkGroupIPv4MRoute = #const RTNLGRP_IPV4_MROUTE
+bit RTNetlinkGroupIPv4Route = #const RTNLGRP_IPV4_ROUTE
+bit RTNetlinkGroupIPv4Rule = #const RTNLGRP_IPV4_RULE
+bit RTNetlinkGroupIPv6IfAddr = #const RTNLGRP_IPV6_IFADDR
+bit RTNetlinkGroupIPv6MRoute = #const RTNLGRP_IPV6_MROUTE
+bit RTNetlinkGroupIPv6Route = #const RTNLGRP_IPV6_ROUTE
+bit RTNetlinkGroupIPv6IfInfo = #const RTNLGRP_IPV6_IFINFO
+bit RTNetlinkGroupDECnetIfAddr = #const RTNLGRP_DECnet_IFADDR
+bit RTNetlinkGroupDECnetRoute = #const RTNLGRP_DECnet_ROUTE
+bit RTNetlinkGroupDECnetRule = #const RTNLGRP_DECnet_RULE
+bit RTNetlinkGroupIPv6Prefix = #const RTNLGRP_IPV6_PREFIX
+bit RTNetlinkGroupIPv6Rule = #const RTNLGRP_IPV6_RULE
+bit RTNetlinkGroupNDUserOpt = #const RTNLGRP_ND_USEROPT
+bit RTNetlinkGroupPhonetIfAddr = #const RTNLGRP_PHONET_IFADDR
+bit RTNetlinkGroupPhonetRoute = #const RTNLGRP_PHONET_ROUTE
+bit RTNetlinkGroupDCB = #const RTNLGRP_DCB
+bit RTNetlinkGroupIPv4Netconf = #const RTNLGRP_IPV4_NETCONF
+bit RTNetlinkGroupIPv6Netconf = #const RTNLGRP_IPV6_NETCONF
+bit RTNetlinkGroupMDB = #const RTNLGRP_MDB
+bit RTNetlinkGroupMPLSRoute = #const RTNLGRP_MPLS_ROUTE
+bit RTNetlinkGroupNSID = #const RTNLGRP_NSID
diff --git a/tests/Main.hs b/tests/Main.hs
new file mode 100644
index 0000000..1b0344f
--- /dev/null
+++ b/tests/Main.hs
@@ -0,0 +1,216 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Control.Exception (bracket)
+import System.Socket.Family.Inet (inetAddressFromTuple)
+import System.Socket.Family.Inet6 (inet6AddressFromTuple)
+import System.Posix (getEffectiveUserID)
+
+import Test.Hspec
+
+import System.Linux.RTNetlink
+import System.Linux.RTNetlink.Link
+import System.Linux.RTNetlink.Address
+
+loopback :: LinkName
+loopback = LinkName "lo"
+
+testLink :: LinkName
+testLink = LinkName "foobazblargle"
+
+notALink :: LinkName
+notALink = LinkName "notalink"
+
+localhost4 :: InetAddress
+localhost4 = inetAddressFromTuple (127,0,0,1)
+
+localhost6 :: Inet6Address
+localhost6 = inet6AddressFromTuple (0,0,0,0,0,0,0,1)
+
+testAddress4 :: InetAddress
+testAddress4 = inetAddressFromTuple (169,254,42,42)
+
+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
+
+withTestInterface :: IO a -> IO a
+withTestInterface = bracket createTestInterface (const destroyTestLink) . const
+
+createTestLink :: IO ()
+createTestLink = runRTNL (create $ Bridge testLink)
+
+destroyTestLink :: IO ()
+destroyTestLink = runRTNL $ destroy testLink
+
+withTestLink :: IO a -> IO a
+withTestLink = bracket createTestLink (const destroyTestLink) . const
+
+main :: IO ()
+main = do
+ haveRoot <- (0 ==) <$> getEffectiveUserID
+ 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"
+
+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 indices" $ do
+ runRTNL (dump loopback) `shouldReturn` [LinkIndex 1]
+
+ it "gets link states" $ do
+ runRTNL (dump loopback) `shouldReturn` [Up]
+
+ context "when given a non-existent link name" $ do
+ it "throws an exception" $ do
+ 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
+
+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 given a bad interface index" $ do
+ it "throws an exception" $ do
+ indices <- runRTNL $ dump AnyInterface
+ let badIx = maximum indices + 1
+ prefix = IfPrefix 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
+ interface = IfInetAddress testAddress4 badPrefix index
+ runRTNL (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 given a non-existent link name" $ do
+ it "throws an exception" $ do
+ runRTNL (change notALink Up) `shouldThrow` anyIOException
+
+testDestroy :: Spec
+testDestroy = do
+ context "when operating on layer-2 links" $ before_ createTestLink $ do
+ it "destroys links by name" $ do
+ links <- runRTNL $ do
+ destroy testLink
+ dump AnyLink
+ links `shouldSatisfy` not . elem testLink
+
+ 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
+ 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