{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

{-|
Module      : System.Linux.Netlink.Route
Description : The implementation for netlinks route family
Maintainer  : ongy
Stability   : testing
Portability : Linux

This module provides wrappers for functionality provided by the netlink route family
-}
module System.Linux.Netlink.Route
    (
      Packet
    , RoutePacket

    , getRoutePackets
    , Message(..)
    
    , getLinkAddress
    , getLinkBroadcast
    , getLinkName
    , getLinkMTU
    , getLinkQDisc
    , getLinkTXQLen
    , getIFAddr
    , getLLAddr
    , getDstAddr

    , putLinkAddress
    , putLinkBroadcast
    , putLinkName
    , putLinkMTU
    , putLinkQDisc
    , putLinkTXQLen
    ) where

import Prelude hiding (length, lookup, init)

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative ((<$>), (<*>))
#endif

import qualified Data.ByteString as BS (length)
import Data.ByteString.Char8 (ByteString, append, init, pack, unpack)
import Data.Char (chr, ord)
import Data.List (intersperse)
import Data.Map (insert, lookup, toList)
import Data.Serialize.Get
import Data.Serialize.Put
import Data.Word (Word8, Word16, Word32)
import Data.Int (Int32)

import System.Linux.Netlink.Constants
import System.Linux.Netlink
import System.Linux.Netlink.Helpers
import System.Linux.Netlink.Route.LinkStat

-- |The static data for route messages
data Message = NLinkMsg
    {
      Message -> LinkType
interfaceType  :: LinkType
    , Message -> Word32
interfaceIndex :: Word32
    , Message -> Word32
interfaceFlags :: Word32 -- ^ System.Linux.Netlink.Constants.fIFF_* flags
    }
             | NAddrMsg
    {
      Message -> AddressFamily
addrFamily         :: AddressFamily
    , Message -> Word8
addrMaskLength     :: Word8
    , Message -> Word8
addrFlags          :: Word8
    , Message -> Word8
addrScope          :: Word8
    , Message -> Word32
addrInterfaceIndex :: Word32
    } 
             | NNeighMsg
    { Message -> Word8
neighFamily  :: Word8 -- ^ One of System.Linux.Netlink.Constants.eAF_* values
    , Message -> Int32
neighIfindex :: Int32
    , Message -> Word16
neighState   :: Word16 -- ^ System.Linux.Netlink.Constants.fNUD_* flags
    , Message -> Word8
neighFlags   :: Word8
    , Message -> Word8
neighType    :: Word8
    } deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq)

instance Show Message where
  show :: Message -> String
show (NLinkMsg t :: LinkType
t i :: Word32
i f :: Word32
f) =
    "LinkMessage. Type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LinkType -> String
forall a. (Num a, Show a, Eq a) => a -> String
showLinkType LinkType
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Index: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Flags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
f
  show (NAddrMsg f :: AddressFamily
f l :: Word8
l fl :: Word8
fl s :: Word8
s i :: Word32
i) =
    "AddrMessage. Family: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AddressFamily -> String
forall a. Show a => a -> String
show AddressFamily
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", MLength: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Flags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ 
    Word8 -> String
forall a. Show a => a -> String
show Word8
fl String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Index: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
i
  show (NNeighMsg f :: Word8
f i :: Int32
i s :: Word16
s fl :: Word8
fl t :: Word8
t) =
    "NeighMessage. Family: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Index: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int32 -> String
forall a. Show a => a -> String
show Int32
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", State: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ 
    Word16 -> String
forall a. Show a => a -> String
show Word16
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Flags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
fl String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
t

instance Convertable Message where
  getGet :: MessageType -> Get Message
getGet = MessageType -> Get Message
getMessage
  getPut :: Message -> Put
getPut = Message -> Put
putMessage

-- |Typedef for route messages
type RoutePacket = Packet Message

showRouteHeader :: Header -> String
showRouteHeader :: Header -> String
showRouteHeader (Header t :: MessageType
t f :: Word16
f s :: Word32
s p :: Word32
p) =
  "Type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MessageType -> String
