diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /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 --- /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 --- /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 --- /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 / index \n" + ++ "\t| destroy ipv4 / index \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 --- /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 | index )\n" + ++ "\t| dump [(name | index ) state]\n" + ++ "\t| change (name | index ) (up | down)\n" + ++ "\n" + ++ "CREATE\n" + ++ "\t= TYPE 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 --- /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 +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 --- /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 --- /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 +#include +#include + +-- | 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 --- /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 +#include +#include + +-- | 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 --- /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 + +-- | 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 --- /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 + +-- | 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 --- /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 +#include + +-- | 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 --- /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 + +-- | 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 --- /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