diff --git a/agentx.cabal b/agentx.cabal --- a/agentx.cabal +++ b/agentx.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: agentx -version: 0.1.0.1 +version: 0.1.0.2 synopsis: AgentX protocol for snmp subagents description: Native implementation agentx protocol (rfc2741) license: BSD3 @@ -16,7 +16,12 @@ cabal-version: >=1.10 library - exposed-modules: Network.Protocol.Snmp.AgentX, Network.Protocol.Snmp.AgentX.MIBTree, Network.Protocol.Snmp.AgentX.Packet + exposed-modules: Network.Protocol.Snmp.AgentX, + Network.Protocol.Snmp.AgentX.MIBTree, + Network.Protocol.Snmp.AgentX.Packet, + Network.Protocol.Snmp.AgentX.Handlers, + Network.Protocol.Snmp.AgentX.Service, + Network.Protocol.Snmp.AgentX.Types other-modules: Network.Protocol.Snmp.AgentX.MIBTree.Tree, Network.Protocol.Snmp.AgentX.MIBTree.MIBTree, Network.Protocol.Snmp.AgentX.MIBTree.Types, Network.Protocol.Snmp.AgentX.Packet.Binary, Network.Protocol.Snmp.AgentX.Packet.Get, Network.Protocol.Snmp.AgentX.Packet.Put, Network.Protocol.Snmp.AgentX.Packet.Types diff --git a/src/Network/Protocol/Snmp/AgentX/Handlers.hs b/src/Network/Protocol/Snmp/AgentX/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Snmp/AgentX/Handlers.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Protocol.Snmp.AgentX.Handlers +( route ) +where + +import Control.Applicative +import Control.Monad.State +import Control.Monad.Reader +import qualified Data.Label as DL +import qualified Data.Map as Map +import Data.IORef +import Data.List (find) +import Data.Maybe + +import Network.Protocol.Snmp.AgentX.MIBTree +import Network.Protocol.Snmp (OID) +import Network.Protocol.Snmp.AgentX.Packet +import Network.Protocol.Snmp.AgentX.Types + +makePdu :: [Either TaggedError VarBind] -> SubAgent (Maybe PDU) +makePdu xs = do + now <- uptime + let (good, index, firstBad) = splitByError xs + case firstBad of + Nothing -> return . Just $ Response now (Tagged NoAgentXError) index good + Just err -> return . Just $ Response now err index good + +splitByError :: [Either TaggedError a] -> ([a], Index, Maybe TaggedError) +splitByError xs = + case splitByError' xs of + (xss, Nothing) -> (xss, minBound, Nothing) + (xss, e) -> (xss, toEnum (1 + length xss), e) -- ? check position + where + splitByError' :: [Either TaggedError a] -> ([a], Maybe TaggedError) + splitByError' [] = ([], Nothing) + splitByError' (Left err : _) = ([], Just err) + splitByError' (Right x : xs') = + let splitted = splitByError' xs' + in (x : fst splitted, snd splitted) + +-- | processing request, return response +route :: Packet -> SubAgent (Maybe Packet) +route packet = route' pdu' >>= return . fmap setPdu + where + pdu' = DL.get pdu packet + setPdu = flip (DL.set pdu) packet + transactionId = DL.get tid packet + route' :: PDU -> SubAgent (Maybe PDU) + route' (Get mcontext oids) = makePdu =<< getHandler oids mcontext + route' (GetNext mcontext srange) = makePdu =<< getNextHandler mcontext srange + route' (GetBulk mcontext nonRepeaters maxRepeaters srange) = makePdu =<< getBulkHandler mcontext nonRepeaters maxRepeaters srange + route' (TestSet mcontext varBindList) = makePdu =<< testSetHandler mcontext varBindList transactionId + route' CommitSet = do + tr <- transactions <$> ask + now <- uptime + mtransaction <- Map.lookup transactionId <$> (liftIO . readIORef $ tr) + liftIO $ atomicModifyIORef' tr $ \m -> (Map.update (\x -> Just $ x { statusV = CleanupSetT }) transactionId m, ()) + case mtransaction of + Just (Transaction mcontext varBindList TestSetT) -> do + result <- mapM (commit mcontext) varBindList + return $ maybe (Just $ Response now (Tagged NoCommitError) minBound []) + (const $ Just $ Response now (Tagged CommitFailed) minBound []) + (find (\x -> snd x == CommitFailed) result) + _ -> return . Just $ Response now (Tagged CommitFailed) minBound [] + where + commit mcontext varbind' = do + mib <- runMIBTree (findOne (DL.get vboid varbind') mcontext) + result <- liftIO $ commitSetAIO (val mib) (DL.get vbvalue varbind') + return (varbind', result) + route' CleanupSet = do + tr <- transactions <$> ask + maybeTransaction <- Map.lookup transactionId <$> (liftIO . readIORef $ tr) + let oidsList = map (DL.get vboid) $ fromMaybe [] (vblist `fmap` maybeTransaction) + let mcontext = join $ tcontext `fmap` maybeTransaction + liftIO . atomicModifyIORef' tr $ \m -> (Map.delete transactionId m, ()) + void $ runMIBTree (regWrapper (findMany oidsList mcontext)) + return Nothing + + route' _ = do + liftIO $ print packet + makePdu =<< return [Left (Tagged RequestDenied)] + +uptime :: SubAgent SysUptime +uptime = do + nowref <- sysuptime <$> ask + liftIO . readIORef $ nowref + +getHandler :: [OID] -> Maybe Context -> SubAgent [Either TaggedError VarBind] +getHandler xs mc = map Right <$> (liftIO . mapM mibToVarBind =<< evalMIBTree (findMany xs mc)) + +getNextHandler :: Maybe Context -> [SearchRange] -> SubAgent [Either TaggedError VarBind] +getNextHandler mc xs = map Right <$> (liftIO . mapM mibToVarBind =<< evalMIBTree (findManyNext xs mc)) + +getBulkHandler :: Maybe Context -> NonRepeaters -> MaxRepeaters -> [SearchRange] -> SubAgent [Either TaggedError VarBind] +getBulkHandler = undefined + +testSetHandler :: Maybe Context -> [VarBind] -> TransactionID -> SubAgent [Either TaggedError VarBind] +testSetHandler mcontext varBindList transactionId = do + tr <- transactions <$> ask + result <- mapM testFun varBindList + let (goods, _, _) = splitByError result + liftIO . atomicModifyIORef' tr $ \x -> (Map.insert transactionId (Transaction mcontext goods TestSetT) x, ()) + return result + where + testFun v = do + mib <- runMIBTree (findOne (DL.get vboid v) mcontext) + testResult <- liftIO $ testSetAIO (val mib) (DL.get vbvalue v) + return $ if testResult == NoTestError + then Right v + else Left (Tagged testResult) + + diff --git a/src/Network/Protocol/Snmp/AgentX/Service.hs b/src/Network/Protocol/Snmp/AgentX/Service.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Snmp/AgentX/Service.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +module Network.Protocol.Snmp.AgentX.Service +( agent +, Client(..) +, request +, requestWithResponse +) +where + +import Network.Socket (close, Socket, socket, Family(AF_UNIX), SocketType(Stream), connect, SockAddr(SockAddrUnix)) +import Network.Socket.ByteString.Lazy (recv, send) +import Control.Concurrent (killThread, threadDelay, ThreadId) +import Data.Binary (encode, decode) +import Data.Monoid ((<>)) +import Control.Applicative hiding (empty) +import Control.Monad.State.Strict +import Control.Monad.Reader +import Control.Exception +import Data.IORef +import Data.Fixed (div') +import Data.Time.Clock.POSIX (getPOSIXTime) +import System.IO (hSetBuffering, stdout, BufferMode(LineBuffering)) +import Pipes.Concurrent (spawn, forkIO, fromInput, toOutput, unbounded) +import Pipes +import Pipes.Lift +import Control.Concurrent.MVar +import Data.Default +import qualified Data.Map.Strict as Map +import qualified Data.Label as DL + +import Network.Protocol.Snmp (OID) +import Network.Protocol.Snmp.AgentX.Packet +import Network.Protocol.Snmp.AgentX.MIBTree hiding (register) +import qualified Network.Protocol.Snmp.AgentX.MIBTree as MIBTree +import Network.Protocol.Snmp.AgentX.Handlers +import Network.Protocol.Snmp.AgentX.Types + +-- | start agent +agent :: FilePath -- ^ path to socket + -> OID -- ^ base oid + -> Maybe Client -- ^ client + -> [MIB] -- ^ MIBs + -> IO () +agent path o client tree = bracket (openSocket path) + close + (runAgent o tree client) + +openSocket :: String -> IO Socket +openSocket path = socket AF_UNIX Stream 0 >>= \x -> connect x (SockAddrUnix path) >> return x + +runAgent :: OID -> [MIB] -> Maybe Client -> Socket -> IO () +runAgent modOid tree mclient socket' = do + hSetBuffering stdout LineBuffering + -- make state + st <- initAgent modOid tree socket' + -- start timer + timer <- forkIO $ do + t <- getSysUptime + atomicWriteIORef (sysuptime st) t + threadDelay 1000000 + -- spawn mailboxes for requests and for responses + (reqTo, req) <- (\(x,y) -> (toOutput x, fromInput y)) <$> spawn unbounded + (respTo, resp) <- (\(x,y) -> (toOutput x, fromInput y)) <$> spawn unbounded + -- spawn sort machine + sortPid <- fiber st $ input >-> sortInput reqTo respTo + -- open session + run st $ resp >-> openSession >-> output + -- start register, unregister fiber + regPid <- fiber st $ resp >-> registrator >-> output + -- start server fiber + serverPid <- fiber st $ req >-> server + serverPid1 <- fiber st $ req >-> server + serverPid2 <- fiber st $ req >-> server + -- start agent fiber + agentPid <- fiber st $ resp >-> runClient (maybe def id mclient) >-> output + regPidTimer <- registerTimer st + _ <- getLine :: IO String + liftIO $ putStrLn "unregister all MIB" + evalStateT unregisterFullTree =<< readIORef (mibs st) + liftIO $ threadDelay 1000000 + void $ mapM (liftIO . killThread) [serverPid, serverPid1, serverPid2, sortPid, agentPid, regPid, timer, regPidTimer] -- p2,p3,p4,p5, + +initAgent :: OID -> [MIB] -> Socket -> IO SubAgentState +initAgent modOid tree socket' = do + sysUptimeIORef <- newIORef =<< getSysUptime + sessionsIORef <- newIORef Nothing + packetCounterIORef <- newIORef minBound + mod' <- mkModule modOid tree + moduleIORef <- newIORef =<< flip execStateT mod' (initModule >> registerFullTree) + m <- newMVar () + transactionsIORef <- newIORef Map.empty + return $ SubAgentState sysUptimeIORef packetCounterIORef moduleIORef m socket' sessionsIORef transactionsIORef + +registerTimer :: SubAgentState -> IO ThreadId +registerTimer st = forkIO . forever $ do + oldTree <- evalStateT askTree =<< readIORef (mibs st) + liftIO $ threadDelay 1000000 + evalStateT (flip regByDiff oldTree =<< askTree) =<< readIORef (mibs st) +--------------------------------------------------------------------------- +-- Pipes eval +--------------------------------------------------------------------------- +run :: SubAgentState -> Effect SubAgent a -> IO a +run s eff = runEffect $ runReaderP s eff + +server :: Consumer Packet SubAgent () +server = forever $ do + m <- await + -- ask >>= flip fiber (yield m >-> server' >-> _dp "out" >-> output) + ask >>= flip fiber (yield m >-> server' >-> output) + +fiber :: MonadIO m => SubAgentState -> Effect SubAgent () -> m ThreadId +fiber st = liftIO . forkIO . run st + +input :: Producer Packet SubAgent () +input = forever $ do + sock' <- sock <$> ask + h <- liftIO $ recv sock' 20 + b <- liftIO $ recv sock' (bodySizeFromHeader h) + yield $ decode $ h <> b + +output :: Consumer Packet SubAgent () +output = forever $ do + sock' <- sock <$> ask + bs <- await + void . liftIO $ send sock' (encode bs) + +sortInput :: Consumer Packet SubAgent () -> Consumer Packet SubAgent () -> Consumer Packet SubAgent () +sortInput requests responses = forever $ await >>= sortInput' + where + sortInput' m + | isResponse m = yield m >-> responses + | otherwise = yield m >-> requests + isResponse p = case DL.get pdu p of + Response{} -> True + _ -> False + +server' :: Pipe Packet Packet SubAgent () +server' = forever $ await >>= lift . route >>= yieldOnlyJust + where + yieldOnlyJust Nothing = return () + yieldOnlyJust (Just resp) = yield resp + +openSession :: Pipe Packet Packet SubAgent () +openSession = do + openPacket <- lift open + request openPacket + +registrator :: Pipe Packet Packet SubAgent () +registrator = forever $ mapM_ request =<< lift register + +-- | simple request for client, if you dont need response. +request :: Packet -> Pipe Packet Packet SubAgent () +request p = do + pid' <- lift getPid + sid' <- lift getSid + yield $ DL.set pid pid' (DL.set sid sid' p) + resp <- await + lift . setSid . (DL.get sid) $ resp + +-- | as request, but you can work with response. +requestWithResponse :: Packet -> Pipe Packet Packet SubAgent Packet +requestWithResponse p = do + pid' <- lift getPid + sid' <- lift getSid + yield $ DL.set pid pid' (DL.set sid sid' p) + resp <- await + lift . setSid . (DL.get sid) $ resp + return resp + +-- | if you need client +newtype Client = Client { runClient :: Pipe Packet Packet SubAgent () } + +-- | by default just ping every 5s. +instance Default Client where + def = Client . forever $ do + request ping + liftIO $ threadDelay 5000000 + +_dp :: String -> Pipe Packet Packet SubAgent () +_dp label = forever $ do + i <- await + liftIO $ print $ label ++ " " ++ show i + yield i + +--------------------------------------------------------------------------- +-- SubAgent eval +--------------------------------------------------------------------------- +register :: SubAgent [Packet] +register = do + s <- mibs <$> ask + m <- liftIO $ readIORef s + (toReg, toUnReg) <- liftIO $ takeMVar (DL.get MIBTree.register m) + liftIO $ mapM_ (\x -> print ("R " ++ show x)) toReg + liftIO $ mapM_ (\x -> print ("UR " ++ show x)) toUnReg + return $ map toRegPacket toReg <> map toUnRegPacket toUnReg + where + toRegPacket :: (OID, Maybe Context) -> Packet + toRegPacket m = + let pduList = Register (snd m) minBound (toEnum 127) minBound (fst m) Nothing + in mkPacket def pduList def minBound minBound minBound + toUnRegPacket :: (OID, Maybe Context) -> Packet + toUnRegPacket m = + let pduList = Unregister (snd m) (toEnum 127) minBound (fst m) Nothing + in mkPacket def pduList def minBound minBound minBound + +open :: SubAgent Packet +open = do + s <- mibs <$> ask + m <- liftIO $ readIORef s + let open' = Open minBound (DL.get moduleOID m) ("Haskell AgentX sub-aagent") + return $ mkPacket def open' def minBound minBound minBound + +ping :: Packet +ping = mkPacket def (Ping Nothing) def minBound minBound minBound + +getSid :: SubAgent SessionID +getSid = do + sesRef <- sessions <$> ask + s <- liftIO $ readIORef sesRef + maybe (return minBound) return s + +setSid :: SessionID -> SubAgent () +setSid sid' = do + sesRef <- sessions <$> ask + s <- liftIO $ readIORef sesRef + case s of + Nothing -> do + liftIO $ atomicModifyIORef' sesRef (const $ (Just sid', ())) + msg + Just x + | x == sid' -> return () + | otherwise -> do + liftIO $ atomicModifyIORef' sesRef (const $ (Just sid', ())) + msg + where + msg = liftIO $ print $ "set sid " ++ show sid' + + +getPid :: SubAgent PacketID +getPid = do + pidRef <- packetCounter <$> ask + liftIO $ atomicModifyIORef' pidRef $ \x -> (succ x, succ x) + +getSysUptime :: IO SysUptime +getSysUptime = do + (t :: Integer) <- flip div' 1 <$> getPOSIXTime + return . toEnum . fromIntegral $ t diff --git a/src/Network/Protocol/Snmp/AgentX/Types.hs b/src/Network/Protocol/Snmp/AgentX/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Snmp/AgentX/Types.hs @@ -0,0 +1,62 @@ +module Network.Protocol.Snmp.AgentX.Types +( SubAgentState(..) +, Transaction(..) +, evalMIBTree +, runMIBTree +, SubAgent +, TransactionState(..) +) +where + +import Control.Monad.State.Strict +import Control.Monad.Reader +import Network.Socket hiding (recv) +import Control.Concurrent.MVar +import Control.Applicative +import Data.IORef +import Data.Map + +import Network.Protocol.Snmp.AgentX.Packet +import Network.Protocol.Snmp.AgentX.MIBTree + + +data Transaction = Transaction + { tcontext :: Maybe Context + , vblist :: [VarBind] + , statusV :: TransactionState + } deriving Show + +data TransactionState = TestSetT + | CommitSetT + | UndoSetT + | CleanupSetT + deriving (Show, Eq, Ord, Enum) + +data SubAgentState = SubAgentState + { sysuptime :: IORef SysUptime + , packetCounter :: IORef PacketID + , mibs :: IORef Module + , mutex :: MVar () + , sock :: Socket + , sessions :: IORef (Maybe SessionID) + , transactions :: IORef (Map TransactionID Transaction) + } + +type SubAgent = ReaderT SubAgentState IO + + +-- | run MIBTree in SubAgent context, with lock (access to Module read-write) +runMIBTree :: MIBTree IO a -> SubAgent a +runMIBTree f = do + st <- mibs <$> ask + m <- mutex <$> ask + lift $ withMVar m $ \() -> do + (a, newst) <- runStateT f =<< (liftIO $ readIORef st) + atomicWriteIORef st newst + return a + +-- | eval MIBTree in SubAgent context without lock (access to Module read only) +evalMIBTree :: MIBTree IO a -> SubAgent a +evalMIBTree f = do + st <- mibs <$> ask + liftIO $ evalStateT f =<< (liftIO $ readIORef st)