forall a. (Num a, Show a, Eq a) => a -> String
showMessageType MessageType
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Flags: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Word16 -> String
forall a. Show a => a -> String
show Word16
f) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Seq: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", Pid: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
p


instance Show RoutePacket where
  showList :: [RoutePacket] -> ShowS
showList xs :: [RoutePacket]
xs = (([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ([RoutePacket] -> [String]) -> [RoutePacket] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse "===\n" ([String] -> [String])
-> ([RoutePacket] -> [String]) -> [RoutePacket] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RoutePacket -> String) -> [RoutePacket] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map RoutePacket -> String
forall a. Show a => a -> String
show ([RoutePacket] -> String) -> [RoutePacket] -> String
forall a b. (a -> b) -> a -> b
$[RoutePacket]
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++)
  show :: RoutePacket -> String
show (Packet hdr :: Header
hdr cus :: Message
cus attrs :: Attributes
attrs) =
    "RoutePacket: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Header -> String
showRouteHeader Header
hdr String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    Message -> String
forall a. Show a => a -> String
show Message
cus String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    --TODO: is this the case every time? maybe match on other to get which enum to use
    "Attrs: \n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((Int, ByteString) -> String) -> [(Int, ByteString)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (MessageType -> (Int, ByteString) -> String
showMsgAttr (Header -> MessageType
messageType Header
hdr)) (Attributes -> [(Int, ByteString)]
forall k a. Map k a -> [(k, a)]
toList Attributes
attrs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  show p :: RoutePacket
p = RoutePacket -> String
forall a. Show a => Packet a -> String
showPacket RoutePacket
p


showMsgAttr :: MessageType -> (Int, ByteString) -> String
showMsgAttr :: MessageType -> (Int, ByteString) -> String
showMsgAttr msgType :: MessageType
msgType
  | MessageType
msgType MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_NEWNEIGH = (Int, ByteString) -> String
showNeighAttr
  | MessageType
msgType MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_DELNEIGH = (Int, ByteString) -> String
showNeighAttr
  | MessageType
msgType MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_GETNEIGH = (Int, ByteString) -> String
showNeighAttr
  | Bool
otherwise = (Int, ByteString) -> String
showLinkAttr --default to original behavior

showNeighAttr :: (Int, ByteString) -> String
showNeighAttr :: (Int, ByteString) -> String
showNeighAttr = (Int -> String) -> (Int, ByteString) -> String
showAttr Int -> String
forall a. (Num a, Show a, Eq a) => a -> String
showNeighAttrType

showLinkAttr :: (Int, ByteString) -> String
showLinkAttr :: (Int, ByteString) -> String
showLinkAttr (i :: Int
i, v :: ByteString
v)
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eIFLA_STATS64 = "IFLA_STATS64:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
showStats64 ByteString
v
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eIFLA_STATS = "IFLA_STATS:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
showStats32 ByteString
v
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eIFLA_AF_SPEC = 
    "eIFLA_AF_SPEC: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ '\n'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
indent (ByteString -> String
showAfSpec ByteString
v)
  | Bool
otherwise = (Int -> String) -> (Int, ByteString) -> String
showAttr Int -> String
forall a. (Num a, Show a, Eq a) => a -> String
showLinkAttrType (Int
i, ByteString
v)

showStats64 :: ByteString -> String
showStats64 :: ByteString -> String
showStats64 bs :: ByteString
bs = case Get LinkStat -> ByteString -> Either String LinkStat
forall a. Get a -> ByteString -> Either String a
runGet Get LinkStat
getLinkStat64 ByteString
bs of
  (Left x :: String
x) -> ShowS
forall a. HasCallStack => String -> a
error ("Could not marshall LinkStat64: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x)
  (Right x :: LinkStat
x) -> LinkStat -> String
forall a. Show a => a -> String
show LinkStat
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"

showStats32 :: ByteString -> String
showStats32 :: ByteString -> String
showStats32 bs :: ByteString
bs = case Get LinkStat -> ByteString -> Either String LinkStat
forall a. Get a -> ByteString -> Either String a
runGet Get LinkStat
getLinkStat32 ByteString
bs of
  (Left x :: String
x) -> ShowS
forall a. HasCallStack => String -> a
error ("Could not marshall LinkStat32: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x)
  (Right x :: LinkStat
x) -> LinkStat -> String
forall a. Show a => a -> String
show LinkStat
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"


showAfSpec :: ByteString -> String
showAfSpec :: ByteString -> String
showAfSpec bs :: ByteString
bs = case Get Attributes -> ByteString -> Either String Attributes
forall a. Get a -> ByteString -> Either String a
runGet Get Attributes
getAttributes ByteString
bs of
  (Left x :: String
x) -> ShowS
forall a. HasCallStack => String -> a
error ("Could not marshall AfSpec: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x)
  (Right attrs :: Attributes
attrs) -> 
    ((Int, ByteString) -> String) -> [(Int, ByteString)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(i :: Int
i, v :: ByteString
v) -> Int -> String
forall a. (Num a, Show a, Eq a) => a -> String
showAddressFamily Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ '\n'Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
indent (ByteString -> String
showAfSpec' ByteString
v)) (Attributes -> [(Int, ByteString)]
forall k a. Map k a -> [(k, a)]
toList Attributes
attrs)

showAfSpec' :: ByteString -> String
showAfSpec' :: ByteString -> String
showAfSpec' bs :: ByteString
bs = case Get Attributes -> ByteString -> Either String Attributes
forall a. Get a -> ByteString -> Either String a
runGet Get Attributes
getAttributes ByteString
bs of
  (Left x :: String
x) -> ShowS
forall a. HasCallStack => String -> a
error ("Could not marshall AfSpec': " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x)
  (Right attrs :: Attributes
attrs) -> Attributes -> String
showNLAttrs Attributes
attrs


--
-- New generic stuffs
--

getMessage :: MessageType -> Get Message
getMessage :: MessageType -> Get Message
getMessage msgtype :: MessageType
msgtype | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_NEWLINK = Get Message
getMessageLink
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_GETLINK = Get Message
getMessageLink
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_DELLINK = Get Message
getMessageLink
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_NEWADDR = Get Message
getMessageAddr
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_GETADDR = Get Message
getMessageAddr
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_DELADDR = Get Message
getMessageAddr

                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_GETNEIGH = Get Message
getMessageNeigh
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_NEWNEIGH = Get Message
getMessageNeigh
                   | MessageType
msgtype MessageType -> MessageType -> Bool
forall a. Eq a => a -> a -> Bool
== MessageType
forall a. Num a => a
eRTM_DELNEIGH = Get Message
getMessageNeigh

                   | Bool
otherwise               =
                       String -> Get Message
forall a. HasCallStack => String -> a
error (String -> Get Message) -> String -> Get Message
forall a b. (a -> b) -> a -> b
$ "Can't decode message " String -> ShowS
forall a. [a] -> [a] -> [a]
++ MessageType -> String
forall a. Show a => a -> String
show MessageType
msgtype

getMessageLink :: Get Message
getMessageLink :: Get Message
getMessageLink = do
    Int -> Get ()
skip 2
    LinkType
ty    <- Word16 -> LinkType
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> LinkType) -> Get Word16 -> Get LinkType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
g16
    Word32
idx   <- Get Word32
g32
    Word32
flags <- Get Word32
g32
    Int -> Get ()
skip 4
    Message -> Get Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Get Message) -> Message -> Get Message
forall a b. (a -> b) -> a -> b
$ LinkType -> Word32 -> Word32 -> Message
NLinkMsg LinkType
ty Word32
idx Word32
flags

getMessageAddr :: Get Message
getMessageAddr :: Get Message
getMessageAddr = do
    AddressFamily
fam <- Word8 -> AddressFamily
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> AddressFamily) -> Get Word8 -> Get AddressFamily
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
g8
    Word8
maskLen <- Get Word8
g8
    Word8
flags <- Get Word8
g8
    Word8
scope <- Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8) -> Get Word8 -> Get Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
g8
    Word32
