packages feed

agentx 0.1.0.1 → 0.1.0.2

raw patch · 4 files changed

+430/−2 lines, 4 files

Files

agentx.cabal view
@@ -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
+ src/Network/Protocol/Snmp/AgentX/Handlers.hs view
@@ -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)++
+ src/Network/Protocol/Snmp/AgentX/Service.hs view
@@ -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
+ src/Network/Protocol/Snmp/AgentX/Types.hs view
@@ -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)