agentx 0.1.0.4 → 0.1.0.5

raw patch · 8 files changed

+51/−50 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• agentx.cabal +3/−3
• src/Main.hs +1/−1
• src/Network/Protocol/Snmp/AgentX/Handlers.hs +2/−2
• src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs +8/−8
• src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs +1/−0
• src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs +11/−5
• src/Network/Protocol/Snmp/AgentX/Service.hs +12/−16
• src/Network/Protocol/Snmp/AgentX/Types.hs +13/−15

@@ -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  

@@ -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

@@ -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

@@ -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  

@@ -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

@@ -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 

@@ -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  

@@ -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)