{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module System.Linux.RTNetlink (
RTNL()
, tryRTNL
, runRTNL
, runRTNLGroups
, create
, destroy
, dump
, dump'
, change
, getBacklog
, clearBacklog
, talk
, talk_
, talkRaw
, toggleVerbose
, liftIO
) where
import Control.Applicative (Applicative(..), (<$>))
import Control.Monad (when, void)
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
import Control.Monad.Catch (throwM, try, handle, bracket)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import Control.Monad.Trans.State.Strict (get, gets, put, modify, modify')
import Data.Monoid (mempty)
import Data.Either (partitionEithers)
import Data.List (partition)
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 Data.ByteString as S
import System.Linux.RTNetlink.Message
import System.Linux.RTNetlink.Packet
import System.Linux.RTNetlink.Util
import System.Socket.Family.Netlink
import System.Socket.Protocol.RTNetlink
data Handle = Handle
{ _handle :: Socket Netlink Raw RTNetlink
, backlog :: [S.ByteString]
, verbose :: Bool
, seqNum :: SequenceNumber
}
newtype RTNL a = RTNL {unRTNL :: StateT Handle IO a} deriving
( Functor
, Applicative
, Monad
, MonadIO
, MonadCatch
, MonadThrow
, MonadMask
)
tryRTNL :: RTNL a -> IO (Either String a)
tryRTNL = fmap (left (\e -> show (e::IOError))) . try . runRTNL
runRTNL :: RTNL a -> IO a
runRTNL = runRTNLGroups []
runRTNLGroups :: [RTNetlinkGroup] -> RTNL a -> IO a
runRTNLGroups gs r = bracket (rethrow "socket" socket) close $ \s -> do
rethrow "bind" $ bind s =<< netlinkAddress gs
h <- Handle s [] False <$> randomIO
evalStateT (unRTNL r) h
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'
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:_ -> throwM $ errnoToIOError "RTNETLINK answers" e Nothing Nothing
_ -> return rs
talk_ :: Header h => (SequenceNumber -> NLMessage h) -> RTNL ()
talk_ m = void (talk m :: RTNL [()])
create :: Create c => c -> RTNL ()
create = talk_ . createNLMessage
destroy :: Destroy d => d -> RTNL ()
destroy = talk_ . destroyNLMessage
dump :: Dump q r => q -> RTNL [r]
dump = talk . requestNLMessage
dump' :: Dump q r => q -> RTNL r
dump' q = dump q >>= \l -> case l of
e:[] -> return e
_:_ -> throwM $ userError "`dumpOne' returned non-unique"
[] -> throwM $ userError "`dumpOne' returned empty"
change :: Change id c => id -> c -> RTNL ()
change i c = talk_ $ changeNLMessage i c
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
clearBacklog :: RTNL ()
clearBacklog = RTNL . modify' $ \h -> h {backlog = []}
toggleVerbose :: RTNL ()
toggleVerbose = RTNL . modify $ \h -> h {verbose = not $ verbose h}
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
tryDecodeReply :: Reply r => S.ByteString -> Either S.ByteString r
tryDecodeReply bs = maybe (Left bs) Right $ fromNLMessage' =<< decodeMaybe bs
receiveAll :: Socket f t p -> Int -> MessageFlags -> IO [S.ByteString]
receiveAll s n f = unfoldM . timeout 500 . rethrow "receive" $ receive s n f
rethrow :: MonadCatch m => String -> m a -> m a
rethrow name = handle $ \(SocketException n) ->
throwM $ errnoToIOError name (Errno n) Nothing Nothing