agentx (empty) → 0.1.0.0
raw patch · 14 files changed
+2123/−0 lines, 14 filesdep +Diffdep +basedep +binarysetup-changed
Dependencies added: Diff, base, binary, bitwise, bytestring, containers, data-default, fclabels, mtl, network, network-info, pipes, pipes-concurrency, pipes-network, safe, snmp, time, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- agentx.cabal +81/−0
- src/Main.hs +82/−0
- src/Network/Protocol/Snmp/AgentX.hs +203/−0
- src/Network/Protocol/Snmp/AgentX/MIBTree.hs +50/−0
- src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs +251/−0
- src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs +185/−0
- src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs +222/−0
- src/Network/Protocol/Snmp/AgentX/Packet.hs +66/−0
- src/Network/Protocol/Snmp/AgentX/Packet/Binary.hs +13/−0
- src/Network/Protocol/Snmp/AgentX/Packet/Get.hs +282/−0
- src/Network/Protocol/Snmp/AgentX/Packet/Put.hs +250/−0
- src/Network/Protocol/Snmp/AgentX/Packet/Types.hs +406/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, chemist++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of chemist nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ agentx.cabal view
@@ -0,0 +1,81 @@+-- Initial agentx.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: agentx+version: 0.1.0.0+synopsis: AgentX protocol for snmp subagents+description: Native implementation agentx protocol (rfc2741) +license: BSD3+license-file: LICENSE+author: chemist+maintainer: chemistmail@gmail.com+-- copyright: +category: Network+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++executable agentx+ main-is: Main.hs+ build-depends: base >=4.6 && <4.8+ , snmp+ , binary+ , bytestring+ , bitwise+ , network+ , fclabels+ , Diff+ , mtl+ , transformers+ , time+ , containers+ , data-default+ , network-info+ , safe+ , pipes-network+ , pipes+ , pipes-concurrency+ hs-source-dirs: src+ ghc-options: -Wall -threaded -rtsopts -auto-all -caf-all+ default-language: Haskell2010+-- +-- executable client+-- main-is: Client.hs+-- build-depends: base >=4.6 && <4.8+-- , snmp+-- , bytestring+-- hs-source-dirs: src+-- ghc-options: -Wall -threaded -rtsopts -auto-all -caf-all+-- default-language: Haskell2010++library+ exposed-modules: Network.Protocol.Snmp.AgentX, Network.Protocol.Snmp.AgentX.MIBTree, Network.Protocol.Snmp.AgentX.Packet+ 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 + -- other-extensions: + build-depends: base >=4.6 && <4.8+ , snmp+ , binary+ , bytestring+ , bitwise+ , network+ , fclabels+ , Diff+ , mtl+ , transformers+ , time+ , data-default+ , containers+ , network-info+ , safe+ , pipes-network+ , pipes+ , pipes-concurrency+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010++source-repository head+ type: git+ location: git@github.com:chemist/agentx.git
+ src/Main.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+module Main where++import Network.Protocol.Snmp.AgentX +import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import Data.Fixed (div')+import Data.Time.Clock.POSIX (getPOSIXTime)+import Control.Applicative ((<$>))+import Control.Monad.State+import Data.IORef++++str :: ByteString -> PVal+str x = rsValue (String x)++now :: PVal+now = rdValue $ TimeTicks . flip div' 1 <$> liftIO getPOSIXTime++rws :: IORef Value -> PVal+rws io = rwValue readV commit test undo+ where+ test (String x) + | BS.length x < 10 = return NoTestError+ | otherwise = return TooBig+ test _ = return WrongType+ commit v = do+ writeIORef io v+ return NoCommitError+ undo _ = return NoUndoError+ readV = readIORef io++rwi :: IORef Value -> PVal+rwi io = rwValue readV commit test undo+ where+ test (Integer x) + | x < 5 = return NoTestError+ | otherwise = return TooBig+ test _ = return WrongType+ commit v = do+ writeIORef io v+ return NoCommitError+ undo _ = return NoUndoError+ readV = readIORef io++dynTree :: IORef Value -> Update+dynTree i = Update $ do+ Integer count <- liftIO $ readIORef i+ return $ concatMap fun [0 .. count]+ where+ fun x = [ mkObject (fromIntegral x) "trees" ("tree" ++ show x) Nothing+ , mkObjectType 0 ("tree" ++ show x) "abr" Nothing (str "abr")+ , mkObjectType 1 ("tree" ++ show x) "abrvalg" Nothing (str "abrvalg")+ ]++ver :: Maybe Context+ver = Just "version"++simpleTree :: IORef Value -> IORef Value -> [MIB]+simpleTree m i = + [ mkObject 0 "Fixmon" "about" Nothing+ , mkObjectType 0 "about" "name" Nothing $ rsValue (String "Fixmon agent")+ , mkObjectType 1 "about" "version" Nothing $ rsValue (String "0.0.1")+ , mkObjectType 1 "about" "version" ver $ rsValue (String "Alpha")+ , mkObjectType 2 "about" "comment" Nothing (rws m) + , mkObject 1 "Fixmon" "dyn" Nothing+ , mkObjectType 0 "dyn" "counter" Nothing (rwi i)+ , mkObject 1 "dyn" "trees" (Just $ dynTree i)+ ]++tree :: IO [MIB]+tree = do+ m <- newIORef (String "init")+ i <- newIORef (Integer 0)+ return $ simpleTree m i+ +main :: IO ()+main = agent "/var/agentx/master" [1,3,6,1,4,1,44729] Nothing =<< tree+
+ src/Network/Protocol/Snmp/AgentX.hs view
@@ -0,0 +1,203 @@+module Network.Protocol.Snmp.AgentX ( +-- * About+-- $about+ MIB+, Value(..)+, PVal(..)+, rwValue+, rsValue+, rdValue+, Update(..)+, mkObject+, mkObjectType+, CommitError(..)+, TestError(..)+, UndoError(..)+, Context+, agent+, Client+-- * Usage+-- ** Imports+-- $imports++-- ** Desribe values for monitoring+-- $values++-- ** Build dynamic tree+-- $dynTree++-- ** Describe context +-- $context++-- ** Construct full tree+-- $fullTree++-- ** Start subagent+-- $dowork++-- ** Examples+-- $config+)+where++import Network.Protocol.Snmp +import Network.Protocol.Snmp.AgentX.Service +import Network.Protocol.Snmp.AgentX.MIBTree +import Network.Protocol.Snmp.AgentX.Packet ++{- $about+Library for write extensible SNMP agents.+-}++{- $imports+> {-# LANGUAGE OverloadedStrings #-}+> {-# LANGUAGE ScopedTypeVariables #-}+> {-# LANGUAGE RankNTypes #-}+> module Main where+> +> import Network.Protocol.Snmp.AgentX +> import qualified Data.ByteString as BS+> import Data.ByteString (ByteString)+> import Data.Fixed (div')+> import Data.Time.Clock.POSIX (getPOSIXTime)+> import Control.Applicative ((<$>))+> import Control.Monad.State+> import Data.IORef+-}+++{- $values+> str :: ByteString -> PVal+> str x = rsValue (String x)+> +> now :: PVal+> now = rdValue $ TimeTicks . flip div' 1 <$> liftIO getPOSIXTime+> +> rws :: IORef Value -> PVal+> rws io = rwValue readV commit test undo+> where+> test (String x) +> | BS.length x < 10 = return NoTestError+> | otherwise = return TooBig+> test _ = return WrongType+> commit v = do+> writeIORef io v+> return NoCommitError+> undo _ = return NoUndoError+> readV = readIORef io+> +> rwi :: IORef Value -> PVal+> rwi io = rwValue readV commit test undo+> where+> test (Integer x) +> | x < 5 = return NoTestError+> | otherwise = return TooBig+> test _ = return WrongType+> commit v = do+> writeIORef io v+> return NoCommitError+> undo _ = return NoUndoError+> readV = readIORef io+-}++{- $dynTree+> dynTree :: IORef Value -> Update+> dynTree i = Update $ do+> Integer count <- liftIO $ readIORef i+> return $ concatMap fun [0 .. count]+> where+> fun x = [ mkObject (fromIntegral x) "trees" ("tree" ++ show x) Nothing+> , mkObjectType 0 ("tree" ++ show x) "abr" Nothing (str "abr")+> , mkObjectType 1 ("tree" ++ show x) "abrvalg" Nothing (str "abrvalg")+> ]+> +-}++{- $context+> ver :: Maybe Context+> ver = Just "version"+-}++{- $fullTree+> simpleTree :: IORef Value -> IORef Value -> [MIB]+> simpleTree m i = +> [ mkObject 0 "Fixmon" "about" Nothing+> , mkObjectType 0 "about" "name" Nothing $ rsValue (String "Fixmon agent")+> , mkObjectType 1 "about" "version" Nothing $ rsValue (String "0.0.1")+> , mkObjectType 1 "about" "version" ver $ rsValue (String "Alpha")+> , mkObjectType 2 "about" "comment" Nothing (rws m) +> , mkObject 1 "Fixmon" "dyn" Nothing+> , mkObjectType 0 "dyn" "counter" Nothing (rwi i)+> , mkObject 1 "dyn" "trees" (Just $ dynTree i)+> ]+> +> tree :: IO [MIB]+> tree = do+> m <- newIORef (String "init")+> i <- newIORef (Integer 0)+> return $ simpleTree m i+> +-}+ +{- $dowork+> main :: IO ()+> main = agent "/var/agentx/master" [1,3,6,1,4,1,44729] Nothing =<< tree+> +-}++{- $config+> SNMP server config+> > cat /etc/snmp/snmpd.conf+> > rwuser sha+> > createUser sha SHA "password" DESi+> > master agentx+> > agentXPerms 777 775+> +> SNMP client config+> > cat /etc/snmp/snmp.conf+> > defVersion 3+> > defSecurityName sha+> > defSecurityLevel authPriv+> > defPassphrase password+> > defAuthType SHA+> > defPrivType DES+> > defContext ""+> +> Build and start example+> > cabal install example+> > .cabal-sandbox/bin/example+> > .cabal-sandbox/bin/agentx+> > "set sid SessionID 15"+> > "R ([1,3,6,1,4,1,44729,1,1,0,1],Nothing)"+> > "R ([1,3,6,1,4,1,44729,1,1,0,0],Nothing)"+> > "R ([1,3,6,1,4,1,44729,1,0],Nothing)"+> > "R ([1,3,6,1,4,1,44729,0,2],Nothing)"+> > "R ([1,3,6,1,4,1,44729,0,1],Just (Context \"version\"))"+> > "R ([1,3,6,1,4,1,44729,0,1],Nothing)"+> > "R ([1,3,6,1,4,1,44729,0,0],Nothing)"+> +> Get MIB tree+> > snmpwalk -r 1 -On localhost 1.3.6.1.4.1.44729+> > .1.3.6.1.4.1.44729.0.0 = STRING: "Fixmon agent"+> > .1.3.6.1.4.1.44729.0.1 = STRING: "0.0.1"+> > .1.3.6.1.4.1.44729.0.2 = STRING: "init"+> > .1.3.6.1.4.1.44729.1.0 = INTEGER: 0+> > .1.3.6.1.4.1.44729.1.1.0.0 = STRING: "abr"+> > .1.3.6.1.4.1.44729.1.1.0.1 = STRING: "abrvalg"+> +> Change MIB tree +> > snmpset -r 1 -On localhost .1.3.6.1.4.1.44729.1.0 i 2+> > .1.3.6.1.4.1.44729.1.0 = INTEGER: 2+> > snmpwalk -r 1 -On localhost 1.3.6.1.4.1.44729+> > .1.3.6.1.4.1.44729.0.0 = STRING: "Fixmon agent"+> > .1.3.6.1.4.1.44729.0.1 = STRING: "0.0.1"+> > .1.3.6.1.4.1.44729.0.2 = STRING: "init"+> > .1.3.6.1.4.1.44729.1.0 = INTEGER: 2+> > .1.3.6.1.4.1.44729.1.1.0.0 = STRING: "abr"+> > .1.3.6.1.4.1.44729.1.1.0.1 = STRING: "abrvalg"+> > .1.3.6.1.4.1.44729.1.1.1.0 = STRING: "abr"+> > .1.3.6.1.4.1.44729.1.1.1.1 = STRING: "abrvalg"+> > .1.3.6.1.4.1.44729.1.1.2.0 = STRING: "abr"+> > .1.3.6.1.4.1.44729.1.1.2.1 = STRING: "abrvalg"+> +-}
+ src/Network/Protocol/Snmp/AgentX/MIBTree.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE RankNTypes #-}+module Network.Protocol.Snmp.AgentX.MIBTree ( + MIBTree+-- ** Module+, Module+-- *** create and init Module+, mkModule+, initModule+, registerFullTree+, unregisterFullTree+, askTree+, regByDiff+-- *** lenses for Module+, moduleOID+, register+, zipper+, ou+-- *** functions for work with MIBTree+, findOne+, findMany+, findNext+, findManyNext+-- ** MIB+, Parent+, Name+, MIB+-- *** lenses+, oi+, val+, context+-- *** constructors+, mkObject+, mkObjectType+, isObjectType+-- ** raw values for build SNMP subagent+, Update(..)+, PVal(..)+, isWritable+-- *** helpers for create PVal+, rsValue+, rdValue+, rwValue+, regWrapper+, mibToVarBind+)+where+import Network.Protocol.Snmp.AgentX.MIBTree.MIBTree+import Network.Protocol.Snmp.AgentX.MIBTree.Types++
+ src/Network/Protocol/Snmp/AgentX/MIBTree/MIBTree.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Network.Protocol.Snmp.AgentX.MIBTree.MIBTree +( initModule+, registerFullTree+, unregisterFullTree+, findOne+, findMany+, findNext+, findClosest+, findManyNext+, regWrapper+, askTree+, regByDiff+)+where++import Data.Maybe +import Control.Applicative+import Control.Monad.State.Strict (MonadIO, forM_, lift, get, put, liftIO, when)+import Network.Protocol.Snmp.AgentX.MIBTree.Types hiding (context)+import Network.Protocol.Snmp.AgentX.MIBTree.Tree +import Network.Protocol.Snmp (OID, Value(EndOfMibView, NoSuchInstance, NoSuchObject))+import Network.Protocol.Snmp.AgentX.Packet (Context, SearchRange, startOID, endOID, include)+import Control.Concurrent.MVar+import qualified Data.Label as L+import Data.List (stripPrefix)++import Data.Monoid+import Data.Label.Monadic+import Control.Category ((.))+import Prelude hiding ((.))+-- import Debug.Trace++-- | build tree and init module+initModule :: (Monad m, MonadIO m, Functor m) => MIBTree m ()+initModule = flip forM_ evalTree =<< toUpdateList <$> gets ou + where+ evalTree :: (Monad m, MonadIO m, Functor m) => MIB -> MIBTree m ()+ evalTree obj = do+ (mibs, updates) <- buildTree <$> (lift $ unUpdate . fromJust . update $ obj)+ case updates of+ Empty -> do -- if without updates just attach subtree+ modify zipper $ top . attach mibs . (fromJust . setCursor (oi obj) Nothing) . top+ modify ou $ top . attach updates . (fromJust . setCursor (oi obj) Nothing) . top+ _ -> do -- if with updates, save state, build new subtree, return state, and attach builded subtree+ modify zipper $ fromJust . setCursor (oi obj) Nothing . top+ modify ou $ fromJust . setCursor (oi obj) Nothing . top+ old <- get+ modify zipper $ const (mibs, [])+ modify ou $ const (updates, [])+ initModule+ Module (z,_) (o,_) _ _ <- get+ put old+ modify zipper $ top . attach z+ modify ou $ top . attach o++-- | register all MIBs in snmp server+registerFullTree :: (Monad m, MonadIO m, Functor m) => MIBTree m ()+registerFullTree = do+ z <- fst . top <$> gets zipper + mv <- gets register+ b <- gets moduleOID+ liftIO $ putMVar mv (addBaseOid b $ regPair z Empty)++unregisterFullTree :: (Monad m, MonadIO m, Functor m) => MIBTree m ()+unregisterFullTree = do+ z <- fst . top <$> gets zipper + mv <- gets register+ b <- gets moduleOID+ liftIO $ putMVar mv (addBaseOid b $ regPair Empty z)++askTree :: (Monad m, MonadIO m, Functor m) => MIBTree m (Tree IValue)+askTree = fst . top <$> gets zipper++regByDiff :: (Monad m, MonadIO m, Functor m) => Tree IValue -> Tree IValue -> MIBTree m ()+regByDiff old new = do+ mv <- gets register+ b <- gets moduleOID+ liftIO $ putMVar mv (addBaseOid b $ regPair old new)+++addBaseOid :: OID -> ([(OID, Maybe Context)], [(OID, Maybe Context)]) -> ([(OID, Maybe Context)], [(OID, Maybe Context)])+addBaseOid b (reg, unreg) = (map fun reg, map fun unreg)+ where+ fun (o, mc) = (b <> o, mc)++toUpdateList :: Zipper Tree IUpdate -> [MIB]+toUpdateList (Empty, _) = []+toUpdateList (t, _) = toUpdateList' ([], t)+ where+ toUpdateList' :: (OID, Tree IUpdate) -> [MIB]+ toUpdateList' (o, Node x next level) = + if withValue x+ then Object (reverse $ index x : o) (index x) "" "" (valueFromContexted x) + : toUpdateList' (o, next) + <> toUpdateList' (index x : o, level)+ else toUpdateList' (o, next)+ <> toUpdateList' (index x : o, level)+ toUpdateList' _ = []+ valueFromContexted (Contexted (_, _, x)) = x++inRange :: SearchRange -> MIB -> MIB +inRange s m =+ if (L.get startOID s) <= oi m && oi m < (L.get endOID s)+ then ObjectType (oi m) (last $ oi m) "" "" Nothing (val m)+ else ObjectType (L.get startOID s) (last $ L.get startOID s) "" "" Nothing (rsValue EndOfMibView)++-- | find one MIB +findOne :: (Monad m, MonadIO m, Functor m) => + OID -- ^ path for find+ -> Maybe Context -- ^ context, you can have many values with one path and different context+ -> MIBTree m MIB +findOne ys mcontext = do+ -- init zippers+ modify zipper top+ modify ou top+ modOID <- gets moduleOID+ -- strip module prefix+ case stripPrefix modOID ys of+ Nothing -> return $ ObjectType ys (last ys) "" "" mcontext nso+ Just ys' -> do+ updates <- gets ou+ -- put update subtree to state+ puts ou (updateSubtree ys' updates)+ -- update dynamic branches+ initModule+ -- get back full update tree+ puts ou updates+ -- find+ findOne' ys' <$> gets zipper+ where+ findOne' xs z = toObject $ setCursor xs mcontext z++ toObject Nothing = ObjectType ys (last ys) "" "" mcontext nsi+ toObject (Just (Node (Contexted (i, _, v)) _ Empty, _)) = ObjectType ys i "" "" mcontext (fromMaybe nso v)+ toObject _ = ObjectType ys (last ys) "" "" mcontext nso++ nso, nsi :: PVal + nso = rsValue NoSuchObject+ nsi = rsValue NoSuchInstance++updateSubtree :: Contexted a => OID -> Zipper Tree a -> Zipper Tree a+updateSubtree xs z =+ let (x, u) = goClosest xs Nothing z+ isLevel (Level _) = True+ isLevel _ = False+ cleanUnused (Level (Node v _ l)) = Level (Node v Empty l)+ cleanUnused _ = error "cleanUnused"+ cleanHead Empty = Empty+ cleanHead (Node v _ l) = Node v Empty l+ in top (cleanHead x, map cleanUnused $ filter isLevel u)++-- | wrap MIBTree action, get MIB tree before and after, register added mibs, unregister removed mibs+regWrapper :: (Monad m, MonadIO m, Functor m) => MIBTree m x -> MIBTree m x+regWrapper x = do+ old <- fst . top <$> gets zipper + r <- x+ new <- fst . top <$> gets zipper + mv <- gets register+ b <- gets moduleOID+ let diff = addBaseOid b $ regPair new old+ when (diff /= ([], [])) $ do+ liftIO $ putMVar mv diff+ return r+++-- | like findOne, but for many paths+findMany :: (Monad m, MonadIO m, Functor m) => [OID] -> Maybe Context -> MIBTree m [MIB]+findMany xs mc = mapM (flip findOne mc) xs++-- | find next node in MIBTree +findNext :: (Monad m, MonadIO m, Functor m) => + SearchRange -- ^ SearchRange (getwalk or getnext requests)+ -> Maybe Context -- ^ context+ -> MIBTree m MIB -- ^ search result+findNext sr mcontext = do+ modify zipper top+ modify ou top+ modOID <- gets moduleOID+ let start = L.get startOID sr+ end = L.get endOID sr+ case (stripPrefix modOID start, stripPrefix modOID end) of+ (Nothing, _) -> return $ ObjectType start (last start) "" "" mcontext eom+ (Just start', Just end') -> do+ updates <- gets ou+ puts ou (updateSubtree start' updates)+ initModule+ puts ou updates+ let fixSearchRange = L.set startOID start' . L.set endOID end' + fixMib modOID . findNext' (fixSearchRange sr) <$> gets zipper+ _ -> error "findNext"++ where+ eom :: PVal+ eom = rsValue EndOfMibView++ fixMib :: OID -> MIB -> MIB+ fixMib m (ObjectType o i _ _ mc v) = ObjectType (m <> o) i "" "" mc v+ fixMib _ _ = error "fixMib"++ findNext' :: SearchRange -> Zipper Tree IValue -> MIB+ findNext' sr' z + | L.get include sr' =+ let start = L.get startOID sr'+ nz@(Node v _ _, _) = goClosest start mcontext z + o = oid nz+ Contexted (i, mc, Just pv) = v+ in if o == start && withValue v && mc == mcontext+ then ObjectType o i "" "" mc pv+ else findNext' (L.set include False $ sr') z+ | otherwise =+ let start = L.get startOID sr'+ nz = goClosest start mcontext z+ l = hasLevel nz+ n = hasNext nz+ in case (l, n) of+ (True, _) -> inRange sr' $ findClosest False start mcontext (fromJust $ goLevel nz)+ (False, True) -> inRange sr' $ findClosest False start mcontext (fromJust $ goNext nz)+ (False, False) -> inRange sr' $ findClosest True start mcontext (fromJust $ goUp nz)++findClosest :: Bool -> OID -> Maybe Context -> Zipper Tree IValue -> MIB+findClosest back o mcontext z =+ let (canBeObject, checkContextEquality) = isFocusObjectType z+ magic = if back + then not (hasLevel z)+ else (hasLevel z)+ isNextAvailable = hasNext z+ in case (canBeObject, checkContextEquality mcontext, magic, isNextAvailable) of+ (True, True, _, _ ) -> getFocus z + (_, _, True, _ ) -> findClosest False o mcontext (fromJust $ goLevel z)+ (_, _, False, True ) -> findClosest False o mcontext (fromJust $ goNext z)+ _ -> case goUp z of+ Just nz -> findClosest True o mcontext nz+ Nothing -> ObjectType o (last o) "" "" Nothing (rsValue EndOfMibView)++isFocusObjectType :: Contexted a => (Tree a, t) -> (Bool, Maybe Context -> Bool)+isFocusObjectType (Node v _ Empty,_) = (withValue v, (==) (context v))+isFocusObjectType _ = (False, const False)++getFocus :: Zipper Tree IValue -> MIB+getFocus z@(Node (Contexted (i, mc, Just v)) _ _, _) = + let o = oid z+ in ObjectType o i "" "" mc v+getFocus _ = error "getFocus"++-- | like findNext+findManyNext :: (Monad m, MonadIO m, Functor m) => [SearchRange] -> Maybe Context -> MIBTree m [MIB]+findManyNext xs mc = mapM (flip findNext mc) xs++
+ src/Network/Protocol/Snmp/AgentX/MIBTree/Tree.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+module Network.Protocol.Snmp.AgentX.MIBTree.Tree +( Zippers(..)+, Contexted(..)+, Tree(..)+, Zipper+, hasNext+, hasLevel+, goClosest+, Move(..)+, regPair+)+where++import Data.Maybe (fromJust)+import Data.Monoid hiding (First)+import Network.Protocol.Snmp.AgentX.Packet (Context)+import Network.Protocol.Snmp (OID)+import Data.Algorithm.Diff+import Data.List (sort)+import Prelude ++data Move b a = Next (b a)+ | Level (b a)++instance (Show a, Show (b a)) => Show (Move b a) where+ show (Next x) = "\nNext " ++ show x+ show (Level x) = "\nLevel " ++ show x++type Moving b a = [Move b a]++type Zipper b a = (b a, Moving b a)++class Zippers b where+ toZipper :: b a -> Zipper b a+ attach :: b a -> Zipper b a -> Zipper b a+ goNext :: Zipper b a -> Maybe (Zipper b a)+ goLevel :: Zipper b a -> Maybe (Zipper b a)+ goBack :: Zipper b a -> Maybe (Zipper b a)+ goUp :: Zipper b a -> Maybe (Zipper b a)+ top :: Zipper b a -> Zipper b a+ oid :: Contexted a => Zipper b a -> OID+ cursor :: Contexted a => Zipper b a -> Maybe (Integer, Maybe Context)+ setCursor :: Contexted a => OID -> Maybe Context -> Zipper b a -> Maybe (Zipper b a)++data Tree a = Node a (Tree a) (Tree a)+ | Empty+ deriving (Functor, Eq)++class Contexted a where+ index :: a -> Integer+ context :: a -> Maybe Context+ withValue :: a -> Bool++instance Contexted a => Monoid (Tree a) where+ mempty = Empty+ mappend a Empty = a+ mappend Empty a = a+ mappend (Node v next link) x@(Node v1 next1 link1)+ | index v == index v1 && context v == context v1 = Node v (next <> next1) (link <> link1) + | otherwise = Node v (next <> x) link +++instance (Contexted a, Show a) => Show (Tree a) where+ show f = unlines $ drawLevel f+ where+ drawLevel Empty = []+ drawLevel (Node v next link) = (show (index v) <> " " <> show v <> " ") : (drawSubtree next link)++ drawSubtree next link = (shift "`- " " | " (drawLevel link)) <> drawLevel next+ + shift first rest = zipWith (++) (first : repeat rest)++-- testTree :: Tree (Integer, Maybe String)+-- testTree = Node (0, Just "first") (Node (1, Just "second") Empty Empty) (Node (10, Just "third") Empty Empty)++instance Contexted (Integer, Maybe String) where+ index = fst+ context = undefined+ withValue (_, Nothing) = False+ withValue _ = True++instance Zippers Tree where+ toZipper t = (t, [])++ attach t (Empty, bs) = (t, bs)+ attach t (Node v next _, bs) = (Node v next t, bs)++ goNext (Empty, _) = Nothing+ goNext (Node _ Empty _, _) = Nothing+ goNext (Node x next link, bs) = Just (next, Next (Node x Empty link):bs)++ goLevel (Empty, _) = Nothing+ goLevel (Node _ _ Empty, _) = Nothing+ goLevel (Node x next link, bs) = Just (link, Level (Node x next Empty):bs)++ goBack (_, []) = Nothing+ goBack (t, Next (Node x Empty link):bs) = Just (Node x t link, bs)+ goBack (t, Level (Node x next Empty):bs) = Just (Node x next t , bs)+ goBack _ = Nothing++ goUp (_, []) = Nothing+ goUp (t, Next (Node x Empty link ):bs) = goUp (Node x t link, bs)+ goUp (t, Level (Node x next Empty):bs) = Just (Node x next t , bs)+ goUp _ = Nothing++ top (t,[]) = (t,[]) + top z = top (fromJust $ goBack z)++ oid (z, m) = foldl fun [gi z] m+ where + fun xs (Next{}) = xs+ fun xs (Level x) = gi x : xs+ gi :: Contexted a => Tree a -> Integer+ gi (Node x _ _) = index x+ gi _ = error "oid"++ setCursor [] _ z = Just (top z)+ setCursor ys c z = walk ys (top z)+ where+ giz (Node x _ _ , _) = (index x, context x)+ giz _ = error "setCursor: giz Empty Tree"+ walk [] t = Just t+ walk (x : []) t+ | (x, c) == giz t = Just t+ | otherwise = goNext t >>= walk (x : []) + walk (x : xs) t + | x == fst (giz t) = goLevel t >>= walk xs + | otherwise = goNext t >>= walk (x : xs) ++ cursor ((Node v _ _), _) = Just (index v, context v)+ cursor (Empty , _) = Nothing++hasLevel :: Zipper Tree a -> Bool+hasLevel (Node _ _ Empty, _) = False+hasLevel _ = True++hasNext :: Zipper Tree a -> Bool+hasNext (Node _ Empty _, _) = False+hasNext _ = True++goClosest :: Contexted a => OID -> Maybe Context -> Zipper Tree a -> Zipper Tree a+goClosest [] _ z = top z+goClosest ys c z = walk ys (top z)+ where+ giz (Node x _ _, _) = (index x, context x)+ giz _ = error "goClosest: giz Empty Tree"+ walk [] z' = z'+ walk (x : []) z'+ | (x,c) == giz z' = z'+ | otherwise = maybe z' (walk (x : [])) (goNext z')+ walk (x : xs) z'+ | x == fst (giz z') = maybe z' (walk xs) (goLevel z')+ | otherwise = maybe z' (walk (x : xs)) (goNext z')++type RegType = [(OID, Maybe Context)]+type ToRegistrate = [(OID, Maybe Context)]+type ToUnRegistrate = [(OID, Maybe Context)]+ +toVList :: Contexted a => (OID, Tree a) -> RegType+toVList (path, Node a Empty Empty)+ | withValue a = [(index a : path, context a)]+ | otherwise = []+toVList (path, Node a level next) + | withValue a = (index a : path, context a) : toVList (path, level) <> toVList (index a : path, next)+ | otherwise = toVList (path, level) <> toVList (index a : path, next)+toVList (_, Empty) = []++regPair :: Contexted a => Tree a -> Tree a -> (ToRegistrate, ToUnRegistrate)+regPair old new = splitDiff $ getDiff (reverseOid $ toVList ([], old)) (reverseOid $ toVList ([], new))++reverseOid :: [(OID, Maybe Context)] -> [(OID, Maybe Context)]+reverseOid = sort . map fun + where+ fun (xs, mc) = (reverse xs, mc)++splitDiff :: [Diff a] -> ([a], [a])+splitDiff = splitDiff' ([], []) + where+ splitDiff' (toUnReg, toReg) [] = (toUnReg, toReg)+ splitDiff' (toUnReg, toReg) (Both _ _ : xs) = splitDiff' (toUnReg, toReg) xs+ splitDiff' (toUnReg, toReg) (First x : xs) = splitDiff' (x : toUnReg, toReg) xs+ splitDiff' (toUnReg, toReg) (Second x : xs) = splitDiff' (toUnReg, x : toReg) xs
+ src/Network/Protocol/Snmp/AgentX/MIBTree/Types.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+module Network.Protocol.Snmp.AgentX.MIBTree.Types +( PVal(..)+, rsValue+, rwValue+, rdValue+, Update(..)+, Module(..)+, mkModule+, MIB(..)+, mkObject+, mkObjectType+, mibToVarBind+, isObjectType+, Parent+, Name+, ou+, moduleOID+, MIBTree+, buildTree+, register+, isWritable+, zipper+, IUpdate+, IValue+, ContextedValue(..)+)+where++import Control.Monad.State.Strict +import Control.Concurrent.MVar+import Data.Monoid ((<>))+import Data.Foldable (foldMap)+import Data.Label++import Network.Protocol.Snmp.AgentX.MIBTree.Tree +import Network.Protocol.Snmp (Value(..), OID)+import Network.Protocol.Snmp.AgentX.Packet (Context, CommitError, TestError, UndoError, VarBind, mkVarBind)++-- | Wrapper for value+data PVal = Read + { readAIO :: IO Value + }+ | ReadWrite + { readAIO :: IO Value+ , commitSetAIO :: Value -> IO CommitError+ , testSetAIO :: Value -> IO TestError+ , undoSetAIO :: Value -> IO UndoError+ }++-- | Update, for rebuild oid tree in runtime+newtype Update = Update { unUpdate :: forall m . (Monad m, MonadIO m, Functor m) => m [MIB] }++type IValue = ContextedValue PVal +type IUpdate = ContextedValue Update ++instance Show PVal where+ show Read{} = "Read Value"+ show ReadWrite{} = "ReadWrite Value"++type Parent = String+type Name = String++-- | MIB describe objects and object-types in internal tree with data.+data MIB = Object+ { oi :: OID -- ^ accessor for OID+ , int :: Integer+ , parent :: Parent+ , name :: Name+ , update :: Maybe Update + } | ObjectType+ { oi :: OID+ , int :: Integer+ , parent :: Parent+ , name :: Name+ , context :: Maybe Context -- ^ accessor for Maybe Context+ , val :: PVal -- ^ accessor for PVal+ }++deriving instance Show MIB ++instance Show Update where+ show _ = "Update Subtree Fun"++newtype ContextedValue a = Contexted { unContext :: (Integer, Maybe Context, Maybe a) }++instance Contexted (ContextedValue a) where+ index (Contexted (i, _, _)) = i+ context (Contexted (_, c, _)) = c+ withValue (Contexted (_, _, Just _)) = True+ withValue _ = False++instance Show a => Show (ContextedValue a) where+ show (Contexted (_, Nothing, Nothing)) = "- node -"+ show (Contexted (_, Nothing, Just v)) = "- leaf " <> show v+ show (Contexted (_, Just c, Just v)) = "- contexted leaf " <> show c <> show v+ show _ = "bad node"++-- | internal state for build SNMP submodule+data Module = Module+ { _zipper :: Zipper Tree IValue + , _ou :: Zipper Tree IUpdate+ , _moduleOID :: OID+ , _register :: MVar ([(OID, Maybe Context)], [(OID, Maybe Context)])+ } ++mkLabel ''Module++instance Show Module where+ show (Module z ou' _ _) = show z ++ "\n" ++ show ou'++-- | MIBTree, state transformer, with Module under ground+type MIBTree = StateT Module ++-- | Constructor for Module+mkModule :: (Monad m, MonadIO m, Functor m) => + OID -- ^ base module OID+ -> [MIB] -- ^ all MIB for create module+ -> m Module +mkModule moduleOid mibs = do+ reg <- liftIO $ newEmptyMVar+ return $ Module (toZipper . fst . buildTree $ mibs) (toZipper . snd . buildTree $ mibs) moduleOid reg++buildTree :: [MIB] -> (Tree IValue, Tree IUpdate)+buildTree ms = foldMap singleton $ fillOid ms+ where+ singleton :: MIB -> (Tree IValue , Tree IUpdate)+ singleton m = singleton' (oi m, m)++ singleton' :: (OID, MIB) -> (Tree IValue, Tree IUpdate)+ singleton' ([], _) = (Empty, Empty)+ singleton' ([_], Object _ i _ _ Nothing) = (Node (zero i) Empty Empty, Empty )+ singleton' ([_], Object _ i _ _ u@_) = (Node (zero i) Empty Empty, Node (toC i Nothing u) Empty Empty )+ singleton' ([_], ObjectType _ i _ _ c v) = (Node (toC i c (Just v)) Empty Empty, Empty)+ singleton' ((i:xs), obj@(Object _ _ _ _ Nothing)) = (Node (zero i) Empty (fst $ singleton' (xs, obj)), Empty)+ singleton' ((i:xs), obj@(Object _ _ _ _ _)) = (Node (zero i) Empty (fst $ singleton' (xs, obj)), Node (zero i) Empty (snd $ singleton' (xs, obj)))+ singleton' ((i:xs), obj@(ObjectType{})) = (Node (zero i) Empty (fst $ singleton' (xs, obj)), Empty)++ toC :: Integer -> Maybe Context -> Maybe a -> ContextedValue a+ toC i mc mv = Contexted (i, mc, mv)++ zero :: Integer -> ContextedValue a+ zero i = Contexted (i, Nothing, Nothing)+++-- | check MIB subtype+isObjectType :: MIB -> Bool+isObjectType (ObjectType{}) = True+isObjectType _ = False++-- | Constructor for MIB, create Object in mib tree+mkObject :: Integer -- ^ OID number for this object+ -> Parent -- ^ parent name for this object+ -> Name -- ^ name for this object+ -> Maybe Update -- ^ Just Update if you need dynamic module+ -> MIB -- ^ created MIB+mkObject = Object [] ++-- | Constructor for MIB, create Object-Type in mib tree+mkObjectType :: Integer -- ^ OID number for this object+ -> Parent -- ^ parent+ -> Name -- ^ name+ -> Maybe Context -- ^ context+ -> PVal -- ^ value+ -> MIB -- ^ created MIB +mkObjectType = ObjectType []++fillOid :: [MIB ] -> [MIB ]+fillOid [] = []+fillOid (ObjectType o i p n v u : xs) + | o == [] = ObjectType [i] i p n v u : mkOid' [(p, []), (n, [i])] xs+ | otherwise = ObjectType o i p n v u : mkOid' [(p, []), (n, o)] xs+ where+ mkOid' :: [(Parent, OID)] -> [MIB ] -> [MIB ]+ mkOid' _ [] = []+ mkOid' base (y:ys) =+ let Just prev = lookup (parent y) base+ newbase = (name y, prev <> [int y]) : base+ in addOid prev y : mkOid' newbase ys+ addOid :: OID -> MIB -> MIB + addOid o' (Object _ i' p' n' u') = Object (o' <> [i']) i' p' n' u'+ addOid o' (ObjectType _ i' p' n' v' u') = ObjectType (o' <> [i']) i' p' n' v' u'+fillOid (Object o i p n u : xs) + | o == [] = Object [i] i p n u : mkOid' [(p, []), (n, [i])] xs+ | otherwise = Object o i p n u : mkOid' [(p, []), (n, o)] xs+ where+ mkOid' :: [(Parent, OID)] -> [MIB ] -> [MIB ]+ mkOid' _ [] = []+ mkOid' base (y:ys) =+ let Just prev = lookup (parent y) base+ newbase = (name y, prev <> [int y]) : base+ in addOid prev y : mkOid' newbase ys+ addOid :: OID -> MIB -> MIB + addOid o' (Object _ i' p' n' u') = Object (o' <> [i']) i' p' n' u'+ addOid o' (ObjectType _ i' p' n' v' u') = ObjectType (o' <> [i']) i' p' n' v' u'++-- | PVal constructor for read only value+rsValue :: Value -> PVal +rsValue v = Read $ return v++-- | PVal constructor for read only IO Value +rdValue :: IO Value -> PVal +rdValue = Read ++-- | PVal constructor for read write value+rwValue :: IO Value -> (Value -> IO CommitError) -> (Value -> IO TestError) -> (Value -> IO UndoError) -> PVal +rwValue = ReadWrite++-- | check for PVal+isWritable :: PVal -> Bool+isWritable ReadWrite{} = True+isWritable _ = False++-- | convert MIB to VarBind+mibToVarBind :: (Monad m, MonadIO m, Functor m) => MIB -> m VarBind+mibToVarBind m = do+ v <- liftIO $ readAIO (val m) + return $ mkVarBind (oi m) v+
+ src/Network/Protocol/Snmp/AgentX/Packet.hs view
@@ -0,0 +1,66 @@+module Network.Protocol.Snmp.AgentX.Packet ( +-- ** Packet + Packet+-- *** constructor+, mkPacket+-- *** lenses for Packet+, pdu+, flags+, tid+, pid+, sid+-- *** types used in Packet+, PDU(..)+, PacketID+, SessionID+, TransactionID+-- ** Flags +, Flags+, InstanceRegistration +, NewIndex +, AnyIndex +, NonDefaultContext +, BigEndian +-- *** constructor+, mkFlags+-- *** lenses+, instanceRegistration+, newIndex+, anyIndex+, nonDefaultContext+, bigEndian+-- ** SearchRange +, SearchRange+-- *** constructor+, mkSearchRange+-- *** lenses+, startOID+, endOID+, include+-- ** VarBind +, VarBind+-- *** constructor+, mkVarBind+-- *** lenses+, vboid+, vbvalue+-- ** other types+, Context+, SysUptime+, Index+, NonRepeaters+, MaxRepeaters+-- ** types for errors +, RError(..)+, UndoError(..)+, TestError(..)+, CommitError(..)+, TaggedError(..)+-- ** helpers+, bodySizeFromHeader+, econvert+)+where++import Network.Protocol.Snmp.AgentX.Packet.Types+import Network.Protocol.Snmp.AgentX.Packet.Binary
+ src/Network/Protocol/Snmp/AgentX/Packet/Binary.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Network.Protocol.Snmp.AgentX.Packet.Binary +( bodySizeFromHeader )+where++import Data.Binary+import Network.Protocol.Snmp.AgentX.Packet.Types ( Packet )+import Network.Protocol.Snmp.AgentX.Packet.Get ( getPacket, bodySizeFromHeader )+import Network.Protocol.Snmp.AgentX.Packet.Put ( putPacket )++instance Binary Packet where+ put = putPacket + get = getPacket
+ src/Network/Protocol/Snmp/AgentX/Packet/Get.hs view
@@ -0,0 +1,282 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Protocol.Snmp.AgentX.Packet.Get +( getPacket+, bodySizeFromHeader+)+where++import Network.Protocol.Snmp.AgentX.Packet.Types ( bigEndian+ , nonDefaultContext+ , unTag+ , Flags+ , mkFlags+ , PDU(..)+ , VarBind+ , mkVarBind+ , SearchRange+ , mkSearchRange+ , Context(..)+ , Packet+ , mkPacket+ , econvert+ )+import Network.Protocol.Snmp (Value(..), OID)++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Binary hiding (get)+import Data.Binary.Get +import Data.Bits.Bitwise (toListLE)+import Data.Monoid ((<>))+import Control.Applicative hiding (empty)+import Data.Int+import Data.Label++getPacket :: Get Packet+getPacket = do+ version <- econvert `fmap` getWord8 + pduTag <- getWord8+ flags <- decodeFlags <$> getWord8+ _reserved <- getWord8+ sid <- econvert `fmap` get32 flags + tid <- econvert `fmap` get32 flags + pid <- econvert `fmap` get32 flags + bodySize <- get32 flags + pdu <- parsePdu pduTag flags bodySize+ return $ mkPacket version pdu flags sid tid pid++decodeFlags :: Word8 -> Flags+decodeFlags x =+ let (i:n:a:nd:nb:_) = toListLE x+ in mkFlags i n a nd nb++get16 :: Flags -> Get Word16+get16 f = case get bigEndian f of+ True -> getWord16be+ False -> getWord16le++get32 :: Flags -> Get Word32+get32 f = case get bigEndian f of+ True -> getWord32be+ False -> getWord32le++get64 :: Flags -> Get Word64+get64 f = case get bigEndian f of+ True -> getWord64be+ False -> getWord64le++type Size = Word32+type Include = Bool++getBool :: Get Bool+getBool = do+ x <- getWord8 + case x of+ 1 -> return True+ 0 -> return False+ _ -> error "bad getBool"++getOid :: Flags -> Get (OID, Include)+getOid flags = do+ nSubId <- getWord8+ prefix <- getWord8+ include <- getBool+ _reserved <- getWord8+ end <- sequence $ replicate (fromIntegral nSubId) (get32 flags)+ case (nSubId, prefix) of+ (0, 0) -> return ([], include)+ (_, 0) -> return (map fromIntegral end, include)+ (_, x) -> return ([1,3,6,1] <> map fromIntegral (fromIntegral x:end), include)++getString :: Flags -> Get ByteString+getString bo = do+ l <- fromIntegral <$> get32 bo+ let fullLength = l + (4 - l `rem` 4) `rem` 4+ s <- getByteString fullLength+ return $ B.take l s++getContext :: Flags -> Get (Maybe Context)+getContext f = case (get nonDefaultContext f) of+ False -> return Nothing+ True -> Just <$> Context <$> getString f++getOidList :: Flags -> [OID] -> Get [OID]+getOidList bo xs = do+ (oi, _) <- getOid bo+ isEnd <- isEmpty+ if isEnd + then return $ reverse (addOi oi xs)+ else getOidList bo (addOi oi xs)+ where+ addOi [] xss = xss+ addOi oi xss = oi:xss++getSearchRange :: Flags -> Get SearchRange+getSearchRange bo = do+ (first, include) <- getOid bo+ (second, _) <- getOid bo+ return $ mkSearchRange first second include++getSearchRangeList :: Flags -> [SearchRange] -> Get [SearchRange]+getSearchRangeList bo xs = do+ sr <- getSearchRange bo+ isEnd <- isEmpty+ if isEnd+ then return $ reverse (sr:xs)+ else getSearchRangeList bo (sr:xs)++getValue :: Flags -> Word16 -> Get Value+getValue _ 0 = return ZeroDotZero+getValue bo 2 = Integer . fromIntegral <$> get32 bo+getValue bo 4 = String <$> getString bo+getValue _ 5 = return Zero+getValue bo 6 = OI . fst <$> getOid bo+getValue _ 64 = do+ a <- getWord8+ b <- getWord8+ c <- getWord8+ d <- getWord8+ return $ IpAddress a b c d+getValue bo 65 = Counter32 <$> get32 bo+getValue bo 66 = Gaude32 <$> get32 bo+getValue bo 67 = TimeTicks <$> get32 bo+getValue bo 68 = Opaque <$> getString bo+getValue bo 70 = Counter64 <$> get64 bo+getValue _ 128 = return NoSuchObject+getValue _ 129 = return NoSuchInstance+getValue _ 130 = return EndOfMibView+getValue _ v = error $ "getValue bad tag " ++ show v++getVarBind :: Flags -> Get VarBind+getVarBind bo = do+ valueTag <- get16 bo + _reserved <- getWord16be+ (oi, _) <- getOid bo+ v <- getValue bo valueTag + return $ mkVarBind oi v++getVarBindList :: Flags -> [VarBind] -> Get [VarBind]+getVarBindList bo xs = do+ vb <- getVarBind bo+ isEnd <- isEmpty+ if isEnd + then return $ reverse (vb:xs)+ else getVarBindList bo (vb:xs)++parsePdu :: Word8 -> Flags -> Size -> Get PDU+parsePdu t f s + | t == 1 = do+ -- Open+ time <- getWord8+ _reserved <- getWord8+ _reserved <- getWord8+ _reserved <- getWord8+ (o, _) <- getOid f+ d <- getString f+ return $ Open time o d+ | t == 2 = do+ -- Close+ reason <- unTag <$> getWord8+ _reserved <- getWord8+ _reserved <- getWord8+ _reserved <- getWord8+ return $ Close reason+ | t == 3 = do+ -- Register+ context <- getContext f+ timeout <- getWord8+ priority <- getWord8+ rsid <- getWord8+ _reserved <- getWord8+ (oid, _) <- getOid f+ case rsid of+ 0x00 -> return $ Register context timeout priority rsid oid Nothing+ _ -> Register context timeout priority rsid oid . Just <$> get32 f+ | t == 4 = do+ -- Unregister+ context <- getContext f+ priority <- getWord8+ rsid <- getWord8+ _reserved <- getWord8+ (oid, _) <- getOid f+ case rsid of+ 0x00 -> return $ Unregister context priority rsid oid Nothing+ _ -> Unregister context priority rsid oid . Just <$> get32 f+ | t == 5 = do+ -- Get+ context <- getContext f+ oil <- getOidList f []+ return $ Get context oil+ | t == 6 = do+ -- GetNext+ context <- getContext f+ srl <- getSearchRangeList f []+ return $ GetNext context srl+ | t == 7 = do+ -- GetBulk+ context <- getContext f+ nonRepeaters <- get16 f+ maxRepeaters <- get16 f+ srl <- getSearchRangeList f []+ return $ GetBulk context nonRepeaters maxRepeaters srl+ | t == 8 = do+ -- TestSet+ context <- getContext f+ vbl <- getVarBindList f []+ return $ TestSet context vbl+ | t == 9 = return $ CommitSet + | t == 10 = return $ UndoSet+ | t == 11 = return $ CleanupSet+ | t == 12 = do+ -- Notify+ context <- getContext f+ vbl <- getVarBindList f []+ return $ Notify context vbl+ | t == 13 = do+ -- Ping+ context <- getContext f+ return $ Ping context+ | t == 14 = do+ -- IndexAllocate+ context <- getContext f+ vbl <- getVarBindList f []+ return $ IndexAllocate context vbl+ | t == 15 = do+ -- IndexDeallocate+ context <- getContext f+ vbl <- getVarBindList f []+ return $ IndexDeallocate context vbl+ | t == 16 = do+ -- AddAgentCaps+ context <- getContext f+ (oi, _) <- getOid f+ description <- getString f+ return $ AddAgentCaps context oi description+ | t == 17 = do+ -- RemoveAgentCaps+ context <- getContext f+ (oi, _) <- getOid f+ return $ RemoveAgentCaps context oi+ | t == 18 = do+ -- Response+ sysuptime <- get32 f + rerror <- unTag <$> get16 f + index <- get16 f + if (s == 8)+ then return $ Response sysuptime rerror index []+ else Response sysuptime rerror index <$> (getVarBindList f [])+ | otherwise = error "parse pdu unknown tag"+++-- | get body size from header+bodySizeFromHeader :: BL.ByteString -> Int64+bodySizeFromHeader "" = 0+bodySizeFromHeader bs =+ let flags = decodeFlags (BL.index bs 2)+ s = BL.drop 16 bs+ in fromIntegral $ runGet (get32 flags) s++++
+ src/Network/Protocol/Snmp/AgentX/Packet/Put.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Network.Protocol.Snmp.AgentX.Packet.Put +( putPacket+) where++import Data.Binary.Put (putBuilder, Put)+import Data.Binary.Builder+import Data.Word+import Data.Monoid+import Data.Bits.Bitwise (fromListLE)+import Control.Monad.State.Strict hiding (gets)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Label.Monadic+import qualified Data.Label as DL+import qualified Data.Label.Monadic as DLM+import Control.Category ((.))+import Prelude hiding ((.))++import Network.Protocol.Snmp.AgentX.Packet.Types+import Network.Protocol.Snmp (Value(..), OID)++type Pack = State (Packet, Word32)++(packet, bodySize) = $(DL.getLabel ''(,))++putPacket :: Packet -> Put+putPacket p = putBuilder . evalState pack $ (p, 0)+ +packBody :: Pack Builder +packBody = packsz =<< DLM.gets (pdu . packet)++pack :: Pack Builder+pack = do+ !b <- packBody+ !s <- packSize+ p <- DLM.gets (pdu . packet)+ f <- packFlags+ sid' <- econvert `fmap` DLM.gets (sid . packet)+ pid' <- econvert `fmap` DLM.gets (pid . packet)+ tid' <- econvert `fmap` DLM.gets (tid . packet)+ psid <- pack32 sid'+ ppid <- pack32 pid'+ ptid <- pack32 tid'+ return $ singleton 1 <> singleton (tag p) <> f <> singleton 0 + <> psid <> ptid <> ppid <> s <> b++packSize :: Pack Builder +packSize = do+ s <- DLM.gets bodySize+ pack32 s +++fixSize :: Word32 -> Pack ()+fixSize x = DLM.modify bodySize (+ x)++packWord :: (w -> Builder) -> (w -> Builder) -> w -> Pack Builder+packWord be le w = do+ b <- gets ( bigEndian . flags . packet )+ if b then return (be w) else return (le w)++pack32 :: Word32 -> Pack Builder+pack32 = packWord putWord32be putWord32le ++packFlags :: Pack Builder+packFlags = do+ flags' <- gets (flags . packet )+ let a = DL.get instanceRegistration flags'+ b = DL.get newIndex flags'+ c = DL.get anyIndex flags'+ d = DL.get nonDefaultContext flags'+ e = DL.get bigEndian flags'+ return $ singleton $ fromListLE [a, b, c, d, e]++packBool :: Bool -> Pack Builder+packBool True = return $ singleton 1+packBool False = return $ singleton 0+++class SizedBuilder a where+ packsz :: a -> Pack Builder++instance SizedBuilder Word64 where+ packsz w = fixSize 8 >> packWord putWord64be putWord64le w++instance SizedBuilder Word32 where+ packsz w = fixSize 4 >> packWord putWord32be putWord32le w++instance SizedBuilder Word16 where+ packsz w = fixSize 2 >> packWord putWord16be putWord16le w++instance SizedBuilder Value where+ packsz (Integer x) = packsz (fromIntegral x :: Word32)+ packsz (Counter32 x) = packsz x + packsz (Counter64 x) = packsz x+ packsz (Gaude32 x) = packsz x+ packsz (TimeTicks x) = packsz x+ packsz (OI x) = packOID False x+ packsz (String x) = packsz x+ packsz (Opaque x) = packsz x+ packsz (IpAddress a b c d) = packsz $ B.pack [a,b,c,d]+ packsz _ = return empty++instance SizedBuilder ByteString where+ packsz bs = do+ s <- packsz bsLen+ fixSize bsLen+ fixSize tailLen+ return $ s <> fromByteString bs <> tailB+ where+ bsLen = fromIntegral $ B.length bs+ tailB = fromByteString $ B.replicate (fromIntegral tailLen) 0x00+ tailLen :: Word32+ tailLen = (4 - bsLen `rem` 4) `rem` 4++instance SizedBuilder Integer where+ packsz x = packsz (fromIntegral x :: Word32)++instance SizedBuilder VarBind where+ packsz vb = do+ t <- packsz (tag value' :: Word16)+ z <- packsz (0 :: Word16)+ oi <- packOID False oid'+ val <- packsz value'+ return $ t <> z <> oi <> val+ where+ oid' = DL.get vboid vb+ value' = DL.get vbvalue vb++instance SizedBuilder (Maybe Context) where+ packsz Nothing = fixContextFlags Nothing >> return empty+ packsz mc@(Just (Context c)) = fixContextFlags mc >> packsz c++instance SizedBuilder SearchRange where+ packsz x = do+ s <- packOID True (DL.get startOID x)+ e <- packOID False (DL.get endOID x)+ return $ s <> e++fixContextFlags :: Maybe Context -> Pack ()+fixContextFlags Nothing = DLM.modify (nonDefaultContext . flags . packet) (const False)+fixContextFlags _ = DLM.modify (nonDefaultContext . flags . packet) (const True)++type Include = Bool++packOID :: Include -> OID -> Pack Builder+packOID _ [] = fixSize 4 >> return (singleton 0 <> singleton 0 <> singleton 0 <> singleton 0)+packOID i xs@(1:3:6:1:[]) = do -- Not clearly in rfc!!!+ include' <- packBool i+ fixSize 4+ oi <- mapM packsz xs+ return $ singleton 4 <> singleton 0 <> include' <> singleton 0 <> mconcat oi+packOID i (1:3:6:1:ls) = do+ include' <- packBool i+ fixSize 4+ oi <- mapM packsz (tail ls)+ return $ singleton (fromIntegral (length ls - 1)) <> singleton (fromIntegral (head ls)) <> include' <> singleton 0 <> mconcat oi+packOID i xs = do+ include' <- packBool i+ fixSize 4+ oi <- mapM packsz xs+ return $ singleton (fromIntegral (length xs)) <> singleton 0 <> include' <> singleton 0 <> mconcat oi++instance SizedBuilder PDU where+ packsz (Open t o d) = do+ poid <- packOID False o+ pdescription <- packsz d + fixSize 4+ fixContextFlags Nothing+ return $ (singleton t) <> singleton 0 <> singleton 0 <> singleton 0 <> poid <> pdescription+ packsz (Close er) = do+ fixSize 4+ fixContextFlags Nothing+ return $ singleton (tag er) <> singleton 0 <> singleton 0 <> singleton 0+ packsz (Register mc t p rs oi mu) = do+ pcontext <- packsz mc+ up <- case (rs, mu) of+ (0, _) -> return empty+ (_, Just x) -> packsz x+ _ -> error "packPacket Register"+ poid <- packOID False oi+ fixSize 4+ return $ pcontext <> singleton t <> singleton p <> singleton rs <> singleton 0 <> poid <> up+ packsz (Unregister mc p rs oi mu) = do+ pcontext <- packsz mc+ up <- case (rs, mu) of+ (0, _) -> return empty+ (_, Just x) -> packsz x+ _ -> error "packPacket Unregister"+ poid <- packOID False oi+ fixSize 4+ return $ pcontext <> singleton 0 <> singleton p <> singleton rs <> singleton 0 <> poid <> up+ packsz (Get mc []) = do+ pcontext <- packsz mc+ return $ pcontext + packsz (Get mc (x:xs)) = do+ pcontext <- packsz mc+ y <- packOID True x+ ys <- mapM (packOID False) xs+ return $ pcontext <> y <> mconcat ys+ packsz (GetNext mc xs) = do+ pcontext <- packsz mc+ ys <- mapM packsz xs+ return $ pcontext <> mconcat ys+ packsz (GetBulk mc nr mr xs) = do+ pcontext <- packsz mc+ nonrepeaters <- packsz nr+ maxrepeaters <- packsz mr+ ys <- mapM packsz xs+ return $ pcontext <> nonrepeaters <> maxrepeaters <> mconcat ys+ packsz (TestSet mc xs) = do+ pcontext <- packsz mc+ ys <- mapM packsz xs+ return $ pcontext <> mconcat ys+ packsz CommitSet = fixContextFlags Nothing >> return empty+ packsz UndoSet = fixContextFlags Nothing >> return empty+ packsz CleanupSet = fixContextFlags Nothing >> return empty+ packsz (Notify mc xs) = do+ pcontext <- packsz mc+ ys <- mapM packsz xs+ return $ pcontext <> mconcat ys+ packsz (Ping mc) = packsz mc+ packsz (IndexAllocate mc xs) = do+ pcontext <- packsz mc+ ys <- mapM packsz xs+ return $ pcontext <> mconcat ys+ packsz (IndexDeallocate mc xs) = do+ pcontext <- packsz mc+ ys <- mapM packsz xs+ return $ pcontext <> mconcat ys+ packsz (AddAgentCaps mc o d) = do+ pcontext <- packsz mc+ oi <- packOID False o+ pdescription <- packsz d+ return $ pcontext <> oi <> pdescription+ packsz (RemoveAgentCaps mc o) = do+ pcontext <- packsz mc+ oi <- packOID False o+ return $ pcontext <> oi+ packsz (Response s re i xs) = do+ psysuptime <- packsz s+ perror <- packsz (tag re :: Word16)+ pindex <- packsz i+ ys <- mapM packsz xs+ fixContextFlags Nothing+ return $ psysuptime <> perror <> pindex <> mconcat ys
+ src/Network/Protocol/Snmp/AgentX/Packet/Types.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Network.Protocol.Snmp.AgentX.Packet.Types +( PDU(..)+, Version+, SessionID+, TransactionID+, PacketID+, econvert+, Context(..)+, Tag(..)+, TaggedError(..)+, TestError(..)+, CommitError(..)+, RError(..)+, UndoError(..)+, SysUptime+, Index+, MaxRepeaters+, NonRepeaters+-- ** Packet+, Packet+-- *** constructor+, mkPacket+-- *** lenses+, flags+, version +, pdu+, sid+, pid+, tid+-- ** SearchRange +, SearchRange+-- *** constructor+, mkSearchRange+-- *** lenses+, startOID+, endOID+, include+-- ** VarBind containt Value and OID+, VarBind+-- *** constructor+, mkVarBind+-- *** lenses+, vboid+, vbvalue+-- ** Flags +, Flags+-- *** constructor+, mkFlags+, InstanceRegistration +, NewIndex +, AnyIndex +, NonDefaultContext +, BigEndian +-- *** lenses+, instanceRegistration+, newIndex+, anyIndex+, nonDefaultContext+, bigEndian+)+where++import Data.Label++import Data.Word+import Data.ByteString (ByteString)+import Data.String+import Data.Default++import Network.Protocol.Snmp (Value(..), OID)++-- | protocol version (const 1 by default)+newtype Version = Version Word8 deriving (Show, Eq, Enum, Bounded, Ord)++-- | session id in header, rfc 2741, section 6.1+newtype SessionID = SessionID Word32 deriving (Show, Eq, Enum, Bounded, Ord)++-- | transaction id in header, rfc 2741, section 6.1+newtype TransactionID = TransactionID Word32 deriving (Show, Eq, Ord, Enum, Bounded)++-- | packet id in header, rfc 2741, section 6.1+newtype PacketID = PacketID Word32 deriving (Show, Eq, Ord, Enum, Bounded)++-- | helper for convert +econvert :: (Enum a, Enum b) => a -> b+econvert = toEnum . fromEnum++-- | rfc 2571 section 3.3.1, rfc 2741 section 6.1.1 Context+newtype Context = Context ByteString deriving (Show, Ord, Eq, IsString)++-- | rfc 2741, section 6.2.2, Error status in agentx-close-pdu+data Reason = Other+ | ParseError+ | ProtocolError+ | Timeouts+ | Shutdown+ | ByManager+ deriving (Show, Eq)++-- | rfc 2741, 6.2.16, Error status in agentx-response-pdu+data RError = NoAgentXError+ | OpenFailed+ | NotOpen+ | IndexWrongType+ | IndexAlreadyAllocated+ | IndexNonAvailable+ | IndexNotAllocated+ | UnsupportedContext+ | DuplicateRegistration+ | UnknownRegistration+ | UnknownAgentCaps+ | RParseError+ | RequestDenied+ | ProcessingError+ deriving (Show, Eq)++-- | result for testSetAIO (rfc 2741, section 7.2.4.1)+data TestError + = NoTestError+ | TooBig+ | NoSuchName+ | BadValue+ | ReadOnly+ | GenError+ | NoAccess+ | WrongType+ | WrongLength+ | WrongEncoding+ | WrongValue+ | NoCreation+ | InconsistentValue+ | ResourceUnavailable+ | NotWritable+ | InconsistentName+ deriving (Show, Eq)++-- | result for commitSetAIO (rfc 2741, section 7.2.4.2)+data CommitError+ = NoCommitError+ | CommitFailed+ deriving (Show, Eq) + +-- | result for undoSetAIO (rfc 2741, section 7.2.4.3)+data UndoError+ = NoUndoError+ | UndoFailed+ deriving (Show, Eq)+ +type Timeout = Word8+type Priority = Word8+type RangeSubid = Word8+type Description = ByteString+type MContext = Maybe Context+type UpperBound = Maybe Word32+type SysUptime = Word32+type Index = Word16+type NonRepeaters = Word16+type MaxRepeaters = Word16++-- | Error with Tag instance+data TaggedError = forall a. (Show a, Eq a, Tag a Word16) => Tagged a ++instance Tag TaggedError Word16 where+ tag (Tagged x) = tag x+ unTag x + | x == 0 = Tagged NoAgentXError+ | x > 0 && x <= 18 = Tagged (unTag x :: TestError)+ | otherwise = Tagged (unTag x :: RError)++instance Eq TaggedError where+ x == y = (tag x :: Word16) == (tag y :: Word16)++instance Show TaggedError where+ show (Tagged a) = show a++ +-- | rfc 2741, section 6.2+data PDU = Open Timeout OID Description -- ^ section 6.2.1+ | Close Reason -- ^ section 6.2.2+ | Register MContext Timeout Priority RangeSubid OID UpperBound -- ^ section 6.2.3+ | Unregister MContext Priority RangeSubid OID UpperBound -- ^ section 6.2.4+ | Get MContext [OID] -- ^ section 6.2.5+ | GetNext MContext [SearchRange] -- ^ section 6.2.6+ | GetBulk MContext NonRepeaters MaxRepeaters [SearchRange] -- ^ section 6.2.7+ | TestSet MContext [VarBind] -- ^ section 6.2.8+ | CommitSet -- ^ section 6.2.9+ | UndoSet -- ^ section 6.2.9+ | CleanupSet -- ^ section 6.2.9+ | Notify MContext [VarBind] -- ^ section 6.2.10+ | Ping MContext -- ^ section 6.2.11+ | IndexAllocate MContext [VarBind] -- ^ section 6.2.12+ | IndexDeallocate MContext [VarBind] -- ^ section 6.2.13+ | AddAgentCaps MContext OID Description -- ^ section 6.2.14+ | RemoveAgentCaps MContext OID -- ^ section 6.2.15+ | Response SysUptime TaggedError Index [VarBind] -- ^ section 6.2.16+ deriving (Show, Eq)+++-- | class for convert Errors to Word* and Word* to Errors+class Tag a b where+ tag :: a -> b+ unTag :: b -> a++-- | Packet type, describe agentx packet.+data Packet = Packet + { _version :: Version + , _pdu :: PDU + , _flags :: Flags + , _sid :: SessionID + , _tid :: TransactionID + , _pid :: PacketID + } deriving Show++mkPacket :: Version -> PDU -> Flags -> SessionID -> TransactionID -> PacketID -> Packet+mkPacket = Packet++-- | header flags, rfc 2741, section 6.1+data Flags = Flags + { _instanceRegistration :: InstanceRegistration + , _newIndex :: NewIndex+ , _anyIndex :: AnyIndex+ , _nonDefaultContext :: NonDefaultContext+ , _bigEndian :: BigEndian+ } deriving (Show)++type InstanceRegistration = Bool+type NewIndex = Bool+type AnyIndex = Bool+type NonDefaultContext = Bool+type BigEndian = Bool++mkFlags :: InstanceRegistration -> NewIndex -> AnyIndex -> NonDefaultContext -> BigEndian -> Flags+mkFlags = Flags++-- | used for getnext and other requests (rfc 2741, section5.2 )+data SearchRange = SearchRange + { _startOID :: OID + , _endOID :: OID+ , _include :: Bool+ } deriving (Show, Eq)++-- | create SearchRange+mkSearchRange :: OID -> OID -> Bool -> SearchRange+mkSearchRange = SearchRange++-- | containt oid and value (rfc 2741, section 5.4)+data VarBind = VarBind + { _vboid :: OID + , _vbvalue :: Value + } deriving (Show, Eq)++-- | constructor for VarBind+mkVarBind :: OID -> Value -> VarBind+mkVarBind = VarBind ++mkLabels [''Packet, ''Flags, ''VarBind, ''SearchRange ]++instance Tag Reason Word8 where+ tag Other = 1+ tag ParseError = 2+ tag ProtocolError = 3+ tag Timeouts = 4+ tag Shutdown = 5+ tag ByManager = 6+ unTag 1 = Other + unTag 2 = ParseError + unTag 3 = ProtocolError+ unTag 4 = Timeouts + unTag 5 = Shutdown + unTag 6 = ByManager + unTag _ = error "unknown reasonFromTag"++instance Tag RError Word16 where+ tag NoAgentXError = 0+ tag OpenFailed = 256+ tag NotOpen = 257+ tag IndexWrongType = 258+ tag IndexAlreadyAllocated = 259+ tag IndexNonAvailable = 260+ tag IndexNotAllocated = 261+ tag UnsupportedContext = 262+ tag DuplicateRegistration = 263+ tag UnknownRegistration = 264+ tag UnknownAgentCaps = 265+ tag RParseError = 266+ tag RequestDenied = 267+ tag ProcessingError = 268+ unTag 0 = NoAgentXError + unTag 256 = OpenFailed + unTag 257 = NotOpen + unTag 258 = IndexWrongType + unTag 259 = IndexAlreadyAllocated+ unTag 260 = IndexNonAvailable + unTag 261 = IndexNotAllocated + unTag 262 = UnsupportedContext + unTag 263 = DuplicateRegistration+ unTag 264 = UnknownRegistration + unTag 265 = UnknownAgentCaps + unTag 266 = RParseError + unTag 267 = RequestDenied + unTag 268 = ProcessingError + unTag _ = error "bad rerror" ++instance Tag TestError Word16 where+ tag NoTestError = 0+ tag TooBig = 1+ tag NoSuchName = 2+ tag BadValue = 3+ tag ReadOnly = 4+ tag GenError = 5+ tag NoAccess = 6+ tag WrongType = 7+ tag WrongLength = 8+ tag WrongEncoding = 9+ tag WrongValue = 10+ tag NoCreation = 11+ tag InconsistentValue = 12+ tag ResourceUnavailable = 13+ tag NotWritable = 17+ tag InconsistentName = 18+ unTag 0 = NoTestError+ unTag 1 = TooBig + unTag 2 = NoSuchName + unTag 3 = BadValue + unTag 4 = ReadOnly + unTag 5 = GenError + unTag 6 = NoAccess + unTag 7 = WrongType + unTag 8 = WrongLength + unTag 9 = WrongEncoding + unTag 10 = WrongValue + unTag 11 = NoCreation + unTag 12 = InconsistentValue + unTag 13 = ResourceUnavailable + unTag 17 = NotWritable + unTag 18 = InconsistentName + unTag _ = error "unknown tag in TestError"++instance Tag CommitError Word16 where+ tag NoCommitError = 0 + tag CommitFailed = 14+ unTag 0 = NoCommitError+ unTag 14 = CommitFailed + unTag _ = error "unknown tag in CommitError"++instance Tag UndoError Word16 where+ tag NoUndoError = 0+ tag UndoFailed = 15+ unTag 0 = NoUndoError+ unTag 15 = UndoFailed + unTag _ = error "unknown tag in UndoError"++++instance Tag PDU Word8 where+ tag Open{} = 1+ tag Close{} = 2+ tag Register{} = 3+ tag Unregister{} = 4+ tag Get{} = 5+ tag GetNext{} = 6+ tag GetBulk{} = 7+ tag TestSet{} = 8+ tag CommitSet{} = 9+ tag UndoSet{} = 10+ tag CleanupSet{} = 11+ tag Notify{} = 12+ tag Ping{} = 13+ tag IndexAllocate{} = 14+ tag IndexDeallocate{} = 15+ tag AddAgentCaps{} = 16+ tag RemoveAgentCaps{} = 17+ tag Response{} = 18+ unTag _ = undefined++instance Tag Value Word16 where+-- TODO check zerodotzero + tag (ZeroDotZero) = 0+ tag (Integer _) = 2+ tag (String _) = 4+ tag (Zero) = 5+ tag (OI _) = 6+ tag (IpAddress _ _ _ _) = 64+ tag (Counter32 _) = 65+ tag (Gaude32 _) = 66+ tag (TimeTicks _) = 67+ tag (Opaque _) = 68+ tag (Counter64 _) = 70+ tag (NoSuchObject) = 128+ tag (NoSuchInstance) = 129+ tag (EndOfMibView) = 130+ unTag _ = undefined++instance Default Flags where+ def = mkFlags False False False False False++instance Default Version where+ def = Version 1+