rtnetlink (empty) → 0.1.0.0
raw patch · 14 files changed
+1667/−0 lines, 14 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, hspec, monad-loops, mtl, pretty-hex, random, rtnetlink, socket, split, transformers, unix
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- examples/rtnl-address/Main.hs +46/−0
- examples/rtnl-link/Main.hs +68/−0
- rtnetlink.cabal +100/−0
- src/System/Linux/RTNetlink.hs +222/−0
- src/System/Linux/RTNetlink/Address.hsc +217/−0
- src/System/Linux/RTNetlink/Link.hsc +172/−0
- src/System/Linux/RTNetlink/Message.hsc +209/−0
- src/System/Linux/RTNetlink/Packet.hsc +196/−0
- src/System/Socket/Family/Netlink.hsc +95/−0
- src/System/Socket/Protocol/RTNetlink.hsc +89/−0
- tests/Main.hs +216/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for rtnetlink++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/rtnl-address/Main.hs view
@@ -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"
+ examples/rtnl-link/Main.hs view
@@ -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"
+ rtnetlink.cabal view
@@ -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
+ src/System/Linux/RTNetlink.hs view
@@ -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
+ src/System/Linux/RTNetlink/Address.hsc view
@@ -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
+ src/System/Linux/RTNetlink/Link.hsc view
@@ -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
+ src/System/Linux/RTNetlink/Message.hsc view
@@ -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
+ src/System/Linux/RTNetlink/Packet.hsc view
@@ -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')
+ src/System/Socket/Family/Netlink.hsc view
@@ -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
+ src/System/Socket/Protocol/RTNetlink.hsc view
@@ -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
+ tests/Main.hs view
@@ -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