idx <- Get Word32
g32
    Message -> Get Message
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Get Message) -> Message -> Get Message
forall a b. (a -> b) -> a -> b
$ AddressFamily -> Word8 -> Word8 -> Word8 -> Word32 -> Message
NAddrMsg AddressFamily
fam Word8
maskLen Word8
flags Word8
scope Word32
idx

getMessageNeigh :: Get Message
getMessageNeigh :: Get Message
getMessageNeigh = Word8 -> Int32 -> Word16 -> Word8 -> Word8 -> Message
NNeighMsg
    (Word8 -> Int32 -> Word16 -> Word8 -> Word8 -> Message)
-> Get Word8 -> Get (Int32 -> Word16 -> Word8 -> Word8 -> Message)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
g8
    Get (Int32 -> Word16 -> Word8 -> Word8 -> Message)
-> Get Int32 -> Get (Word16 -> Word8 -> Word8 -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Get ()
skip 3 Get () -> Get Int32 -> Get Int32
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int32) -> Get Word32 -> Get Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
g32)
    Get (Word16 -> Word8 -> Word8 -> Message)
-> Get Word16 -> Get (Word8 -> Word8 -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
g16
    Get (Word8 -> Word8 -> Message)
-> Get Word8 -> Get (Word8 -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
g8
    Get (Word8 -> Message) -> Get Word8 -> Get Message
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
g8

putMessage :: Message -> Put
putMessage :: Message -> Put
putMessage (NLinkMsg ty :: LinkType
ty idx :: Word32
idx flags :: Word32
flags) = do
    Word8 -> Put
p8 Word8
forall a. Num a => a
eAF_UNSPEC Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
p8 0
    Word16 -> Put
p16 (LinkType -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral LinkType
ty)
    Word32 -> Put
p32 Word32
idx
    Word32 -> Put
p32 Word32
flags
    Word32 -> Put
p32 0xFFFFFFFF
putMessage (NAddrMsg fam :: AddressFamily
fam maskLen :: Word8
maskLen flags :: Word8
flags scope :: Word8
scope idx :: Word32
idx) = do
    Word8 -> Put
p8 (AddressFamily -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral AddressFamily
fam)
    Word8 -> Put
p8 Word8
maskLen
    Word8 -> Put
p8 Word8
flags
    Word8 -> Put
p8 (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
scope)
    Word32 -> Put
p32 Word32
idx
putMessage (NNeighMsg f :: Word8
f i :: Int32
i s :: Word16
s fl :: Word8
fl t :: Word8
t) = do
    Word8 -> Put
p8 Word8
f
    Word8 -> Put
p8 0 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
p8 0 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
p8 0 --padding
    Word32 -> Put
p32 (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i)
    Word16 -> Put
p16 Word16
s
    Word8 -> Put
p8 Word8
fl
    Word8 -> Put
p8 Word8
t

-- |'Get' a route message or an error
getRoutePackets :: ByteString -> Either String [RoutePacket]
getRoutePackets :: ByteString -> Either String [RoutePacket]
getRoutePackets = ByteString -> Either String [RoutePacket]
forall a.
(Convertable a, Eq a, Show a) =>
ByteString -> Either String [Packet a]
getPackets

-- |typedef for utility functions
type AttributeReader a = Attributes -> Maybe a

-- |typedef for utility functions
type AttributeWriter a = a -> Attributes -> Attributes

--
-- Link message attributes
--
type LinkAddress = (Word8, Word8, Word8, Word8, Word8, Word8)

-- |get L2 address from netlink attributes
getLinkAddress :: AttributeReader LinkAddress
getLinkAddress :: AttributeReader LinkAddress
getLinkAddress attrs :: Attributes
attrs = ByteString -> LinkAddress
decodeMAC (ByteString -> LinkAddress)
-> Maybe ByteString -> Maybe LinkAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFLA_ADDRESS Attributes
attrs

-- |set L2 address on netlink attributes
putLinkAddress :: AttributeWriter LinkAddress
putLinkAddress :: AttributeWriter LinkAddress
putLinkAddress addr :: LinkAddress
addr = Int -> ByteString -> Attributes -> Attributes
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Int
forall a. Num a => a
eIFLA_ADDRESS (LinkAddress -> ByteString
encodeMAC LinkAddress
addr)

-- |get L2 broadcast address from netlink attributes
getLinkBroadcast :: AttributeReader LinkAddress
getLinkBroadcast :: AttributeReader LinkAddress
getLinkBroadcast attrs :: Attributes
attrs = ByteString -> LinkAddress
decodeMAC (ByteString -> LinkAddress)
-> Maybe ByteString -> Maybe LinkAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFLA_BROADCAST Attributes
attrs

-- |set L2 broadcast address on netlink attributes
putLinkBroadcast :: AttributeWriter LinkAddress
putLinkBroadcast :: AttributeWriter LinkAddress
putLinkBroadcast addr :: LinkAddress
addr = Int -> ByteString -> Attributes -> Attributes
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Int
forall a. Num a => a
eIFLA_BROADCAST (LinkAddress -> ByteString
encodeMAC LinkAddress
addr)

-- |get interface name from netlink attributes
getLinkName :: AttributeReader String
getLinkName :: AttributeReader String
getLinkName attrs :: Attributes
attrs = ByteString -> String
getString (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFLA_IFNAME Attributes
attrs

-- |set interface name on netlink attributes
putLinkName :: AttributeWriter String
putLinkName :: AttributeWriter String
putLinkName ifname :: String
ifname = Int -> ByteString -> Attributes -> Attributes
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Int
forall a. Num a => a
eIFLA_IFNAME (String -> ByteString
putString String
ifname)

-- |get mtu from netlink attributes
getLinkMTU :: AttributeReader Word32
getLinkMTU :: AttributeReader Word32
getLinkMTU attrs :: Attributes
attrs = ByteString -> Maybe Word32
get32 (ByteString -> Maybe Word32) -> Maybe ByteString -> Maybe Word32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFLA_MTU Attributes
attrs

-- |set mtu on netlink attributes
putLinkMTU :: AttributeWriter Word32
putLinkMTU :: AttributeWriter Word32
putLinkMTU mtu :: Word32
mtu = Int -> ByteString -> Attributes -> Attributes
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Int
forall a. Num a => a
eIFLA_MTU (Word32 -> ByteString
put32 Word32
mtu)

-- TODO: IFLA_LINK - need to understand what it does

-- |I actually have no idea what QDisc is
getLinkQDisc :: AttributeReader String
getLinkQDisc :: AttributeReader String
getLinkQDisc attrs :: Attributes
attrs = ByteString -> String
getString (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFLA_QDISC Attributes
attrs

-- |I actually have no idea what QDisc is
putLinkQDisc :: AttributeWriter String
putLinkQDisc :: AttributeWriter String
putLinkQDisc disc :: String
disc = Int -> ByteString -> Attributes -> Attributes
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Int
forall a. Num a => a
eIFLA_QDISC (String -> ByteString
putString String
disc)

-- TODO: IFLA_STATS - bloody huge message, will deal with it later.

-- TODO: IFLA_{COST,PRIORITY,MASTER,WIRELESS,PROTINFO} - need to
-- understand what they do.

-- |I should look this up
getLinkTXQLen :: AttributeReader Word32
getLinkTXQLen :: AttributeReader Word32
getLinkTXQLen attrs :: Attributes
attrs = ByteString -> Maybe Word32
get32 (ByteString -> Maybe Word32) -> Maybe ByteString -> Maybe Word32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFLA_TXQLEN Attributes
attrs

-- |I should look this up
putLinkTXQLen :: AttributeWriter Word32
putLinkTXQLen :: AttributeWriter Word32
putLinkTXQLen len :: Word32
len = Int -> ByteString -> Attributes -> Attributes
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Int
forall a. Num a => a
eIFLA_TXQLEN (Word32 -> ByteString
put32 Word32
len)

-- TODO: IFLA_{MAP,WEIGHT} - need to figure out

-- TODO: IFLA_{LINKMODE,LINKINFO} - see Documentation/networking/operstates.txt

-- TODO: IFLA_{NET_NS_PID,IFALIAS} - need to figure out

-- |get interface address from netlink attributes of 'NAddrMsg'
getIFAddr :: AttributeReader ByteString
getIFAddr :: Attributes -> Maybe ByteString
getIFAddr = Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eIFA_ADDRESS

-- |get L2 address from netlink attributes of 'NNeighMsg'
getLLAddr :: AttributeReader LinkAddress
getLLAddr :: AttributeReader LinkAddress
getLLAddr attrs :: Attributes
attrs = ByteString -> LinkAddress
decodeMAC (ByteString -> LinkAddress)
-> Maybe ByteString -> Maybe LinkAddress
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eNDA_LLADDR Attributes
attrs

-- |get destination address from netlink attributes of 'NNeighMsg'
getDstAddr :: AttributeReader ByteString
getDstAddr :: Attributes -> Maybe ByteString
getDstAddr = Int -> Attributes -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Int
forall a. Num a => a
eNDA_DST

--
-- Helpers
--

decodeMAC :: ByteString -> LinkAddress
decodeMAC :: ByteString -> LinkAddress
decodeMAC = [Word8] -> LinkAddress
forall f. [f] -> (f, f, f, f, f, f)
tuplify ([Word8] -> LinkAddress)
-> (ByteString -> [Word8]) -> ByteString -> LinkAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (String -> [Word8])
-> (ByteString -> String) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
unpack
  where tuplify :: [f] -> (f, f, f, f, f, f)
tuplify [a :: f
a,b :: f
b,c :: f
c,d :: f
d,e :: f
e,f :: f
f] = (f
a,f
b,f
c,f
d,f
e,f
f)
        tuplify _ = String -> (f, f, f, f, f, f)
forall a. HasCallStack => String -> a
error "Bad encoded MAC"

encodeMAC :: LinkAddress -> ByteString
encodeMAC :: LinkAddress -> ByteString
encodeMAC = String -> ByteString
pack (String -> ByteString)
-> (LinkAddress -> String) -> LinkAddress -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> String)
-> (LinkAddress -> [Word8]) -> LinkAddress -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinkAddress -> [Word8]
forall a. (a, a, a, a, a, a) -> [a]
listify
  where listify :: (a, a, a, a, a, a) -> [a]
listify (a :: a
a,b :: a
b,c :: a
c,d :: a
d,e :: a
e,f :: a
f) = [a
a,a
b,a
c,a
d,a
e,a
f]

getString :: ByteString -> String
getString :: ByteString -> String
getString b :: ByteString
b = ByteString -> String
unpack (ByteString -> ByteString
init ByteString
b)

putString :: String -> ByteString
putString :: String -> ByteString
putString s :: String
s = ByteString -> ByteString -> ByteString
append (String -> ByteString
pack String
s) "\0"

get32 :: ByteString -> Maybe Word32
get32 :: ByteString -> Maybe Word32
get32 bs :: ByteString
bs = case Get Word32 -> ByteString -> Either String Word32
forall a. Get a -> ByteString -> Either String a
runGet Get Word32
getWord32host ByteString
bs of
    Left  _ -> Maybe Word32
forall a. Maybe a
Nothing
    Right w :: Word32
w -> Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
w

put32 :: Word32 -> ByteString
put32 :: Word32 -> ByteString
put32 w :: Word32
w = Put -> ByteString
runPut (Word32 -> Put
putWord32host Word32
w)