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.4 +version: 0.1.0.5 synopsis: AgentX protocol for write SNMP subagents description: Native implementation agentx protocol (rfc2741) license: BSD3 @@ -53,7 +53,7 @@ , pipes , pipes-concurrency hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall default-language: Haskell2010 executable agentx_example @@ -79,7 +79,7 @@ , pipes , pipes-concurrency hs-source-dirs: src - ghc-options: -Wall -O2 -threaded + ghc-options: -Wall -O2 -threaded default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -48,7 +48,7 @@ dynTree :: IORef Value -> Update dynTree i = Update $ do - Integer count <- liftIO $ readIORef i + Integer count <- readIORef i return $ concatMap fun [0 .. count] where fun x = [ mkObject (fromIntegral x) "trees" ("tree" ++ show x) Nothing diff --git a/src/Network/Protocol/Snmp/AgentX/Handlers.hs b/src/Network/Protocol/Snmp/AgentX/Handlers.hs --- a/src/Network/Protocol/Snmp/AgentX/Handlers.hs +++ b/src/Network/Protocol/Snmp/AgentX/Handlers.hs @@ -88,10 +88,10 @@ liftIO . readIORef $ nowref getHandler :: [OID] -> Maybe Context -> SubAgent [Either TaggedError VarBind] -getHandler xs mc = map Right <$> (liftIO . mapM mibToVarBind =<< evalMIBTree (findMany xs mc)) +getHandler xs mc = map Right <$> (liftIO . mapM mibToVarBind =<< runMIBTree (findMany xs mc)) getNextHandler :: Maybe Context -> [SearchRange] -> SubAgent [Either TaggedError VarBind] -getNextHandler mc xs = map Right <$> (liftIO . mapM mibToVarBind =<< evalMIBTree (findManyNext xs mc)) +getNextHandler mc xs = map Right <$> (liftIO . mapM mibToVarBind =<< runMIBTree (findManyNext xs mc)) getBulkHandler :: Maybe Context -> NonRepeaters -> MaxRepeaters -> [SearchRange] -> SubAgent [Either TaggedError VarBind] getBulkHandler = undefined diff --git a/src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs b/src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs --- a/src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs +++ b/src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs @@ -33,10 +33,10 @@ -- import Debug.Trace -- | build tree and init module -initModule :: (Monad m, MonadIO m, Functor m) => MIBTree m () +initModule :: MIBTree IO () initModule = flip forM_ evalTree =<< toUpdateList <$> gets ou where - evalTree :: (Monad m, MonadIO m, Functor m) => MIB -> MIBTree m () + evalTree :: MIB -> MIBTree IO () evalTree obj = do (mibs, updates) <- buildTree <$> (lift $ unUpdate . fromJust . update $ obj) case updates of @@ -107,10 +107,10 @@ else ObjectType (L.get startOID s) (last $ L.get startOID s) "" "" Nothing (rsValue EndOfMibView) -- | find one MIB -findOne :: (Monad m, MonadIO m, Functor m) => +findOne :: OID -- ^ path for find -> Maybe Context -- ^ context, you can have many values with one path and different context - -> MIBTree m MIB + -> MIBTree IO MIB findOne ys mcontext = do -- init zippers modify zipper top @@ -166,14 +166,14 @@ -- | like findOne, but for many paths -findMany :: (Monad m, MonadIO m, Functor m) => [OID] -> Maybe Context -> MIBTree m [MIB] +findMany :: [OID] -> Maybe Context -> MIBTree IO [MIB] findMany xs mc = mapM (flip findOne mc) xs -- | find next node in MIBTree -findNext :: (Monad m, MonadIO m, Functor m) => +findNext :: SearchRange -- ^ SearchRange (getwalk or getnext requests) -> Maybe Context -- ^ context - -> MIBTree m MIB -- ^ search result + -> MIBTree IO MIB -- ^ search result findNext sr mcontext = do modify zipper top modify ou top @@ -245,7 +245,7 @@ getFocus _ = error "getFocus" -- | like findNext -findManyNext :: (Monad m, MonadIO m, Functor m) => [SearchRange] -> Maybe Context -> MIBTree m [MIB] +findManyNext :: [SearchRange] -> Maybe Context -> MIBTree IO [MIB] findManyNext xs mc = mapM (flip findNext mc) xs diff --git a/src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs b/src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs --- a/src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs +++ b/src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs @@ -24,6 +24,7 @@ data Move b a = Next (b a) | Level (b a) + deriving Eq instance (Show a, Show (b a)) => Show (Move b a) where show (Next x) = "\nNext " ++ show x diff --git a/src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs b/src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs --- a/src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs +++ b/src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs @@ -52,7 +52,7 @@ } -- | Update, for rebuild oid tree in runtime -newtype Update = Update { unUpdate :: forall m . (Monad m, MonadIO m, Functor m) => m [MIB] } +newtype Update = Update { unUpdate :: IO [MIB] } type IValue = ContextedValue PVal type IUpdate = ContextedValue Update @@ -109,6 +109,12 @@ mkLabel ''Module +instance Eq (ContextedValue a) where + _ == _ = True + +instance Eq Module where + (Module z o _ _) == (Module z1 o1 _ _) = (z == z1) && (o == o1) + instance Show Module where show (Module z ou' _ _) = show z ++ "\n" ++ show ou' @@ -116,10 +122,10 @@ type MIBTree = StateT Module -- | Constructor for Module -mkModule :: (Monad m, MonadIO m, Functor m) => +mkModule :: OID -- ^ base module OID -> [MIB] -- ^ all MIB for create module - -> m Module + -> IO Module mkModule moduleOid mibs = do reg <- liftIO $ newEmptyMVar return $ Module (toZipper . fst . buildTree $ mibs) (toZipper . snd . buildTree $ mibs) moduleOid reg @@ -215,8 +221,8 @@ isWritable _ = False -- | convert MIB to VarBind -mibToVarBind :: (Monad m, MonadIO m, Functor m) => MIB -> m VarBind +mibToVarBind :: MIB -> IO VarBind mibToVarBind m = do - v <- liftIO $ readAIO (val m) + v <- readAIO (val m) return $ mkVarBind (oi m) v diff --git a/src/Network/Protocol/Snmp/AgentX/Service.hs b/src/Network/Protocol/Snmp/AgentX/Service.hs --- a/src/Network/Protocol/Snmp/AgentX/Service.hs +++ b/src/Network/Protocol/Snmp/AgentX/Service.hs @@ -12,7 +12,6 @@ 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, myThreadId) import Data.Binary (encode, decode) import Data.Monoid ((<>)) import Control.Applicative hiding (empty) @@ -23,10 +22,11 @@ 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.Concurrent (spawn, fromInput, toOutput, unbounded) import Pipes import Pipes.Lift -import Control.Concurrent.MVar +import GHC.Conc hiding (yield) +import Control.Concurrent.MVar (takeMVar) import Data.Default import qualified Data.Map.Strict as Map import qualified Data.Label as DL @@ -77,22 +77,20 @@ regPid <- fiber st $ resp >-> registrator >-> output -- start server fibers 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 mainPid <- myThreadId let stopAgent = do liftIO $ putStrLn "unregister all MIB" - evalStateT unregisterFullTree =<< readIORef (mibs st) + evalStateT unregisterFullTree =<< readTVarIO (mibs st) liftIO $ threadDelay 1000000 - void $ mapM (liftIO . killThread) [serverPid, serverPid1, serverPid2, sortPid, agentPid, regPid, timer, regPidTimer] + void $ mapM (liftIO . killThread) [serverPid, sortPid, agentPid, regPid, timer, regPidTimer] throwTo mainPid ExitSuccess void $ installHandler keyboardSignal (Catch stopAgent) Nothing void $ installHandler sigTERM (Catch stopAgent) Nothing void $ installHandler sigQUIT (Catch stopAgent) Nothing - void $ installHandler sigUSR1 (Catch (print =<< readIORef (mibs st))) Nothing + void $ installHandler sigUSR1 (Catch (print =<< readTVarIO (mibs st))) Nothing forever $ threadDelay 10000000 initAgent :: OID -> [MIB] -> Socket -> IO SubAgentState @@ -101,16 +99,15 @@ sessionsIORef <- newIORef Nothing packetCounterIORef <- newIORef minBound mod' <- mkModule modOid tree - moduleIORef <- newIORef =<< flip execStateT mod' (initModule >> registerFullTree) - m <- newMVar () + moduleIORef <- newTVarIO =<< flip execStateT mod' (initModule >> registerFullTree) transactionsIORef <- newIORef Map.empty - return $ SubAgentState sysUptimeIORef packetCounterIORef moduleIORef m socket' sessionsIORef transactionsIORef + return $ SubAgentState sysUptimeIORef packetCounterIORef moduleIORef socket' sessionsIORef transactionsIORef registerTimer :: SubAgentState -> IO ThreadId registerTimer st = forkIO . forever $ do - oldTree <- evalStateT askTree =<< readIORef (mibs st) + oldTree <- evalStateT askTree =<< readTVarIO (mibs st) liftIO $ threadDelay 1000000 - evalStateT (flip regByDiff oldTree =<< askTree) =<< readIORef (mibs st) + evalStateT (flip regByDiff oldTree =<< askTree) =<< readTVarIO (mibs st) --------------------------------------------------------------------------- -- Pipes eval --------------------------------------------------------------------------- @@ -120,7 +117,6 @@ 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 @@ -203,7 +199,7 @@ register :: SubAgent [Packet] register = do s <- mibs <$> ask - m <- liftIO $ readIORef s + m <- liftIO $ readTVarIO 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 @@ -221,7 +217,7 @@ open :: SubAgent Packet open = do s <- mibs <$> ask - m <- liftIO $ readIORef s + m <- liftIO $ readTVarIO s let open' = Open minBound (DL.get moduleOID m) ("Haskell AgentX sub-aagent") return $ mkPacket def open' def minBound minBound minBound diff --git a/src/Network/Protocol/Snmp/AgentX/Types.hs b/src/Network/Protocol/Snmp/AgentX/Types.hs --- a/src/Network/Protocol/Snmp/AgentX/Types.hs +++ b/src/Network/Protocol/Snmp/AgentX/Types.hs @@ -1,7 +1,6 @@ module Network.Protocol.Snmp.AgentX.Types ( SubAgentState(..) , Transaction(..) -, evalMIBTree , runMIBTree , SubAgent , TransactionState(..) @@ -11,9 +10,9 @@ 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 GHC.Conc import Data.Map import Network.Protocol.Snmp.AgentX.Packet @@ -35,8 +34,7 @@ data SubAgentState = SubAgentState { sysuptime :: IORef SysUptime , packetCounter :: IORef PacketID - , mibs :: IORef Module - , mutex :: MVar () + , mibs :: TVar Module , sock :: Socket , sessions :: IORef (Maybe SessionID) , transactions :: IORef (Map TransactionID Transaction) @@ -45,18 +43,18 @@ type SubAgent = ReaderT SubAgentState IO --- | run MIBTree in SubAgent context, with lock (access to Module read-write) +-- | run MIBTree in SubAgent context, without lock, if trees was changed, retry 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 + oldst <- liftIO $ readTVarIO st + (a, newst) <- liftIO $ runStateT f oldst + result <- lift . atomically $ do + oldst' <- readTVar st + if oldst' == newst + then writeTVar st newst >> return True + else return False + if result + then return a + else runMIBTree f --- | 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)