diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Andrew Martin (c) 2017 + +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 Andrew Martin 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/asn1-codec.cabal b/asn1-codec.cabal new file mode 100644 --- /dev/null +++ b/asn1-codec.cabal @@ -0,0 +1,67 @@ +name: asn1-codec +version: 0.1.0 +synopsis: Encode and decode ASN.1 +description: Add a better description later +homepage: https://github.com/andrewthad/asn1-codec +license: BSD3 +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2017 Andrew Martin +category: web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + TestNetwork + Language.Asn.Encoding + Language.Asn.Decoding + Language.Asn.ObjectIdentifier + Language.Asn.Types + Language.Asn.Types.Internal + Net.Snmp.Types + Net.Snmp.Encoding + Net.Snmp.Decoding + Net.Snmp.Client + build-depends: + base >= 4.7 && < 5 + , integer-gmp + , bytestring + , contravariant + , vector + , pretty + , text + , network + , stm + , containers + , hashable + , cryptonite + , memory + default-language: Haskell2010 + +test-suite asn1-records-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base + , asn1-codec + , test-framework + , text + , bytestring + , HUnit + , test-framework-hunit + , aeson + , directory + , base16-bytestring + , vector + other-modules: + Internal + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/andrewthad/asn1-records diff --git a/src/Language/Asn/Decoding.hs b/src/Language/Asn/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Language/Asn/Decoding.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +{-# OPTIONS_GHC -Wall #-} + +module Language.Asn.Decoding + ( ber + , sequence + , sequenceOf + , required + , optional + , defaulted + , utf8String + , integer + , integerRanged + , int32 + , int + , word32 + , word64 + , null + , null' + , octetString + , octetStringWord8 + , octetStringWord32 + , objectIdentifier + , choice + , option + , tag + , mapFailable + ) where + +import Prelude hiding (sequence,null) +import Language.Asn.Types.Internal +import Data.ByteString (ByteString) +import Data.Bits +import Control.Monad hiding (sequence) +import Data.Maybe +import Data.Text (Text) +import Data.Word +import Data.Int +import Data.Functor.Identity (Identity(..)) +import Text.Printf (printf) +import Debug.Trace +import qualified Data.Text.Encoding as TE +import qualified Data.List as List +import qualified Data.Vector as Vector +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Unsafe as BSU + +ber :: AsnDecoding a -> ByteString -> Either String a +ber d bs = requireNoLeftovers =<< decodeBerInternal d Nothing bs + +sequence :: FieldDecoding a -> AsnDecoding a +sequence = AsnDecodingSequence + +sequenceOf :: AsnDecoding a -> AsnDecoding [a] +sequenceOf = AsnDecodingSequenceOf id + +required :: FieldName -> AsnDecoding a -> FieldDecoding a +required name d = FieldDecoding (liftAp (FieldDecodingRequired name d)) + +optional :: FieldName -> AsnDecoding a -> FieldDecoding (Maybe a) +optional name d = FieldDecoding (liftAp (FieldDecodingOptional name d id)) + +defaulted :: Show a => FieldName -> AsnDecoding a -> a -> FieldDecoding a +defaulted name d defVal = FieldDecoding (liftAp (FieldDecodingDefault name d defVal show)) + +choice :: [OptionDecoding a] -> AsnDecoding a +choice = AsnDecodingChoice + +option :: OptionName -> AsnDecoding a -> OptionDecoding a +option = OptionDecoding + +tag :: TagClass -> Int -> Explicitness -> AsnDecoding a -> AsnDecoding a +tag c n e = AsnDecodingRetag (TagAndExplicitness (Tag c n) e) + +utf8String :: AsnDecoding Text +utf8String = AsnDecodingUniversal $ UniverseDecodingTextualString Utf8String id (Subtypes []) (Subtypes []) + +octetString :: AsnDecoding ByteString +octetString = AsnDecodingUniversal $ UniverseDecodingOctetString id (Subtypes []) + +octetStringWord32 :: AsnDecoding Word32 +octetStringWord32 = mapFailable + ( \bs -> if ByteString.length bs == 4 + then Right $ (fromIntegral :: Word -> Word32) + $ unsafeShiftL 24 (fromIntegral (BSU.unsafeIndex bs 0)) + + unsafeShiftL 16 (fromIntegral (BSU.unsafeIndex bs 1)) + + unsafeShiftL 8 (fromIntegral (BSU.unsafeIndex bs 2)) + + fromIntegral (BSU.unsafeIndex bs 3) + else Left "octetStringWord32 expects the octet string to have exactly 4 bytes" + ) octetString + +octetStringWord8 :: AsnDecoding Word8 +octetStringWord8 = mapFailable + ( \bs -> if ByteString.length bs == 1 + then Right (BSU.unsafeIndex bs 0) + else Left "octetStringWord8 expects the octet string to have exactly 1 byte" + ) octetString + +integer :: AsnDecoding Integer +integer = AsnDecodingUniversal (UniverseDecodingInteger id (Subtypes [])) + +-- This could be improved by making sure that integer in question is actually +-- in the provided bounds. +int :: AsnDecoding Int +int = AsnDecodingUniversal (UniverseDecodingInteger fromIntegral (Subtypes [])) + +-- This could be improved by making sure that integer in question is actually +-- in the provided bounds. +int32 :: AsnDecoding Int32 +int32 = AsnDecodingUniversal (UniverseDecodingInteger fromIntegral (Subtypes [])) + +-- This could be improved by making sure that integer in question is actually +-- in the provided bounds. +word32 :: AsnDecoding Word32 +word32 = AsnDecodingUniversal (UniverseDecodingInteger fromIntegral (Subtypes [])) + +-- This could be improved by making sure that integer in question is actually +-- in the provided bounds. +word64 :: AsnDecoding Word64 +word64 = AsnDecodingUniversal (UniverseDecodingInteger fromIntegral (Subtypes [])) + +null :: AsnDecoding () +null = AsnDecodingUniversal (UniverseDecodingNull ()) + +null' :: a -> AsnDecoding a +null' = AsnDecodingUniversal . UniverseDecodingNull + +objectIdentifier :: AsnDecoding ObjectIdentifier +objectIdentifier = AsnDecodingUniversal (UniverseDecodingObjectIdentifier id (Subtypes [])) + +integerRanged :: Integer -> Integer -> AsnDecoding Integer +integerRanged lo hi = AsnDecodingUniversal + (UniverseDecodingInteger id (Subtypes [SubtypeValueRange lo hi])) + +mapFailable :: (a -> Either String b) -> AsnDecoding a -> AsnDecoding b +mapFailable f d = AsnDecodingConversion d f + +repeatUntilEmpty :: Monad m => (ByteString -> m (a,ByteString)) -> ByteString -> m [a] +repeatUntilEmpty f = go where + go bs1 = do + (a,bs2) <- f bs1 + if ByteString.null bs2 + then return [a] + else fmap (a:) (go bs2) + +decodeBerInternal :: AsnDecoding a -> Maybe Tag -> ByteString -> Either String (a,ByteString) +decodeBerInternal x overrideTag bs1 = case x of + AsnDecodingUniversal u -> do + (bsContent,bsRemainder) <- takeTagAndLength Primitive (Tag Universal (universeDecodingTagNumber u)) + a <- decodeUniversal u bsContent + return (a,bsRemainder) + AsnDecodingRetag (TagAndExplicitness newTag expl) nextDecoding -> case expl of + Implicit -> decodeBerInternal nextDecoding (Just $ fromMaybe newTag overrideTag) bs1 + Explicit -> do + (bsContent,bsRemainder) <- takeTagAndLength Constructed newTag + a <- requireNoLeftovers =<< decodeBerInternal nextDecoding Nothing bsContent + return (a,bsRemainder) + AsnDecodingSequence (FieldDecoding fieldDecoding) -> do + (bsContent,bsRemainder) <- takeTagAndLength Constructed sequenceTag + a <- requireNoLeftovers =<< getDecodePart (runAp decodeField fieldDecoding) bsContent + return (a,bsRemainder) + AsnDecodingSequenceOf f nextDecoding -> do + (bsContent,bsRemainder) <- takeTagAndLength Constructed sequenceTag + cs <- repeatUntilEmpty (decodeBerInternal nextDecoding Nothing) bsContent + return (f cs,bsRemainder) + AsnDecodingConversion nextDecoding conv -> do + (b,bs2) <- decodeBerInternal nextDecoding overrideTag bs1 + a <- conv b + return (a,bs2) + -- Note: overrideTag is currently ignored in this case. Per + -- ASN.1 rules, you cannot put an IMPLICIT tag over a CHOICE, + -- which is the only thing that could cause this to happen. + -- Still, I don't like that it's being ignored. + AsnDecodingChoice opts -> case ByteString.uncons bs1 of + Nothing -> Left "while trying to decode Choice tag, ran out of input" + Just (b,bs2) -> do + let possibilities = nextExpectedTags =<< map (\(OptionDecoding _ d) -> d) opts + theTagNumberPrefix = b .&. 31 + (theTagNumber,_) <- decipherTagNumber theTagNumberPrefix bs2 + let mmatched = listToMaybe $ List.filter + (\((Tag tc tn,cstn),_) -> b .&. 192 == tagClassBit tc && b .&. 32 == constructionBit cstn && tn == theTagNumber) + possibilities + case mmatched of + Nothing -> Left $ concat + [ "while trying to decode Choice tag, the tag did not match any of the expected tags: found " + , show theTagNumber + , " but expected one of [" + , List.intercalate "," $ flip map possibilities $ \((Tag tc tn, cstn),_) -> concat + [ show tc + , " " + , show cstn + , " " + , show tn + ] + , "]" + ] + Just (_,Wrapper chosenDecoder conv2) -> do + (c,bs3) <- decodeBerInternal chosenDecoder Nothing bs1 + r <- conv2 c + Right (r,bs3) + where + takeTagAndLength :: Construction -> Tag -> Either String (ByteString,ByteString) + takeTagAndLength construction t1 = do + let tagToUse = fromMaybe t1 overrideTag + bs2 <- expectTag construction tagToUse bs1 + (len,bs3) <- takeLength bs2 + splitOrFail len bs3 + +data Wrapper a = forall b. Wrapper (AsnDecoding b) (b -> Either String a) + +idWrapper :: AsnDecoding a -> Wrapper a +idWrapper d = Wrapper d Right + +nextExpectedTags :: AsnDecoding a -> [((Tag,Construction), Wrapper a)] +nextExpectedTags x = case x of + AsnDecodingUniversal u -> [((Tag Universal (universeDecodingTagNumber u), Primitive),idWrapper x)] + AsnDecodingSequenceOf _ _ -> [((sequenceTag, Constructed),idWrapper x)] + AsnDecodingSequence _ -> [((sequenceTag, Constructed),idWrapper x)] + AsnDecodingChoice opts -> join (map (\(OptionDecoding _ theDec) -> nextExpectedTags theDec) opts) + AsnDecodingRetag (TagAndExplicitness newTag expl) nextDecoding -> case expl of + Explicit -> [((newTag,Constructed),idWrapper x)] + Implicit -> map (\((_,c),Wrapper theDec theConv) -> ((newTag,c), Wrapper (AsnDecodingRetag (TagAndExplicitness newTag expl) theDec) theConv)) (nextExpectedTags nextDecoding) + AsnDecodingConversion nextDecoding conv -> + map (\((t,c),Wrapper theDec theConv) -> ((t,c),Wrapper theDec (theConv >=> conv))) (nextExpectedTags nextDecoding) + +decodeField :: FieldDecodingPart a -> DecodePart a +decodeField x = case x of + FieldDecodingRequired _ d -> DecodePart (decodeBerInternal d Nothing) + FieldDecodingOptional _ d conv1 -> handlePossiblyMissingField d conv1 + FieldDecodingDefault _ d a _ -> handlePossiblyMissingField d (fromMaybe a) + +handlePossiblyMissingField :: AsnDecoding b -> (Maybe b -> a) -> DecodePart a +handlePossiblyMissingField d conv1 = DecodePart $ \bs1 -> case ByteString.uncons bs1 of + Nothing -> Right (conv1 Nothing, bs1) + Just (b,bs2) -> do + let possibilities = nextExpectedTags d + theTagNumberPrefix = b .&. 31 + (theTagNumber,_) <- decipherTagNumber theTagNumberPrefix bs2 + let mmatched = listToMaybe $ List.filter + (\((Tag tc tn,cstn),_) -> b .&. 192 == tagClassBit tc && b .&. 32 == constructionBit cstn && tn == theTagNumber) possibilities + case mmatched of + Nothing -> Right (conv1 Nothing, bs1) + Just (_,Wrapper chosenDecoder conv2) -> do + (c,bs3) <- decodeBerInternal chosenDecoder Nothing bs1 + r <- conv2 c + Right (conv1 (Just r),bs3) + +-- The first argument is the full tag byte +decipherTagNumber :: Word8 -> ByteString -> Either String (Int,ByteString) +decipherTagNumber w bs = do + let tn = w .&. 31 + if tn < 31 + then Right (fromIntegral tn,bs) + else error "decipherTagNumber: handle tags greater than 30" + + +requireNoLeftovers :: (a,ByteString) -> Either String a +requireNoLeftovers (a,bs) = if ByteString.null bs then Right a else Left "expected not to have leftovers, but there were leftovers" + +expectTag :: Construction -> Tag -> ByteString -> Either String ByteString +expectTag construction (Tag tc tn) bs = case ByteString.uncons bs of + Nothing -> Left "expected a byte for the Tag but the ByteString was empty" + Just (b,bsNext) -> do + let expectedTagBits = tagClassBit tc + actualTagBits = b .&. 192 + when (actualTagBits /= expectedTagBits) + $ Left $ "while parsing the tag, the tag class bits did not match: " + ++ "found " ++ printf "%08b" actualTagBits ++ " but expected " + ++ printf "%08b" expectedTagBits ++ " (" ++ show tc ++ ")" + when (b .&. 32 /= constructionBit construction) $ Left "while parsing the tag, the construction bit did not match" + if tn < 31 + then do + when (b .&. 31 /= fromIntegral tn) $ Left "while parsing the tag, the tag number did not match what was expected" + Right bsNext + else error "expectTag: handle tag numbers higher than 30" + +splitOrFail :: Int -> ByteString -> Either String (ByteString,ByteString) +splitOrFail i bs = if i > ByteString.length bs + then Left "tried to take a fixed number of bytes as specified by the encoding, but bytestring ended" + else Right (ByteString.splitAt i bs) + +takeLength :: ByteString -> Either String (Int,ByteString) +takeLength bs1 = case ByteString.uncons bs1 of + Nothing -> Left "while trying to decode the length, expected an initial octet but the bytestring ended" + Just (b,bs2) -> if b < 128 + then Right (fromIntegral b, bs2) + else let bytesToTake = fromIntegral (127 .&. b) in + if ByteString.length bs2 < bytesToTake + then Left "while decoding multi-byte length, ran out of bytes" + else let (bs3,bs4) = ByteString.splitAt bytesToTake bs2 in Right (parseLength bs3, bs4) + + +parseLength :: ByteString -> Int +parseLength = ByteString.foldl' (\i w8 -> i * 256 + fromIntegral w8) 0 + +-- This currently does the wrong thing for negative numbers +parseInteger :: ByteString -> Integer +parseInteger = ByteString.foldl' (\i w8 -> i * 256 + fromIntegral w8) 0 + +decodeUniversal :: UniverseDecoding a -> ByteString -> Either String a +decodeUniversal x bs = case x of + UniverseDecodingInteger f _ -> Right (f (parseInteger bs)) + UniverseDecodingTextualString _ f _ _ -> case TE.decodeUtf8' bs of + Left _ -> Left "while decoding string primitive, found that UTF8-encoding was not used" + Right t -> Right (f t) + UniverseDecodingObjectIdentifier f _ -> fmap f (stepOidAll bs) + UniverseDecodingOctetString f _ -> Right (f bs) + UniverseDecodingNull a -> Right a + +stepOidAll :: ByteString -> Either String ObjectIdentifier +stepOidAll bs1 = case ByteString.uncons bs1 of + Nothing -> Left "while decoding OID, found no bytes, the OID should have at least one octet" + Just (b,bs2) -> + let (w1,w2) = quotRem b 40 + Identity nums = repeatUntilEmpty (Identity . stepOid 0) bs2 + in Right (ObjectIdentifier (Vector.fromList $ fromIntegral w1 : fromIntegral w2 : nums)) + +stepOid :: Integer -> ByteString -> (Integer,ByteString) +stepOid !i bs1 = case ByteString.uncons bs1 of + Nothing -> (i,bs1) + Just (w,bs2) -> + let !acc = i * 128 + fromIntegral (w .&. 127) in + if w .&. 128 == 128 + then stepOid acc bs2 + else (acc,bs2) + +universeDecodingTagNumber :: UniverseDecoding a -> Int +universeDecodingTagNumber x = case x of + UniverseDecodingInteger _ _ -> 2 + UniverseDecodingTextualString typ _ _ _ -> tagNumStringType typ + UniverseDecodingObjectIdentifier _ _ -> 6 + UniverseDecodingOctetString _ _ -> 4 + UniverseDecodingNull _ -> 5 + + + diff --git a/src/Language/Asn/Encoding.hs b/src/Language/Asn/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Language/Asn/Encoding.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +{-# OPTIONS_GHC -Wall #-} + +module Language.Asn.Encoding + ( -- * Run Encoding + der + , toDefinitionString + -- * Build Encoding + -- ** Constructed + , sequence + , sequenceOf + , choice + , tag + , implicitTag + -- ** Fields + , required + , optional + , defaulted + , option + -- ** Primitive + , integer + , integerRanged + , int32 + , int + , word32 + , word64 + , word + , octetString + , octetStringWord8 + , octetStringWord32 + , utf8String + , null + , null' + , objectIdentifier + -- Remove anything exported below this + , int64Log256 + , encodeLength + ) where + +import Prelude hiding (sequence,null) +import Language.Asn.Types.Internal +import Data.String +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.Text (Text) +import Data.Monoid +import Data.Word +import Data.Int +import Data.Bits +import Data.Vector (Vector) +import GHC.Int (Int(..)) +import GHC.Integer.Logarithms (integerLog2#) +import Data.Foldable hiding (null) +import qualified Data.Text.Encoding as TE +import qualified Text.PrettyPrint as PP +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Builder +import qualified Data.List as List +import qualified Data.Vector as Vector +import qualified Data.ByteString as ByteString + +-- Note that DER encoding is a subset of BER encoding. If you +-- need to encode with BER, just use this function. +der :: AsnEncoding a -> a -> LB.ByteString +der e = encodeTaggedByteString . encodeBerInternal e + +tagClassPrefix :: TagClass -> String +tagClassPrefix x = case x of + Universal -> "UNIVERSAL " + Private -> "PRIVATE " + Application -> "APPLICATION " + ContextSpecific -> "" + +toDefinitionString :: AsnEncoding a -> String +toDefinitionString = PP.render . go where + go :: forall b. AsnEncoding b -> PP.Doc + go (EncUniversalValue u) = prettyPrintUniversalValue u + go (EncRetag (TagAndExplicitness theTag expl) e) = + PP.text (prettyPrintTag theTag ++ " " ++ ppExplicitness expl ++ " ") <> go e + go (EncChoice (Choice _ allCtors getValAndEnc)) = (PP.$+$) + "CHOICE" + ( PP.nest 2 $ PP.vcat $ map (ppValEnc . getValAndEnc) allCtors) + go (EncSequence fields) = (PP.$+$) + "SEQUENCE" + ( PP.nest 2 $ PP.vcat $ map ppField fields) + go (EncSequenceOf _ e) = PP.text "SEQUENCE OF" PP.<+> go e + ppField :: forall b. Field b -> PP.Doc + ppField x = case x of + FieldRequired (FieldName name) _ e -> PP.text (name ++ " ") <> go e + FieldOptional (FieldName name) _ e -> PP.text (name ++ " OPTIONAL ") <> go e + FieldDefaulted (FieldName name) _ defVal showVal _ e -> + PP.text (name ++ " DEFAULT " ++ showVal defVal ++ " ") <> go e + ppValEnc :: ValueAndEncoding -> PP.Doc + ppValEnc (ValueAndEncoding _ (OptionName name) _ enc) = PP.text (name ++ " ") <> go enc + ppExplicitness :: Explicitness -> String + ppExplicitness x = case x of + Implicit -> "IMPLICIT" + Explicit -> "EXPLICIT" + + +prettyPrintTag :: Tag -> String +prettyPrintTag (Tag c n) = "[" ++ tagClassPrefix c ++ show n ++ "]" + +prettyPrintUniversalValue :: UniversalValue x -> PP.Doc +prettyPrintUniversalValue x = case x of + UniversalValueBoolean _ _ -> PP.text "BOOLEAN" + UniversalValueInteger _ ss -> PP.text $ "INTEGER" ++ strSubtypes show ss + UniversalValueNull -> PP.text "NULL" + UniversalValueOctetString _ _ -> PP.text "OCTET STRING" + UniversalValueObjectIdentifier _ _ -> PP.text "OBJECT IDENTIFIER" + UniversalValueTextualString typ _ _ _ -> PP.text (strStringType typ) + +strStringType :: StringType -> String +strStringType x = case x of + Utf8String -> "UTF8String" + NumericString -> "NumericString" + PrintableString -> "PrintableString" + TeletexString -> "TeletexString" + VideotexString -> "VideotexString" + IA5String -> "IA5String" + GraphicString -> "GraphicString" + VisibleString -> "VisibleString" + GeneralString -> "GeneralString" + UniversalString -> "UniversalString" + CharacterString -> "CHARACTER STRING" + BmpString -> "BMPString" + +strSubtypes :: (a -> String) -> Subtypes a -> String +strSubtypes f (Subtypes ss) + | length ss == 0 = "" + | otherwise = " (" ++ List.intercalate " | " (map (strSubtype f) ss) ++ ")" + +strSubtype :: (a -> String) -> Subtype a -> String +strSubtype f x = case x of + SubtypeSingleValue a -> f a + SubtypeValueRange lo hi -> f lo ++ " .. " ++ f hi + +makeTag :: TagClass -> Int -> Tag +makeTag = Tag + +sequence :: [Field a] -> AsnEncoding a +sequence = EncSequence + +sequenceOf :: Foldable f => AsnEncoding a -> AsnEncoding (f a) +sequenceOf = EncSequenceOf toList + +choice :: [a] -> (a -> ValueAndEncoding) -> AsnEncoding a +choice xs f = EncChoice (Choice id xs f) + +option :: Int -> OptionName -> b -> AsnEncoding b -> ValueAndEncoding +option = ValueAndEncoding + +tag :: TagClass -> Int -> Explicitness -> AsnEncoding a -> AsnEncoding a +tag c n e = EncRetag (TagAndExplicitness (Tag c n) e) + +implicitTag :: Tag -> AsnEncoding a -> AsnEncoding a +implicitTag t = EncRetag (TagAndExplicitness t Implicit) + +required :: FieldName -> (a -> b) -> AsnEncoding b -> Field a +required = FieldRequired + +optional :: FieldName -> (a -> Maybe b) -> AsnEncoding b -> Field a +optional = FieldOptional + +defaulted :: (Eq b, Show b) => FieldName -> (a -> b) -> AsnEncoding b -> b -> Field a +defaulted name getVal enc defVal = FieldDefaulted name getVal defVal show (==) enc + +objectIdentifier :: AsnEncoding ObjectIdentifier +objectIdentifier = EncUniversalValue (UniversalValueObjectIdentifier id mempty) + +null :: AsnEncoding () +null = null' + +-- | Anything can be encoded as @NULL@ by simply discarding it. Typically, +-- encoding a type with more than one inhabitant as @NULL@ is a mistake, +-- so the more restrictive 'null' is to be preferred. +null' :: AsnEncoding a +null' = EncUniversalValue UniversalValueNull + +integer :: AsnEncoding Integer +integer = EncUniversalValue (UniversalValueInteger id mempty) + +integerRanged :: Integer -> Integer -> AsnEncoding Integer +integerRanged lo hi = EncUniversalValue + (UniversalValueInteger id (Subtypes [SubtypeValueRange lo hi])) + +word32 :: AsnEncoding Word32 +word32 = EncUniversalValue (UniversalValueInteger fromIntegral (Subtypes [SubtypeValueRange 0 4294967295])) + +word64 :: AsnEncoding Word64 +word64 = EncUniversalValue (UniversalValueInteger fromIntegral (Subtypes [SubtypeValueRange 0 18446744073709551615])) + +-- TODO: add a size subtype to this +octetStringWord32 :: AsnEncoding Word32 +octetStringWord32 = EncUniversalValue (UniversalValueOctetString (LB.toStrict . Builder.toLazyByteString . Builder.word32BE) mempty) + +octetStringWord8 :: AsnEncoding Word8 +octetStringWord8 = EncUniversalValue + ( UniversalValueOctetString + ByteString.singleton + mempty + ) + +int32 :: AsnEncoding Int32 +int32 = EncUniversalValue (UniversalValueInteger fromIntegral (Subtypes [SubtypeValueRange (-2147483648) 2147483647])) + +word :: AsnEncoding Word +word = EncUniversalValue (UniversalValueInteger fromIntegral (Subtypes [SubtypeValueRange 0 (fromIntegral (maxBound :: Word))])) + +int :: AsnEncoding Int +int = EncUniversalValue (UniversalValueInteger fromIntegral (Subtypes [SubtypeValueRange (fromIntegral (minBound :: Int)) (fromIntegral (maxBound :: Int))])) + +octetString :: AsnEncoding ByteString +octetString = EncUniversalValue (UniversalValueOctetString id mempty) + +utf8String :: AsnEncoding Text +utf8String = EncUniversalValue (UniversalValueTextualString Utf8String id mempty mempty) + +universalValueTag :: UniversalValue a -> Int +universalValueTag x = case x of + UniversalValueOctetString _ _ -> 4 + UniversalValueBoolean _ _ -> 1 + UniversalValueInteger _ _ -> 2 + UniversalValueNull -> 5 + UniversalValueObjectIdentifier _ _ -> 6 + UniversalValueTextualString typ _ _ _ -> tagNumStringType typ + +-- For DER, which is what is actually targetted by this file, +-- I think that this is always Primitive. +univsersalValueConstruction :: UniversalValue a -> Construction +univsersalValueConstruction x = case x of + UniversalValueOctetString _ _ -> Primitive + UniversalValueBoolean _ _ -> Primitive + UniversalValueInteger _ _ -> Primitive + UniversalValueNull -> Primitive + UniversalValueTextualString _ _ _ _ -> Primitive + UniversalValueObjectIdentifier _ _ -> Primitive + +-- | The ByteString that accompanies the tag does not +-- include its own length. +encodeBerInternal :: AsnEncoding a -> a -> TaggedByteString +encodeBerInternal x a = case x of + EncRetag (TagAndExplicitness outerTag explicitness) e -> + let TaggedByteString construction innerTag lbs = encodeBerInternal e a + in case explicitness of + Implicit -> TaggedByteString construction outerTag lbs + Explicit -> TaggedByteString Constructed outerTag (encodeTaggedByteString (TaggedByteString construction innerTag lbs)) + EncUniversalValue p -> TaggedByteString (univsersalValueConstruction p) (makeTag Universal (universalValueTag p)) (encodePrimitiveBer p a) + EncChoice (Choice conv _ f) -> case f (conv a) of + ValueAndEncoding _ _ b enc2 -> encodeBerInternal enc2 b + EncSequence fields -> TaggedByteString Constructed sequenceTag (foldMap (encodeField a) fields) + -- It's kind of weird that sequence and sequence-of share the same tag, + -- but hey, that's how the committee designed it. + EncSequenceOf listify e -> TaggedByteString Constructed sequenceTag + (foldMap (encodeTaggedByteString . encodeBerInternal e) (listify a)) + +-- Factor out some of the encoding stuff here into another function +encodeField :: a -> Field a -> LB.ByteString +encodeField a x = case x of + FieldRequired _ func enc -> encodeTaggedByteString (encodeBerInternal enc (func a)) + FieldDefaulted _ func defVal _ eqVal enc -> + let val = func a + in if eqVal defVal val + then mempty + else encodeTaggedByteString (encodeBerInternal enc val) + FieldOptional _ mfunc enc -> case mfunc a of + Nothing -> mempty + Just v -> encodeTaggedByteString (encodeBerInternal enc v) + +encodeTaggedByteString :: TaggedByteString -> LB.ByteString +encodeTaggedByteString (TaggedByteString construction theTag lbs) = + encodeTag construction theTag <> encodeLength (LB.length lbs) <> lbs + +encodeTag :: Construction -> Tag -> LB.ByteString +encodeTag c (Tag tclass tnum) + | tnum < 31 = LB.singleton (firstThreeBits .|. intToWord8 tnum) + | otherwise = error "tag number above 30: write this" + where + !firstThreeBits = constructionBit c .|. tagClassBit tclass + +encodeLength :: Int64 -> LB.ByteString +encodeLength x + | x < 128 = LB.singleton (int64ToWord8 x) + | otherwise = + let totalOctets = fromIntegral (int64Log256 x + 1) :: Word8 + in LB.singleton (128 .|. totalOctets) + <> lengthBE (fromIntegral x) + +int64Log256 :: Int64 -> Int +int64Log256 x = unsafeShiftR (int64Log2 x) 3 + +int64Log2 :: Int64 -> Int +int64Log2 x = finiteBitSize x - 1 - countLeadingZeros x + +int64ToWord8 :: Int64 -> Word8 +int64ToWord8 = fromIntegral +{-# INLINE int64ToWord8 #-} + +intToWord8 :: Int -> Word8 +intToWord8 = fromIntegral +{-# INLINE intToWord8 #-} + +encodePrimitiveBer :: UniversalValue a -> a -> LB.ByteString +encodePrimitiveBer p x = case p of + UniversalValueTextualString typ f _ _ -> LB.fromStrict (encodeText typ (f x)) + UniversalValueOctetString f _ -> LB.fromStrict (f x) + UniversalValueObjectIdentifier f _ -> oidBE (f x) + UniversalValueBoolean f _ -> case f x of + True -> LB.singleton 1 + False -> LB.singleton 0 + UniversalValueInteger f _ -> integerBE (f x) + UniversalValueNull -> LB.empty + +encodeText :: StringType -> Text -> ByteString +encodeText x t = case x of + Utf8String -> TE.encodeUtf8 t + _ -> error "encodeText: handle more ASN.1 string types" + +lengthBE :: Int64 -> LB.ByteString +lengthBE i = if i > 0 + then Builder.toLazyByteString (goPos i) + else error "lengthBE: handle the negative case" + where + goPos :: Int64 -> Builder + goPos n1 = if n1 == 0 + then mempty + else let (!n2,!byteVal) = quotRem n1 256 + in goPos n2 <> Builder.word8 (fromIntegral byteVal) + +integerBE :: Integer -> LB.ByteString +integerBE i + | i < 128 && i > (-129) = Builder.toLazyByteString (Builder.int8 (fromIntegral i)) + | otherwise = if i > 0 + then let lb = Builder.toLazyByteString (goPos i) + in if LB.head lb > 127 then LB.cons 0 lb else lb + else error "integerBE: handle the negative case" + where + goPos :: Integer -> Builder + goPos n1 = if n1 == 0 + then mempty + else let (!n2,!byteVal) = quotRem n1 256 + in goPos n2 <> Builder.word8 (fromIntegral byteVal) + +oidBE :: ObjectIdentifier -> LB.ByteString +oidBE (ObjectIdentifier nums1) + | Vector.length nums1 > 2 = + let !n1 = Vector.unsafeIndex nums1 0 + !n2 = Vector.unsafeIndex nums1 1 + !nums2 = Vector.unsafeDrop 2 nums1 + !firstOctet = fromIntegral n1 * 40 + fromIntegral n2 :: Word8 + in Builder.toLazyByteString (Builder.word8 firstOctet <> foldMap multiByteBase127Encoding nums2) + | otherwise = error "oidBE: OID with less than 3 identifiers" + +multiByteBase127Encoding :: Integer -> Builder +multiByteBase127Encoding i0 = + let (!i1,!byteVal) = quotRem i0 128 + in go i1 <> Builder.word8 (fromIntegral byteVal) + where + go n1 = if n1 == 0 + then mempty + else let (!n2,!byteVal) = quotRem n1 128 + in go n2 <> Builder.word8 (128 .|. fromIntegral byteVal) + +integerLog2 :: Integer -> Int +integerLog2 i = I# (integerLog2# i) + diff --git a/src/Language/Asn/ObjectIdentifier.hs b/src/Language/Asn/ObjectIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Language/Asn/ObjectIdentifier.hs @@ -0,0 +1,42 @@ +module Language.Asn.ObjectIdentifier where + +import Language.Asn.Types +import Data.Maybe +import Data.Text (Text) +import Data.ByteString (ByteString) +import qualified Data.Text as Text +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.Vector as Vector +import qualified Data.List as List + +fromList :: [Integer] -> ObjectIdentifier +fromList = ObjectIdentifier . Vector.fromList + +suffixSingleton :: Integer -> ObjectIdentifierSuffix +suffixSingleton = ObjectIdentifierSuffix . Vector.singleton + +appendSuffix :: ObjectIdentifier -> ObjectIdentifierSuffix -> ObjectIdentifier +appendSuffix (ObjectIdentifier a) (ObjectIdentifierSuffix b) = ObjectIdentifier (a Vector.++ b) + +isPrefixOf :: ObjectIdentifier -> ObjectIdentifier -> Bool +isPrefixOf a b = isJust (stripPrefix a b) + +-- improve this later +stripPrefix :: ObjectIdentifier -> ObjectIdentifier -> Maybe ObjectIdentifierSuffix +stripPrefix (ObjectIdentifier a) (ObjectIdentifier b) = + let lenA = Vector.length a + in if (lenA <= Vector.length b) && (a == Vector.take lenA b) + then Just (ObjectIdentifierSuffix (Vector.drop lenA b)) + else Nothing + +encodeString :: ObjectIdentifier -> String +encodeString = List.intercalate "." . Vector.toList . Vector.map show . getObjectIdentifier + +encodeByteString :: ObjectIdentifier -> ByteString +encodeByteString = BC8.pack . encodeString + +encodeText :: ObjectIdentifier -> Text +encodeText = Text.pack . encodeString + + diff --git a/src/Language/Asn/Types.hs b/src/Language/Asn/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Asn/Types.hs @@ -0,0 +1,11 @@ +module Language.Asn.Types + ( AsnEncoding + , AsnDecoding + , ObjectIdentifier(..) + , ObjectIdentifierSuffix(..) + , TagClass(..) + , Explicitness(..) + -- , AsnDecoding + ) where + +import Language.Asn.Types.Internal diff --git a/src/Language/Asn/Types/Internal.hs b/src/Language/Asn/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Asn/Types/Internal.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveGeneric #-} + +{-# OPTIONS_GHC -Wall #-} + +module Language.Asn.Types.Internal where + +import Prelude hiding (sequence,null) +import Data.String +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.Text (Text) +import Data.Monoid +import Data.Word +import Data.Int +import Data.Bits +import Data.Vector (Vector) +import GHC.Int (Int(..)) +import GHC.Integer.Logarithms (integerLog2#) +import Data.Foldable +import Data.Hashable (Hashable(..)) +import GHC.Generics (Generic) +import Data.Functor.Contravariant (Contravariant(..)) +import qualified Data.Text.Encoding as TE +import qualified Text.PrettyPrint as PP +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Builder as Builder +import qualified Data.List as List +import qualified Data.Vector as Vector + +data AsnEncoding a + = EncSequence [Field a] + | forall b. EncSequenceOf (a -> [b]) (AsnEncoding b) + | EncChoice (Choice a) + | EncRetag TagAndExplicitness (AsnEncoding a) + | EncUniversalValue (UniversalValue a) + +instance Contravariant AsnEncoding where + contramap f x = case x of + EncRetag te y -> EncRetag te (contramap f y) + EncUniversalValue u -> EncUniversalValue (contramap f u) + EncSequence xs -> EncSequence (map (contramap f) xs) + EncChoice c -> EncChoice (contramap f c) + EncSequenceOf conv enc -> EncSequenceOf (conv . f) enc + +data UniversalValue a + = UniversalValueBoolean (a -> Bool) (Subtypes Bool) + | UniversalValueInteger (a -> Integer) (Subtypes Integer) + | UniversalValueNull + | UniversalValueOctetString (a -> ByteString) (Subtypes ByteString) + | UniversalValueTextualString StringType (a -> Text) (Subtypes Text) (Subtypes Char) + | UniversalValueObjectIdentifier (a -> ObjectIdentifier) (Subtypes ObjectIdentifier) + +instance Contravariant UniversalValue where + contramap f x = case x of + UniversalValueBoolean conv s -> UniversalValueBoolean (conv . f) s + UniversalValueInteger conv s -> UniversalValueInteger (conv . f) s + UniversalValueObjectIdentifier conv s -> UniversalValueObjectIdentifier (conv . f) s + UniversalValueOctetString conv s -> UniversalValueOctetString (conv . f) s + UniversalValueTextualString typ conv s1 s2 -> UniversalValueTextualString typ (conv . f) s1 s2 + UniversalValueNull -> UniversalValueNull + +newtype Subtypes a = Subtypes { getSubtypes :: [Subtype a] } + deriving (Monoid) + +newtype ObjectIdentifier = ObjectIdentifier { getObjectIdentifier :: Vector Integer } + deriving (Eq,Ord,Show,Read,Generic) + +instance Hashable ObjectIdentifier where + hash (ObjectIdentifier v) = hash (Vector.toList v) + hashWithSalt s (ObjectIdentifier v) = hashWithSalt s (Vector.toList v) + +newtype ObjectIdentifierSuffix = ObjectIdentifierSuffix { getObjectIdentifierSuffix :: Vector Integer } + deriving (Eq,Ord,Show,Read,Generic) + +instance Hashable ObjectIdentifierSuffix where + hash (ObjectIdentifierSuffix v) = hash (Vector.toList v) + hashWithSalt s (ObjectIdentifierSuffix v) = hashWithSalt s (Vector.toList v) + +data Subtype a + = SubtypeSingleValue a -- This also acts as PermittedAlphabet + | SubtypeValueRange a a + +data StringType + = Utf8String + | NumericString + | PrintableString + | TeletexString + | VideotexString + | IA5String + | GraphicString + | VisibleString + | GeneralString + | UniversalString + | CharacterString + | BmpString + +data Explicitness = Explicit | Implicit +data TagAndExplicitness = TagAndExplicitness Tag Explicitness + +data Choice a = forall b. Choice (a -> b) [b] (b -> ValueAndEncoding) + +instance Contravariant Choice where + contramap f (Choice conv bs bToValEnc) = + Choice (conv . f) bs bToValEnc + +data ValueAndEncoding = forall b. ValueAndEncoding Int OptionName b (AsnEncoding b) +data Field a + = forall b. FieldRequired FieldName (a -> b) (AsnEncoding b) + | forall b. FieldOptional FieldName (a -> Maybe b) (AsnEncoding b) + | forall b. FieldDefaulted FieldName (a -> b) b (b -> String) (b -> b -> Bool) (AsnEncoding b) + +instance Contravariant Field where + contramap f x = case x of + FieldRequired name g enc -> FieldRequired name (g . f) enc + FieldOptional name g enc -> FieldOptional name (g . f) enc + FieldDefaulted name g b1 b2 b3 enc -> FieldDefaulted name (g . f) b1 b2 b3 enc + +data TaggedByteString = TaggedByteString !Construction !Tag !LB.ByteString +data TaggedStrictByteString = TaggedStrictByteString !Construction !Tag !ByteString +data Construction = Constructed | Primitive + deriving (Show,Eq) + +newtype FieldName = FieldName { getFieldName :: String } + deriving (IsString) +newtype OptionName = OptionName { getOptionName :: String } + deriving (IsString) + +data TagClass + = Universal + | Application + | Private + | ContextSpecific + deriving (Show,Eq) + +data Tag = Tag + { tagClass :: TagClass + , tagNumber :: Int + } deriving (Show,Eq) + +instance Num TagAndExplicitness where + (+) = error "TagAndExplicitness does not support addition" + (-) = error "TagAndExplicitness does not support subtraction" + (*) = error "TagAndExplicitness does not support multiplication" + abs = error "TagAndExplicitness does not support abs" + signum = error "TagAndExplicitness does not support signum" + negate = error "TagAndExplicitness does not support negate" + fromInteger n = TagAndExplicitness + (Tag ContextSpecific (fromIntegral n)) + Explicit + +instance Num Tag where + (+) = error "Tag does not support addition" + (-) = error "Tag does not support subtraction" + (*) = error "Tag does not support multiplication" + abs = error "Tag does not support abs" + signum = error "Tag does not support signum" + negate = error "Tag does not support negate" + fromInteger n = Tag ContextSpecific (fromIntegral n) + + +------------------------------ +-- Stuff specific to decoding +------------------------------ + +data AsnDecoding a + = AsnDecodingUniversal (UniverseDecoding a) + | forall b. AsnDecodingSequenceOf ([b] -> a) (AsnDecoding b) + | forall b. AsnDecodingConversion (AsnDecoding b) (b -> Either String a) + | AsnDecodingRetag TagAndExplicitness (AsnDecoding a) + | AsnDecodingSequence (FieldDecoding a) + | AsnDecodingChoice [OptionDecoding a] + +deriving instance Functor AsnDecoding + +data Ap f a where + Pure :: a -> Ap f a + Ap :: f a -> Ap f (a -> b) -> Ap f b + +instance Functor (Ap f) where + fmap f (Pure a) = Pure (f a) + fmap f (Ap x y) = Ap x ((f .) <$> y) + +instance Applicative (Ap f) where + pure = Pure + Pure f <*> y = fmap f y + Ap x y <*> z = Ap x (flip <$> y <*> z) + +data OptionDecoding a = OptionDecoding OptionName (AsnDecoding a) + deriving (Functor) + +newtype FieldDecoding a = FieldDecoding (Ap FieldDecodingPart a) + deriving (Functor,Applicative) + +data FieldDecodingPart a + = FieldDecodingRequired FieldName (AsnDecoding a) + | FieldDecodingDefault FieldName (AsnDecoding a) a (a -> String) + | forall b. FieldDecodingOptional FieldName (AsnDecoding b) (Maybe b -> a) + +data UniverseDecoding a + = UniverseDecodingInteger (Integer -> a) (Subtypes Integer) + | UniverseDecodingTextualString StringType (Text -> a) (Subtypes Text) (Subtypes Char) + | UniverseDecodingOctetString (ByteString -> a) (Subtypes ByteString) + | UniverseDecodingObjectIdentifier (ObjectIdentifier -> a) (Subtypes ObjectIdentifier) + | UniverseDecodingNull a + deriving (Functor) + +newtype DecodePart a = DecodePart { getDecodePart :: ByteString -> Either String (a,ByteString) } + deriving (Functor) + +instance Applicative DecodePart where + pure a = DecodePart (\bs -> Right (a,bs)) + DecodePart f <*> DecodePart g = DecodePart $ \bs1 -> do + (h,bs2) <- f bs1 + (a,bs3) <- g bs2 + return (h a, bs3) + +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp _ (Pure x) = pure x +runAp u (Ap f x) = flip id <$> u f <*> runAp u x + +liftAp :: f a -> Ap f a +liftAp x = Ap x (Pure id) +{-# INLINE liftAp #-} + +-------------------------- +-- Functions common to encoding and decoding +-------------------------- + +-- Bit six is 1 when a value is constructed. +constructionBit :: Construction -> Word8 +constructionBit x = case x of + Constructed -> 32 + Primitive -> 0 + +-- Controls upper two bits in the octet +tagClassBit :: TagClass -> Word8 +tagClassBit x = case x of + Universal -> 0 + Application -> 64 + ContextSpecific -> 128 + Private -> 192 + +sequenceTag :: Tag +sequenceTag = Tag Universal 16 + +tagNumStringType :: StringType -> Int +tagNumStringType x = case x of + Utf8String -> 12 + NumericString -> 18 + PrintableString -> 19 + TeletexString -> 20 + VideotexString -> 21 + IA5String -> 22 + GraphicString -> 25 + VisibleString -> 26 + GeneralString -> 27 + UniversalString -> 28 + CharacterString -> 29 + BmpString -> 30 diff --git a/src/Net/Snmp/Client.hs b/src/Net/Snmp/Client.hs new file mode 100644 --- /dev/null +++ b/src/Net/Snmp/Client.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Net.Snmp.Client where + +import Net.Snmp.Types +import Language.Asn.Types +import Data.Coerce +import Control.Monad.STM +import Control.Concurrent.STM.TVar +import Control.Concurrent.STM.TMVar +import Data.Map (Map) +import Data.Maybe +import Data.Word +import Data.Vector (Vector) +import Data.IntMap (IntMap) +import Control.Monad +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan +import Data.ByteString (ByteString) +import Control.Exception (throwIO,Exception) +import Control.Applicative +import Data.Functor +import Data.Int +import Control.Concurrent +import Debug.Trace +import Text.Printf (printf) +import Data.Bits +import qualified Data.Vector as Vector +import qualified Data.IntMap as IntMap +import qualified Network.Socket as NS +import qualified Data.ByteString as ByteString +import qualified Network.Socket.ByteString as NSB +import qualified Net.Snmp.Decoding as SnmpDecoding +import qualified Net.Snmp.Encoding as SnmpEncoding +import qualified Language.Asn.Decoding as AsnDecoding +import qualified Language.Asn.Encoding as AsnEncoding +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as LB +import qualified System.Posix.Types + +data Session = Session + { sessionSockets :: !(Chan NS.Socket) + -- , sessionCredsTimestamps :: !(TVar (Map Word32 + , sessionSocketCount :: !Int + , sessionRequestId :: !(TVar RequestId) + , sessionAesSalt :: !(TVar AesSalt) + , sessionTimeoutMicroseconds :: !Int + , sessionMaxTries :: !Int + } + +data Config = Config + { configSocketPoolSize :: !Int + , configTimeoutMicroseconds :: !Int + , configRetries :: !Int + } deriving (Show,Eq) + +data Destination = Destination + { destinationHost :: !(Word8,Word8,Word8,Word8) + , destinationPort :: !Word16 + } deriving (Show,Eq) + +data Credentials + = CredentialsConstructV2 CredentialsV2 + | CredentialsConstructV3 CredentialsV3 + deriving (Show,Eq) + +newtype CredentialsV2 = CredentialsV2 + { credentialsV2CommunityString :: ByteString + } deriving (Show,Eq) + + +data CredentialsV3 = CredentialsV3 + { credentialsV3Crypto :: !Crypto + , credentialsV3ContextName :: !ByteString + , credentialsV3User :: !ByteString + } deriving (Show,Eq) + +data Context = Context + { contextSession :: !Session + , contextDestination :: !Destination + , contextCredentials :: !Credentials + } + +data PerHostV3 = PerHostV3 + { perHostV3AuthoritativeEngineId :: !EngineId + , perHostV3ReceiverTime :: !Int32 + , perHostV3ReceiverBoots :: !Int32 + } + + + +-- | Only one connection can be open at a time on a given port. +openSession :: Config -> IO Session +openSession (Config socketPoolSize timeout retries) = do + addrinfos <- NS.getAddrInfo + (Just (NS.defaultHints {NS.addrFlags = [NS.AI_PASSIVE]})) + (Just "0.0.0.0") + Nothing + let serveraddr = head addrinfos + allSockets <- replicateM socketPoolSize $ do + sock <- NS.socket (NS.addrFamily serveraddr) NS.Datagram NS.defaultProtocol + NS.bind sock (NS.addrAddress serveraddr) + return sock + requestIdVar <- newTVarIO (RequestId 1) + aesSaltVar <- newTVarIO (AesSalt 1) + socketChan <- newChan + writeList2Chan socketChan allSockets + return (Session socketChan socketPoolSize requestIdVar aesSaltVar timeout retries) + +closeSession :: Session -> IO () +closeSession session = replicateM_ (sessionSocketCount session) $ do + sock <- readChan (sessionSockets session) + NS.close sock + +generalRequest :: + (RequestId -> Pdus) + -> (Pdu -> Either SnmpException a) + -> Context + -> IO (Either SnmpException a) +generalRequest pdusFromRequestId fromPdu (Context session (Destination ip port) creds) = do + sock <- readChan (sessionSockets session) + case creds of + CredentialsConstructV2 (CredentialsV2 commStr) -> do + requestId <- nextRequestId (sessionRequestId session) + let !bs = id + $ LB.toStrict + $ AsnEncoding.der SnmpEncoding.messageV2 + $ MessageV2 commStr + $ pdusFromRequestId requestId + !bsLen = ByteString.length bs + go1 :: Int -> IO (Either SnmpException Pdu) + go1 !n1 = if n1 > 0 + then do + when inDebugMode $ putStrLn "Sending:" + when inDebugMode $ putStrLn (hexByteStringInternal bs) + bytesSentLen <- NSB.sendTo sock bs (NS.SockAddrInet (fromIntegral port) (NS.tupleToHostAddress ip)) + if bytesSentLen /= bsLen + then return $ Left $ SnmpExceptionNotAllBytesSent bytesSentLen bsLen + else do + let go2 mperHostV3 = do + (isReadyAction,deregister) <- threadWaitReadSTM (mySockFd sock) + delay <- registerDelay (sessionTimeoutMicroseconds session) + isContentReady <- atomically $ (isReadyAction $> True) <|> (fini delay $> False) + deregister + if not isContentReady + then go1 (n1 - 1) + else do + bsRecv <- NSB.recv sock 10000 + when inDebugMode $ putStrLn "Received:" + when inDebugMode $ print bsRecv + if ByteString.null bsRecv + then return (Left SnmpExceptionSocketClosed) + else case AsnDecoding.ber SnmpDecoding.messageV2 bsRecv of + Left err -> return (Left $ SnmpExceptionDecoding err) + Right msg -> case messageV2Data msg of + PdusResponse pdu@(Pdu respRequestId _ _ _) -> + case compare requestId respRequestId of + GT -> go2 mperHostV3 + EQ -> return (Right pdu) + LT -> return $ Left $ SnmpExceptionMissedResponse requestId respRequestId + _ -> return (Left (SnmpExceptionNonPduResponseV2 msg)) + go2 Nothing + else return $ Left SnmpExceptionTimeout + e <- go1 (sessionMaxTries session) + writeChan (sessionSockets session) sock + return (e >>= fromPdu) + CredentialsConstructV3 (CredentialsV3 crypto contextName user) -> do + -- setting the reportable flags is very important + -- for AuthPriv + let flags = cryptoFlags crypto .|. 0x04 + mkAuthParams :: RequestId -> PerHostV3 -> (ByteString,ScopedPduData) -> ByteString + mkAuthParams reqId phv3 privPair = case cryptoAuth crypto of + Nothing -> ByteString.empty + Just (AuthParameters typ password) -> + -- figure out a way to cache this + let key = SnmpEncoding.passwordToKey typ password (perHostV3AuthoritativeEngineId phv3) + serializationWithoutAuth = snd (makeBs (ByteString.replicate 12 0x00) reqId privPair phv3) + in SnmpEncoding.mkSign typ key serializationWithoutAuth + mkPrivParams :: AesSalt -> RequestId -> PerHostV3 -> (ByteString,ScopedPduData) + mkPrivParams theSalt reqId phv3 = case crypto of + AuthPriv (AuthParameters authType authPass) (PrivParameters privType privPass) -> case privType of + PrivTypeAes -> + let (encrypted,actualSaltBs) = SnmpEncoding.aesEncrypt + key + (perHostV3ReceiverBoots phv3) + (perHostV3ReceiverTime phv3) + theSalt + (LB.toStrict (AsnEncoding.der SnmpEncoding.scopedPdu spdu)) + in (actualSaltBs,ScopedPduDataEncrypted encrypted) + PrivTypeDes -> + let (encrypted,actualSaltBs) = SnmpEncoding.desEncrypt + key + (perHostV3ReceiverBoots phv3) + (fromIntegral (getAesSalt theSalt)) + -- (perHostV3ReceiverTime phv3) + (LB.toStrict (AsnEncoding.der SnmpEncoding.scopedPdu spdu)) + in (actualSaltBs,ScopedPduDataEncrypted encrypted) + where key = SnmpEncoding.passwordToKey authType privPass (perHostV3AuthoritativeEngineId phv3) + _ -> (ByteString.empty,ScopedPduDataPlaintext spdu) + where spdu = ScopedPdu (perHostV3AuthoritativeEngineId phv3) contextName (pdusFromRequestId reqId) + makeBs :: ByteString -> RequestId -> (ByteString,ScopedPduData) -> PerHostV3 -> (MessageV3,ByteString) + makeBs activeAuthParams reqId (activePrivParams,spdud) (PerHostV3 authoritativeEngineId receiverTime boots) = + let myMsg = MessageV3 + (HeaderData reqId 1500 flags) -- making up a max size + (Usm authoritativeEngineId boots receiverTime user activeAuthParams activePrivParams) + spdud + -- myMsg2 = trace ("THE MESSAGE TO SEND: " ++ show myMsg) myMsg + in (myMsg, LB.toStrict $ AsnEncoding.der SnmpEncoding.messageV3 $ myMsg) + fullMakeBs :: AesSalt -> RequestId -> PerHostV3 -> (MessageV3, ByteString) + fullMakeBs theSalt reqId phv3 = + let privPair = mkPrivParams theSalt reqId phv3 + authParams = mkAuthParams reqId phv3 privPair + newPair = makeBs authParams reqId privPair phv3 + in newPair + go1 :: Int -> RequestId -> (MessageV3,ByteString) -> Bool -> IO (Either SnmpException Pdu) + go1 !n1 !requestId (!sentMsg,!bsSent) !engineIdsAcquired = if n1 > 0 + then do + when inDebugMode $ putStrLn "Sending:" + when inDebugMode $ putStrLn (hexByteStringInternal bsSent) + let bsLen = ByteString.length bsSent + bytesSentLen <- NSB.sendTo sock bsSent (NS.SockAddrInet (fromIntegral port) (NS.tupleToHostAddress ip)) + if bytesSentLen /= bsLen + then return $ Left $ SnmpExceptionNotAllBytesSent bytesSentLen bsLen + else do + let go2 :: IO (Either SnmpException Pdu) + go2 = do + (isReadyAction,deregister) <- threadWaitReadSTM (mySockFd sock) + delay <- registerDelay (sessionTimeoutMicroseconds session) + isContentReady <- atomically $ (isReadyAction $> True) <|> (fini delay $> False) + deregister + if not isContentReady + then do + when inDebugMode $ putStrLn "NO RESPONSE" + requestId' <- nextRequestId (sessionRequestId session) + go1 (n1 - 1) requestId' (sentMsg,bsSent) engineIdsAcquired + else do + bsRecv <- NSB.recv sock 10000 + when inDebugMode $ putStrLn "Received:" + when inDebugMode $ putStrLn (hexByteStringInternal bsRecv) + if ByteString.null bsRecv + then return (Left SnmpExceptionSocketClosed) + else case AsnDecoding.ber SnmpDecoding.messageV3 bsRecv of + Left err -> return (Left $ SnmpExceptionDecoding err) + Right msg -> do + case cryptoAuth crypto of + Nothing -> return () + Just (AuthParameters typ password) -> do + when inDebugMode $ putStrLn "THE RECEIVED MESSAGE" + when inDebugMode $ print msg + let reencoded = LB.toStrict $ AsnEncoding.der SnmpEncoding.messageV3 msg + when inDebugMode $ putStrLn $ hexByteStringInternal $ reencoded + when (reencoded /= bsRecv) $ do + when inDebugMode $ putStrLn "NOT THE SAME" + let key = SnmpEncoding.passwordToKey typ password (usmAuthoritativeEngineId (messageV3SecurityParameters msg)) + case SnmpEncoding.checkSign typ key msg of + Nothing -> return () + Just (expected,actual) -> do + when (not $ ByteString.null actual) $ do + throwIO $ SnmpExceptionAuthenticationFailure expected actual + let handleSpdu :: ScopedPdu -> IO (Either SnmpException Pdu) + handleSpdu spdu = case scopedPduData spdu of + -- check to make sure that we requested an unencrypted response + -- somehow check the message id in here too + PdusResponse pdu@(Pdu respRequestId _ _ _) -> + case compare requestId respRequestId of + GT -> go2 + EQ -> return (Right pdu) + LT -> return $ Left $ SnmpExceptionMissedResponse requestId respRequestId + PdusReport (Pdu respRequestId _ _ _) -> do + when inDebugMode $ putStrLn $ "Expected Request ID: " ++ show requestId + when inDebugMode $ putStrLn $ "Received Request ID: " ++ show respRequestId + if engineIdsAcquired + then return $ Left (SnmpExceptionBadEngineId sentMsg msg) + else do + let usm = messageV3SecurityParameters msg + phv3 = PerHostV3 + (usmAuthoritativeEngineId usm) + (usmAuthoritativeEngineTime usm) + (usmAuthoritativeEngineBoots usm) + theSalt <- atomically $ nextSalt (sessionAesSalt session) + requestId' <- nextRequestId (sessionRequestId session) + -- Notice that n1 is not decremented in this + -- situation. This is intentional. + go1 n1 requestId' (fullMakeBs theSalt requestId' phv3) True + _ -> return (Left (SnmpExceptionNonPduResponseV3 msg)) + case messageV3Data msg of + ScopedPduDataEncrypted encrypted -> case crypto of + AuthPriv (AuthParameters authType _) (PrivParameters privType privPass) -> do + let usm = messageV3SecurityParameters msg + key = SnmpEncoding.passwordToKey authType privPass (usmAuthoritativeEngineId usm) + mdecrypted = case privType of + PrivTypeDes -> SnmpEncoding.desDecrypt key (usmPrivacyParameters usm) encrypted + PrivTypeAes -> SnmpEncoding.aesDecrypt key (usmPrivacyParameters usm) (usmAuthoritativeEngineBoots usm) (usmAuthoritativeEngineTime usm) encrypted + case mdecrypted of + Just bs -> case AsnDecoding.ber SnmpDecoding.scopedPdu bs of + Left err -> throwIO (SnmpExceptionDecoding err) + Right spdu -> handleSpdu spdu + Nothing -> throwIO SnmpExceptionDecryptionFailure + ScopedPduDataPlaintext spdu -> handleSpdu spdu + go2 + else return $ Left $ SnmpExceptionTimeoutV3 sentMsg + -- boots and estimated time are made up for this, we could do better + let originalPhv3 = PerHostV3 (EngineId "initial-engine-id") 0xFFFFFF 0xEEEEEE + theSalt <- atomically $ nextSalt (sessionAesSalt session) + requestId' <- nextRequestId (sessionRequestId session) + e <- go1 (sessionMaxTries session) requestId' (fullMakeBs theSalt requestId' originalPhv3) False + writeChan (sessionSockets session) sock + return (e >>= fromPdu) + +nextSalt :: TVar AesSalt -> STM AesSalt +nextSalt v = do + AesSalt w <- readTVar v + let s = AesSalt (w + 1) + writeTVar v s + return s + +throwSnmpException :: IO (Either SnmpException a) -> IO a +throwSnmpException = (either throwIO return =<<) + +get :: Context -> ObjectIdentifier -> IO ObjectSyntax +get ctx ident = throwSnmpException (get' ctx ident) + +getBulkStep :: Context -> Int -> ObjectIdentifier -> IO (Vector (ObjectIdentifier,ObjectSyntax)) +getBulkStep ctx maxRep ident = throwSnmpException (getBulkStep' ctx maxRep ident) + +getBulkChildren :: Context -> Int -> ObjectIdentifier -> IO (Vector (ObjectIdentifier,ObjectSyntax)) +getBulkChildren ctx maxRep oid1 = throwSnmpException (getBulkChildren' ctx maxRep oid1) + +get' :: Context -> ObjectIdentifier -> IO (Either SnmpException ObjectSyntax) +get' ctx ident = generalRequest + (\reqId -> PdusGetRequest (Pdu reqId (ErrorStatus 0) (ErrorIndex 0) (Vector.singleton (VarBind ident BindingResultUnspecified)))) + (singleBindingValue ident <=< onlyBindings) + ctx + +getBulkStep' :: Context -> Int -> ObjectIdentifier -> IO (Either SnmpException (Vector (ObjectIdentifier,ObjectSyntax))) +getBulkStep' ctx maxRep ident = generalRequest + (\reqId -> PdusGetBulkRequest (BulkPdu reqId 0 (fromIntegral maxRep) (Vector.singleton (VarBind ident BindingResultUnspecified)))) + (fmap multipleBindings . onlyBindings) + ctx + +getBulkChildren' :: Context -> Int -> ObjectIdentifier -> IO (Either SnmpException (Vector (ObjectIdentifier,ObjectSyntax))) +getBulkChildren' ctx maxRep oid1 = go Vector.empty oid1 where + go prevPairs ident = do + epairsUnfiltered <- getBulkStep' ctx maxRep ident + case epairsUnfiltered of + Left e -> return (Left e) + Right pairsUnfiltered -> do + let pairs = Vector.filter (\(oid,_) -> oidIsPrefixOf oid1 oid) pairsUnfiltered + if Vector.null pairs + then return (Right prevPairs) + else go (prevPairs Vector.++ pairs) (fst (Vector.last pairs)) + +oidIsPrefixOf :: ObjectIdentifier -> ObjectIdentifier -> Bool +oidIsPrefixOf (ObjectIdentifier a) (ObjectIdentifier b) = + let lenA = Vector.length a in + (lenA <= Vector.length b) && + (a == Vector.take lenA b) + +-- There is not a mapMaybe for vector until 0.12.0.0 +multipleBindings :: Vector VarBind -> Vector (ObjectIdentifier,ObjectSyntax) +multipleBindings = Vector.fromList . mapMaybe + ( \(VarBind ident br) -> case br of + BindingResultValue obj -> Just (ident,obj) + _ -> Nothing + ) . Vector.toList + +singleBindingValue :: ObjectIdentifier -> Vector VarBind -> Either SnmpException ObjectSyntax +singleBindingValue oid v = if Vector.length v == 1 + then do + let VarBind name res = v Vector.! 0 + when (name /= oid) $ Left $ SnmpExceptionMismatchedBinding oid name + case res of + BindingResultValue obj -> Right obj + BindingResultUnspecified -> Left SnmpExceptionUnspecified + BindingResultNoSuchObject -> Left (SnmpExceptionNoSuchObject oid) + BindingResultNoSuchInstance -> Left (SnmpExceptionNoSuchInstance oid) + BindingResultEndOfMibView -> Left SnmpExceptionEndOfMibView + else Left (SnmpExceptionMultipleBindings (Vector.length v)) + +onlyBindings :: Pdu -> Either SnmpException (Vector VarBind) +onlyBindings (Pdu _ errStatus@(ErrorStatus e) errIndex bindings) = + if e == 0 then Right bindings else Left (SnmpExceptionPduError errStatus errIndex) + +data SnmpException + = SnmpExceptionNotAllBytesSent !Int !Int + | SnmpExceptionTimeout + | SnmpExceptionTimeoutV3 !MessageV3 + | SnmpExceptionPduError !ErrorStatus !ErrorIndex + | SnmpExceptionMultipleBindings !Int + | SnmpExceptionMismatchedBinding !ObjectIdentifier !ObjectIdentifier + | SnmpExceptionUnspecified -- ^ Should not happen + | SnmpExceptionNoSuchObject !ObjectIdentifier + | SnmpExceptionNoSuchInstance !ObjectIdentifier + | SnmpExceptionEndOfMibView + | SnmpExceptionMissedResponse !RequestId !RequestId + | SnmpExceptionNonPduResponseV2 !MessageV2 + | SnmpExceptionNonPduResponseV3 !MessageV3 + | SnmpExceptionDecoding !String + | SnmpExceptionSocketClosed + | SnmpExceptionAuthenticationFailure !ByteString !ByteString + | SnmpExceptionBadEngineId !MessageV3 !MessageV3 + | SnmpExceptionDecryptionFailure + deriving (Show,Eq) + +instance Exception SnmpException + +readTMVarTimeout :: Int -> TMVar a -> IO (Maybe a) +readTMVarTimeout timeoutAfter pktChannel = do + delay <- registerDelay timeoutAfter + atomically $ + Just <$> readTMVar pktChannel + <|> pure Nothing <* fini delay + +fini :: TVar Bool -> STM () +fini = check <=< readTVar + +nextRequestId :: TVar RequestId -> IO RequestId +nextRequestId requestIdVar = atomically $ do + RequestId i1 <- readTVar requestIdVar + let !i2 = mod (i1 + 1) 100000000 + !i3 = if i2 == 0 then 1 else i2 + writeTVar requestIdVar (RequestId i3) + return (RequestId i3) + +mySockFd :: NS.Socket -> System.Posix.Types.Fd +mySockFd (NS.MkSocket n _ _ _ _) = System.Posix.Types.Fd n + +hexByteStringInternal :: ByteString -> String +hexByteStringInternal = ByteString.foldr (\w xs -> printf "%02X" w ++ xs) [] + +inDebugMode :: Bool +inDebugMode = False + diff --git a/src/Net/Snmp/Decoding.hs b/src/Net/Snmp/Decoding.hs new file mode 100644 --- /dev/null +++ b/src/Net/Snmp/Decoding.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} + +module Net.Snmp.Decoding where + +import Prelude hiding (sequence,null) +import Language.Asn.Decoding +import Language.Asn.Types +import Net.Snmp.Types +import Data.Coerce (coerce) +import Data.ByteString (ByteString) +import Text.Printf (printf) +import Data.Bifunctor +import Data.Bits +import Data.Monoid +import Data.Maybe +import Data.Int +import qualified Data.List as List +import qualified Crypto.MAC.HMAC as HMAC +import qualified Data.ByteArray as BA +import qualified Crypto.Hash as Hash +import qualified Data.ByteString as B +import qualified Data.ByteString as ByteString +import qualified Data.Vector as Vector +import qualified Net.Snmp.Encoding as E +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as LB +import qualified Language.Asn.Decoding as AsnDecoding + +messageV2 :: AsnDecoding MessageV2 +messageV2 = sequence $ MessageV2 + <$ required "version" integer -- make this actually demand that it's 1 + <*> required "community" octetString + <*> required "data" pdus + +simpleSyntax :: AsnDecoding SimpleSyntax +simpleSyntax = choice + [ fmap SimpleSyntaxInteger $ option "integer-value" int32 + , fmap SimpleSyntaxString $ option "string-value" octetString + , fmap SimpleSyntaxObjectId $ option "objectID-value" objectIdentifier + ] + +applicationSyntax :: AsnDecoding ApplicationSyntax +applicationSyntax = choice + [ fmap ApplicationSyntaxIpAddress + $ option "ipAddress-value" $ tag Application 0 Implicit octetStringWord32 + , fmap ApplicationSyntaxCounter + $ option "counter-value" $ tag Application 1 Implicit word32 + , fmap ApplicationSyntaxTimeTicks + $ option "timeticks-value" $ tag Application 3 Implicit word32 + , fmap ApplicationSyntaxArbitrary + $ option "arbitrary-value" $ tag Application 4 Implicit octetString + , fmap ApplicationSyntaxBigCounter + $ option "big-counter-value" $ tag Application 6 Implicit word64 + , fmap ApplicationSyntaxUnsignedInteger + $ option "unsigned-integer-value" $ tag Application 2 Implicit word32 + ] + +objectSyntax :: AsnDecoding ObjectSyntax +objectSyntax = choice + [ fmap ObjectSyntaxSimple $ option "simple" simpleSyntax + , fmap ObjectSyntaxApplication $ option "application-wide" applicationSyntax + ] + +bindingResult :: AsnDecoding BindingResult +bindingResult = choice + [ BindingResultValue <$> option "value" objectSyntax + , BindingResultUnspecified <$ option "unSpecified" null + , BindingResultNoSuchObject <$ option "noSuchObject" (tag ContextSpecific 0 Implicit null) + , BindingResultNoSuchInstance <$ option "noSuchInstance" (tag ContextSpecific 1 Implicit null) + , BindingResultEndOfMibView <$ option "endOfMibView" (tag ContextSpecific 2 Implicit null) + ] + +varBind :: AsnDecoding VarBind +varBind = sequence $ VarBind + <$> required "name" objectIdentifier + -- result is not actually named in the RFC + <*> required "result" bindingResult + +pdu :: AsnDecoding Pdu +pdu = sequence $ Pdu + <$> required "request-id" (coerce int) + <*> required "error-status" (coerce integer) + <*> required "error-index" (coerce int32) + <*> required "variable-bindings" (fmap Vector.fromList $ sequenceOf varBind) + +bulkPdu :: AsnDecoding BulkPdu +bulkPdu = sequence $ BulkPdu + <$> required "request-id" (coerce int) + <*> required "non-repeaters" int32 + <*> required "max-repetitions" int32 + <*> required "variable-bindings" (fmap Vector.fromList $ sequenceOf varBind) + +pdus :: AsnDecoding Pdus +pdus = choice + [ PdusGetRequest <$> option "get-request" (tag ContextSpecific 0 Implicit pdu) + , PdusGetNextRequest <$> option "get-next-request" (tag ContextSpecific 1 Implicit pdu) + , PdusGetBulkRequest <$> option "get-bulk-request" (tag ContextSpecific 5 Implicit bulkPdu) + , PdusResponse <$> option "response" (tag ContextSpecific 2 Implicit pdu) + , PdusSetRequest <$> option "set-request" (tag ContextSpecific 3 Implicit pdu) + , PdusInformRequest <$> option "inform-request" (tag ContextSpecific 6 Implicit pdu) + , PdusSnmpTrap <$> option "snmpV2-trap" (tag ContextSpecific 7 Implicit pdu) + , PdusReport <$> option "report" (tag ContextSpecific 8 Implicit pdu) + ] + +-- onlyMessageId :: AsnDecoding RequestId +-- onlyMessageId = sequence + +messageV3 :: AsnDecoding MessageV3 +messageV3 = sequence $ MessageV3 + <$ required "msgVersion" integer -- make this actually demand that it's 3 + <*> required "msgGlobalData" headerData + <*> required "msgSecurityParameters" + (mapFailable (first ("while decoding security params" ++) . AsnDecoding.ber usm) octetString) + <*> required "msgData" scopedPduDataDecoding + +headerData :: AsnDecoding HeaderData +headerData = sequence $ HeaderData + <$> required "msgID" (coerce int) + <*> required "msgMaxSize" int32 + <*> required "msgFlags" octetStringWord8 + <* required "msgSecurityModel" integer -- make sure this is actually 3 + +-- else Left $ concat +-- [ "wrong auth flags in header data: " +-- , "expected " ++ printf "%08b" (E.cryptoFlags c) +-- , " but found " ++ printf "%08b" w +-- ] + +scopedPduDataDecoding :: AsnDecoding ScopedPduData +scopedPduDataDecoding = choice + [ fmap ScopedPduDataPlaintext $ option "plaintext" scopedPdu + , fmap ScopedPduDataEncrypted $ option "encryptedPDU" octetString + ] + +scopedPdu :: AsnDecoding ScopedPdu +scopedPdu = sequence $ ScopedPdu + <$> required "contextEngineID" (coerce octetString) + <*> required "contextName" octetString + <*> required "data" pdus + +usm :: AsnDecoding Usm -- ((Crypto,Maybe MessageV3),Usm) +usm = sequence $ Usm + <$> required "msgAuthoritativeEngineID" (coerce octetString) + <*> required "msgAuthoritativeEngineBoots" int32 + <*> required "msgAuthoritativeEngineTime" int32 + <*> required "msgUserName" octetString + <*> required "msgAuthenticationParameters" octetString + <*> required "msgPrivacyParameters" octetString + +type Salt = ByteString +type Encrypted = ByteString +type Raw = ByteString + diff --git a/src/Net/Snmp/Encoding.hs b/src/Net/Snmp/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Net/Snmp/Encoding.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} + +module Net.Snmp.Encoding where + +import Prelude hiding (sequence,null) +import Language.Asn.Encoding +import Language.Asn.Types +import Net.Snmp.Types +import Data.Coerce (coerce) +import Data.ByteString (ByteString) +import Data.Functor.Contravariant +import Data.Bifunctor +import Data.Word +import Data.Int +import Data.Bits +import Data.Monoid +import Data.Maybe +import qualified Crypto.Cipher.AES as Priv +import qualified Crypto.Cipher.DES as Priv +import qualified Crypto.Cipher.Types as Priv +-- import qualified Crypto.Cipher.DES as Priv +-- import qualified Crypto.Cipher.AES as Priv + +import qualified Crypto.Data.Padding as Pad +import qualified Crypto.Error as Priv +import qualified Data.ByteString as B +import qualified Data.List as List +import qualified Crypto.MAC.HMAC as HMAC +-- import qualified Crypto.Hash.MD5 as Md5 +-- import qualified Crypto.Hash.SHA1 as Sha + + +import qualified Language.Asn.Encoding as AsnEncoding +import qualified Data.ByteArray as BA +import qualified Crypto.Hash as Hash +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy as BL +import qualified Data.Vector as Vector +import qualified Data.ByteString.Builder as Builder + +messageV2 :: AsnEncoding MessageV2 +messageV2 = sequence + [ required "version" (const 1) integer + , required "community" messageV2CommunityString octetString + , required "data" messageV2Data pdus + ] + +simpleSyntax :: AsnEncoding SimpleSyntax +simpleSyntax = choice + [ SimpleSyntaxInteger 0 + , SimpleSyntaxString ByteString.empty + , SimpleSyntaxObjectId defaultObjectIdentifier + ] $ \x -> case x of + SimpleSyntaxInteger n -> option 0 "integer-value" n int32 + SimpleSyntaxString bs -> option 1 "string-value" bs octetString + SimpleSyntaxObjectId oid -> option 2 "objectID-value" oid objectIdentifier + +applicationSyntax :: AsnEncoding ApplicationSyntax +applicationSyntax = choice + [ ApplicationSyntaxIpAddress 0 + , ApplicationSyntaxCounter 0 + , ApplicationSyntaxTimeTicks 0 + , ApplicationSyntaxArbitrary ByteString.empty + , ApplicationSyntaxBigCounter 0 + , ApplicationSyntaxUnsignedInteger 0 + ] $ \x -> case x of + ApplicationSyntaxIpAddress n -> option 0 "ipAddress-value" n + $ tag Application 0 Implicit octetStringWord32 + ApplicationSyntaxCounter n -> option 1 "counter-value" n + $ tag Application 1 Implicit word32 + ApplicationSyntaxTimeTicks n -> option 2 "timeticks-value" n + $ tag Application 3 Implicit word32 + ApplicationSyntaxArbitrary n -> option 3 "arbitrary-value" n + $ tag Application 4 Implicit octetString + ApplicationSyntaxBigCounter n -> option 4 "big-counter-value" n + $ tag Application 6 Implicit word64 + ApplicationSyntaxUnsignedInteger n -> option 5 "unsigned-integer-value" n + $ tag Application 2 Implicit word32 + +objectSyntax :: AsnEncoding ObjectSyntax +objectSyntax = choice + [ ObjectSyntaxSimple (SimpleSyntaxInteger 0) + , ObjectSyntaxApplication (ApplicationSyntaxCounter 0) + ] $ \x -> case x of + ObjectSyntaxSimple v -> option 0 "simple" v simpleSyntax + ObjectSyntaxApplication v -> option 1 "application-wide" v applicationSyntax + +bindingResult :: AsnEncoding BindingResult +bindingResult = choice + [ BindingResultValue (ObjectSyntaxSimple (SimpleSyntaxInteger 0)) + , BindingResultUnspecified + , BindingResultNoSuchObject + , BindingResultNoSuchInstance + , BindingResultEndOfMibView + ] $ \x -> case x of + BindingResultValue obj -> option 0 "value" obj objectSyntax + BindingResultUnspecified -> option 1 "unSpecified" () null + BindingResultNoSuchObject -> option 2 "noSuchObject" () $ implicitTag 0 null + BindingResultNoSuchInstance -> option 3 "noSuchInstance" () $ implicitTag 1 null + BindingResultEndOfMibView -> option 4 "endOfMibView" () $ implicitTag 2 null + +varBind :: AsnEncoding VarBind +varBind = sequence + [ required "name" varBindName objectIdentifier + -- result is not actually named in the RFC + , required "result" varBindResult bindingResult + ] + +pdu :: AsnEncoding Pdu +pdu = sequence + [ required "request-id" pduRequestId (coerce int) + , required "error-status" pduErrorStatus (coerce integer) + , required "error-index" pduErrorIndex (coerce int32) + , required "variable-bindings" pduVariableBindings (sequenceOf varBind) + ] + +bulkPdu :: AsnEncoding BulkPdu +bulkPdu = sequence + [ required "request-id" bulkPduRequestId (coerce int) + , required "non-repeaters" bulkPduNonRepeaters int32 + , required "max-repetitions" bulkPduMaxRepetitions int32 + , required "variable-bindings" bulkPduVariableBindings (sequenceOf varBind) + ] + +pdus :: AsnEncoding Pdus +pdus = choice + [ PdusGetRequest defaultPdu + , PdusGetNextRequest defaultPdu + , PdusGetBulkRequest (BulkPdu (RequestId 0) 0 0 Vector.empty) + , PdusResponse defaultPdu + , PdusSetRequest defaultPdu + , PdusInformRequest defaultPdu + , PdusSnmpTrap defaultPdu + , PdusReport defaultPdu + ] $ \x -> case x of + PdusGetRequest p -> option 0 "get-request" p $ implicitTag 0 pdu + PdusGetNextRequest p -> option 1 "get-next-request" p $ implicitTag 1 pdu + PdusGetBulkRequest p -> option 2 "get-bulk-request" p $ implicitTag 5 bulkPdu + PdusResponse p -> option 3 "response" p $ implicitTag 2 pdu + PdusSetRequest p -> option 4 "set-request" p $ implicitTag 3 pdu + PdusInformRequest p -> option 5 "inform-request" p $ implicitTag 6 pdu + PdusSnmpTrap p -> option 6 "snmpV2-trap" p $ implicitTag 7 pdu + PdusReport p -> option 7 "report" p $ implicitTag 8 pdu + +defaultObjectIdentifier :: ObjectIdentifier +defaultObjectIdentifier = ObjectIdentifier (Vector.fromList [1,3,6]) + +defaultPdu :: Pdu +defaultPdu = Pdu (RequestId 0) (ErrorStatus 0) (ErrorIndex 0) Vector.empty + +defaultUsm :: Usm +defaultUsm = Usm defaultEngineId 0 0 ByteString.empty ByteString.empty ByteString.empty + +-- messageV3 :: AsnEncoding ((Crypto,AesSalt),MessageV3) +-- messageV3 = contramap (\(c,m) -> ((c,Just m),m)) internalMessageV3 + +messageV3 :: AsnEncoding MessageV3 +messageV3 = sequence + [ required "msgVersion" (const 3) integer + , required "msgGlobalData" messageV3GlobalData headerData + , required "msgSecurityParameters" + (\msg -> LB.toStrict (AsnEncoding.der usm (messageV3SecurityParameters msg))) + octetString + , required "msgData" messageV3Data scopedPduDataEncoding + ] + +headerData :: AsnEncoding HeaderData +headerData = sequence + [ required "msgID" headerDataId (coerce int) + , required "msgMaxSize" headerDataMaxSize int32 + , required "msgFlags" headerDataFlags octetStringWord8 + , required "msgSecurityModel" (const 3) integer + ] + +scopedPduDataEncoding :: AsnEncoding ScopedPduData +scopedPduDataEncoding = choice + [ ScopedPduDataPlaintext defaultScopedPdu + , ScopedPduDataEncrypted ByteString.empty + ] $ \s -> case s of + ScopedPduDataPlaintext spdu -> option 0 "plaintext" spdu scopedPdu + ScopedPduDataEncrypted bs -> option 1 "encryptedPDU" bs octetString + +-- scopedPduDataEncoding :: AsnEncoding (((Crypto,AesSalt),Usm),ScopedPdu) +-- scopedPduDataEncoding = choice +-- [ (((NoAuthNoPriv, AesSalt 0),defaultUsm), defaultScopedPdu) +-- , (((AuthPriv defaultAuthParams defaultPrivParams, AesSalt 0),defaultUsm), defaultScopedPdu) +-- ] $ \(((c,theSalt),u),spdu) -> case c of +-- AuthPriv (AuthParameters authType authKey) (PrivParameters privType privPass) -> +-- option 1 "encryptedPDU" spdu $ contramap +-- (\spdu -> case privType of +-- PrivTypeDes -> desEncrypt +-- (passwordToKey authType authKey (usmEngineId u)) +-- (usmEngineBoots u) +-- (usmEngineTime u) +-- (LB.toStrict (AsnEncoding.der scopedPdu spdu)) +-- PrivTypeAes -> aesEncrypt +-- (passwordToKey authType authKey (usmEngineId u)) +-- (usmEngineBoots u) +-- (usmEngineTime u) +-- theSalt +-- (LB.toStrict (AsnEncoding.der scopedPdu spdu)) +-- ) +-- octetString +-- _ -> option 0 "plaintext" spdu scopedPdu + +scopedPdu :: AsnEncoding ScopedPdu +scopedPdu = sequence + [ required "contextEngineID" scopedPduContextEngineId (coerce octetString) + , required "contextName" scopedPduContextName octetString + , required "data" scopedPduData pdus + ] + +usm :: AsnEncoding Usm +usm = sequence + [ required "msgAuthoritativeEngineID" usmAuthoritativeEngineId (coerce octetString) + , required "msgAuthoritativeEngineBoots" usmAuthoritativeEngineBoots int32 + , required "msgAuthoritativeEngineTime" usmAuthoritativeEngineTime int32 + , required "msgUserName" usmUserName octetString + , required "msgAuthenticationParameters" usmAuthenticationParameters octetString + , required "msgPrivacyParameters" usmPrivacyParameters octetString + ] + +-- hashEncodedMessage :: AuthType -> ByteString -> ByteString +-- hashEncodedMessage x bs = case x of +-- AuthTypeMd5 -> BA.convert (Hash.hash bs :: Hash.Digest Hash.MD5) +-- AuthTypeSha -> BA.convert (Hash.hash bs :: Hash.Digest Hash.SHA1) + +hmacEncodedMessage :: AuthType -> ByteString -> ByteString -> ByteString +hmacEncodedMessage x key bs = case x of + AuthTypeMd5 -> BA.convert (HMAC.hmac key bs :: HMAC.HMAC Hash.MD5) + AuthTypeSha -> BA.convert (HMAC.hmac key bs :: HMAC.HMAC Hash.SHA1) + +hash :: AuthType -> ByteString -> ByteString +hash AuthTypeMd5 = BA.convert . (Hash.hash :: ByteString -> Hash.Digest Hash.MD5) +hash AuthTypeSha = BA.convert . (Hash.hash :: ByteString -> Hash.Digest Hash.SHA1) + +hashlazy :: AuthType -> LB.ByteString -> ByteString +hashlazy AuthTypeMd5 = BA.convert . (Hash.hashlazy :: LB.ByteString -> Hash.Digest Hash.MD5) +hashlazy AuthTypeSha = BA.convert . (Hash.hashlazy :: LB.ByteString -> Hash.Digest Hash.SHA1) + +passwordToKey :: AuthType -> ByteString -> EngineId -> ByteString +passwordToKey at pass (EngineId eid) = + hash at (authKey <> eid <> authKey) + where + mkAuthKey = hashlazy at . LB.take 1048576 . LB.fromChunks . List.repeat + !authKey = mkAuthKey pass + +defaultAuthParams :: AuthParameters +defaultAuthParams = AuthParameters AuthTypeSha ByteString.empty + +defaultPrivParams :: PrivParameters +defaultPrivParams = PrivParameters PrivTypeDes ByteString.empty + +defaultScopedPdu :: ScopedPdu +defaultScopedPdu = ScopedPdu defaultEngineId ByteString.empty (PdusGetRequest defaultPdu) + +defaultEngineId :: EngineId +defaultEngineId = EngineId ByteString.empty + +-- type Salt = ByteString +type Encrypted = ByteString +type Raw = ByteString + +desEncrypt :: + ByteString + -> Int32 + -> Int32 + -> ByteString + -> (Encrypted,ByteString) +desEncrypt privKey eb et = + (,salt) . Priv.cbcEncrypt cipher iv . Pad.pad Pad.PKCS5 + where + preIV = B.drop 8 (B.take 16 privKey) + salt = toSalt eb et + iv :: Priv.IV Priv.DES + !iv = fromJust $ Priv.makeIV (B.pack $ B.zipWith xor preIV salt) + !cipher = mkCipher (B.take 8 privKey) + +desDecrypt :: ByteString -> ByteString -> Encrypted -> Maybe Raw +desDecrypt privKey salt = + Just . stripBS . Priv.cbcDecrypt cipher iv + where + preIV = B.drop 8 (B.take 16 privKey) + iv :: Priv.IV Priv.DES + !iv = fromJust $ Priv.makeIV (B.pack $ B.zipWith xor preIV salt) + !cipher = mkCipher (B.take 8 privKey) + +aesDecrypt :: ByteString -> ByteString -> Int32 -> Int32 -> Encrypted -> Maybe Raw +aesDecrypt privKey salt eb et = + Just . stripBS . Priv.cfbDecrypt cipher iv + where + iv :: Priv.IV Priv.AES128 + !iv = fromJust $ Priv.makeIV (toSalt eb et <> salt) + !cipher = mkCipher (B.take 16 privKey) + +stripBS :: ByteString -> ByteString +stripBS bs = + let bs' = B.drop 1 bs + l1 = fromIntegral (B.head bs') + in if testBit l1 7 + then case clearBit l1 7 of + 0 -> error "something bad happened while decrypting" + len -> + let size = uintbs (B.take len (B.drop 1 bs')) + in B.take (size + len + 2) bs + else B.take (l1 + 2) bs + where + {- uintbs return the unsigned int represented by the bytes -} + uintbs = B.foldl' (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 + +aesEncrypt :: ByteString -> Int32 -> Int32 -> AesSalt -> Raw -> (Encrypted,ByteString) +aesEncrypt privKey eb et (AesSalt rcounter) = + (,salt) . Priv.cfbEncrypt cipher iv + where + salt = wToBs rcounter + iv :: Priv.IV Priv.AES128 + !iv = unJust $ Priv.makeIV (toSalt eb et <> salt) + !cipher = mkCipher (B.take 16 privKey) + unJust x = case x of + Nothing -> error "Net.Snmp.Encoding: aesEncrypt: bad salt" + Just a -> a + +wToBs :: Word64 -> ByteString +wToBs x = B.pack + [ fromIntegral (x `shiftR` 56 .&. 0xff) + , fromIntegral (x `shiftR` 48 .&. 0xff) + , fromIntegral (x `shiftR` 40 .&. 0xff) + , fromIntegral (x `shiftR` 32 .&. 0xff) + , fromIntegral (x `shiftR` 24 .&. 0xff) + , fromIntegral (x `shiftR` 16 .&. 0xff) + , fromIntegral (x `shiftR` 8 .&. 0xff) + , fromIntegral (x `shiftR` 0 .&. 0xff) + ] + +toSalt :: Int32 -> Int32 -> ByteString +toSalt x y = B.pack + [ fromIntegral (x `shiftR` 24 .&. 0xff) + , fromIntegral (x `shiftR` 16 .&. 0xff) + , fromIntegral (x `shiftR` 8 .&. 0xff) + , fromIntegral (x `shiftR` 0 .&. 0xff) + , fromIntegral (y `shiftR` 24 .&. 0xff) + , fromIntegral (y `shiftR` 16 .&. 0xff) + , fromIntegral (y `shiftR` 8 .&. 0xff) + , fromIntegral (y `shiftR` 0 .&. 0xff) + ] + +mkCipher :: (Priv.Cipher c) => ByteString -> c +mkCipher = (\(Priv.CryptoPassed x) -> x) . Priv.cipherInit +{-# INLINE mkCipher #-} + +mkSign :: AuthType -> ByteString -> ByteString -> ByteString +mkSign at key = B.take 12 . hmacEncodedMessage at key +{-# INLINE mkSign #-} + +-- mkSign :: AuthType -> ByteString -> ByteString -> ByteString +-- mkSign = error "mkSign: write this" + +checkSign :: AuthType -> ByteString -> MessageV3 -> Maybe (ByteString,ByteString) +checkSign at key msg = if expected == actual + then Nothing + else Just (expected,actual) + where + raw = LB.toStrict (AsnEncoding.der messageV3 (resetAuthParams msg)) + expected = mkSign at key raw + actual = usmAuthenticationParameters (messageV3SecurityParameters msg) + +resetAuthParams :: MessageV3 -> MessageV3 +resetAuthParams m = m + { messageV3SecurityParameters = (messageV3SecurityParameters m) + { usmAuthenticationParameters = ByteString.replicate 12 0x00 + } + } + diff --git a/src/Net/Snmp/Types.hs b/src/Net/Snmp/Types.hs new file mode 100644 --- /dev/null +++ b/src/Net/Snmp/Types.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE BangPatterns #-} + +module Net.Snmp.Types where + +import Language.Asn.Types +import Data.Int +import Data.Word +import Data.ByteString (ByteString) +import Data.Vector (Vector) + +newtype RequestId = RequestId { getRequestId :: Int } + deriving (Eq,Ord,Show,Read) +newtype ErrorIndex = ErrorIndex { getErrorIndex :: Int32 } + deriving (Eq,Show) +newtype ErrorStatus = ErrorStatus { getErrorStatus :: Integer } + deriving (Eq,Show) + +data ObjectSyntax + = ObjectSyntaxSimple !SimpleSyntax + | ObjectSyntaxApplication !ApplicationSyntax + deriving (Eq,Show) + +data SimpleSyntax + = SimpleSyntaxInteger !Int32 + | SimpleSyntaxString !ByteString + | SimpleSyntaxObjectId !ObjectIdentifier + deriving (Eq,Show) + +data ApplicationSyntax + = ApplicationSyntaxIpAddress !Word32 + | ApplicationSyntaxCounter !Word32 + | ApplicationSyntaxTimeTicks !Word32 + | ApplicationSyntaxArbitrary !ByteString + | ApplicationSyntaxBigCounter !Word64 + | ApplicationSyntaxUnsignedInteger !Word32 + deriving (Eq,Show) + +data VarBind = VarBind + { varBindName :: !ObjectIdentifier + , varBindResult :: !BindingResult + } deriving (Eq,Show) + +data BindingResult + = BindingResultValue !ObjectSyntax + | BindingResultUnspecified + | BindingResultNoSuchObject + | BindingResultNoSuchInstance + | BindingResultEndOfMibView + deriving (Eq,Show) + +data Pdus + = PdusGetRequest !Pdu + | PdusGetNextRequest !Pdu + | PdusGetBulkRequest !BulkPdu + | PdusResponse !Pdu + | PdusSetRequest !Pdu + | PdusInformRequest !Pdu + | PdusSnmpTrap !Pdu + | PdusReport !Pdu + deriving (Eq,Show) + +-- | A message as defined by RFC1157. The @version@ field is omitted +-- since it is required to be 1. The encoding and decoding of 'Message' +-- do have this field present though. +data MessageV2 = MessageV2 + { messageV2CommunityString :: !ByteString + , messageV2Data :: !Pdus + -- ^ In the ASN.1 definition of @Message@, this field is an @ANY@. + -- In practice, it is always @PDUs@. + } deriving (Eq,Show) + +data MessageV3 = MessageV3 + { messageV3GlobalData :: !HeaderData + , messageV3SecurityParameters :: !Usm + , messageV3Data :: !ScopedPduData + } deriving (Eq,Show) + +data HeaderData = HeaderData + { headerDataId :: !RequestId + , headerDataMaxSize :: !Int32 + , headerDataFlags :: !Word8 + -- The Security Model is omitted because we only + -- support USM (User Security Model, represented by the number 3), + -- which seems to be the only one actually in use. + -- , headerDataSecurityModel :: !Int + } deriving (Eq,Show) + +-- data AuthFlags = AuthFlagsNoAuthNoPriv | AuthFlagsAuthNoPriv | AuthFlagsAuthPriv + +data AuthType = AuthTypeMd5 | AuthTypeSha + deriving (Eq,Show) +data PrivType = PrivTypeDes | PrivTypeAes + deriving (Eq,Show) + +data Crypto + = NoAuthNoPriv + | AuthNoPriv !AuthParameters + | AuthPriv !AuthParameters !PrivParameters + deriving (Eq,Show) + +data AuthParameters = AuthParameters + { authParametersType :: !AuthType + , authParametersKey :: !ByteString + } deriving (Eq,Show) + +data PrivParameters = PrivParameters + { privParametersType :: !PrivType + , privParametersKey :: !ByteString + } deriving (Eq,Show) + +newtype AesSalt = AesSalt { getAesSalt :: Word64 } + +cryptoFlags :: Crypto -> Word8 +cryptoFlags x = case x of + NoAuthNoPriv -> 0 + AuthNoPriv _ -> 1 + AuthPriv _ _ -> 3 + +cryptoAuth :: Crypto -> Maybe AuthParameters +cryptoAuth x = case x of + NoAuthNoPriv -> Nothing + AuthNoPriv a -> Just a + AuthPriv a _ -> Just a + +cryptoPriv :: Crypto -> Maybe PrivParameters +cryptoPriv x = case x of + NoAuthNoPriv -> Nothing + AuthNoPriv _ -> Nothing + AuthPriv _ a -> Just a + +data ScopedPduData + = ScopedPduDataPlaintext !ScopedPdu + | ScopedPduDataEncrypted !ByteString + deriving (Eq,Show) + +newtype EngineId = EngineId { getEngineId :: ByteString } + deriving (Eq,Ord,Show) + +data ScopedPdu = ScopedPdu + { scopedPduContextEngineId :: !EngineId + , scopedPduContextName :: !ByteString + , scopedPduData :: !Pdus + } deriving (Eq,Show) + +data Usm = Usm + { usmAuthoritativeEngineId :: !EngineId + , usmAuthoritativeEngineBoots :: !Int32 + , usmAuthoritativeEngineTime :: !Int32 + , usmUserName :: !ByteString + , usmAuthenticationParameters :: !ByteString + , usmPrivacyParameters :: !ByteString + } deriving (Eq,Show) + +data Pdu = Pdu + { pduRequestId :: !RequestId + , pduErrorStatus :: !ErrorStatus + , pduErrorIndex :: !ErrorIndex + , pduVariableBindings :: !(Vector VarBind) + } deriving (Eq,Show) + +data BulkPdu = BulkPdu + { bulkPduRequestId :: !RequestId + , bulkPduNonRepeaters :: !Int32 + , bulkPduMaxRepetitions :: !Int32 + , bulkPduVariableBindings :: !(Vector VarBind) + } deriving (Eq,Show) + + + diff --git a/src/TestNetwork.hs b/src/TestNetwork.hs new file mode 100644 --- /dev/null +++ b/src/TestNetwork.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestNetwork where + +import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Network.Socket.ByteString +import Language.Asn.Types +import Net.Snmp.Types +import Net.Snmp.Encoding +import Data.ByteString (ByteString) +import Text.Printf (printf) +import Network.BSD (getProtocolNumber) +import Control.Concurrent +import Control.Monad +import qualified Language.Asn.Encoding as E +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as LB +import qualified Data.Vector as Vector + +printResponse :: MessageV2 -> IO () +printResponse msg = do + addrinfos <- getAddrInfo Nothing (Just "10.10.10.1") (Just "161") + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Stream defaultProtocol + connect sock (addrAddress serveraddr) + sendAll sock (LB.toStrict (E.der messageV2 msg)) + result <- recv sock 2048 + close sock + putStrLn (hexByteString result) + +sendUdp :: MessageV2 -> IO () +sendUdp msg = do + addrinfos <- getAddrInfo Nothing (Just "10.10.10.1") (Just "161") + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Datagram defaultProtocol + connect sock (addrAddress serveraddr) + putStrLn "Sending" + sendAll sock (LB.toStrict $ E.der messageV2 msg) + msg <- recv sock 1024 + close sock + putStr "Got response: " + putStrLn (hexByteString msg) + +backgroundListenUdp :: IO () +backgroundListenUdp = void $ forkIO listenUdp + +listenUdp :: IO () +listenUdp = do + protoNum <- getProtocolNumber "UDP" + serveraddr:_ <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing (Just "161") + sock <- socket (addrFamily serveraddr) Datagram protoNum + bind sock (addrAddress serveraddr) + let go = do + (bs,_) <- recvFrom sock 4096 + if ByteString.null bs + then close sock + else putStrLn (hexByteString bs) >> go + go + +getSystemDescription :: MessageV2 +getSystemDescription = MessageV2 "opsview" + $ PdusGetRequest $ Pdu + (RequestId 10000) + (ErrorStatus 0) + (ErrorIndex 0) + $ Vector.singleton $ VarBind sysDescr BindingResultUnspecified + +sysDescr :: ObjectIdentifier +sysDescr = ObjectIdentifier $ Vector.fromList [1,3,6,1,2,1,1,1,0] + +hexByteString :: ByteString -> String +hexByteString = ByteString.foldr (\w xs -> printf "%02X" w ++ xs) [] + diff --git a/test/Internal.hs b/test/Internal.hs new file mode 100644 --- /dev/null +++ b/test/Internal.hs @@ -0,0 +1,11 @@ +module Internal where + +import Data.Aeson.TH +import Data.Aeson.Types (camelTo2) + +myOptions :: String -> Options +myOptions name = defaultOptions + { fieldLabelModifier = camelTo2 '_' . drop (length name) + , constructorTagModifier = camelTo2 '_' . drop (length name) + } + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +import Prelude hiding (sequence) +import Language.Asn.Types +import qualified Language.Asn.Encoding as Encoding +import qualified Language.Asn.Decoding as Decoding +import Net.Snmp.Client +import Internal (myOptions) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Data.Text (Text) +import Data.Aeson.TH (deriveJSON) +import System.Directory (getDirectoryContents) +import Text.Printf (printf) +import Data.Char (isSpace) +import Net.Snmp.Types +import Data.ByteString (ByteString) +import Numeric (readHex) +import Control.Monad +import qualified Data.Vector as Vector +import qualified Data.Text as Text +import qualified Data.List as List +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString.Lazy.Char8 as LBC8 +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString as BS +import qualified Net.Snmp.Encoding as SnmpEncoding +import qualified Net.Snmp.Decoding as SnmpDecoding +import qualified Data.ByteString.Base16 as Base16 + +main :: IO () +main = do + humanFiles <- List.sort . filter isChildTestDir <$> getDirectoryContents "sample/human" + fooFiles <- List.sort . filter isChildTestDir <$> getDirectoryContents "sample/foo" + textListFiles <- List.sort . filter isChildTestDir <$> getDirectoryContents "sample/text_list" + varBindFiles <- List.sort . filter isChildTestDir <$> getDirectoryContents "sample/var_bind" + messageFiles <- List.sort . filter isChildTestDir <$> getDirectoryContents "sample/message" + messageV3Files <- List.sort . filter isChildTestDir <$> getDirectoryContents "sample/message_v3" + defaultMain + [ testGroup "ASN.1 Codecs" + [ testGroup "Human" (testEncodingDecoding "human" encHuman decHuman =<< humanFiles) + , testGroup "Foo" (testEncodingDecoding "foo" encFoo decFoo =<< fooFiles) + , testGroup "Text List" (testEncodingDecoding "text_list" encTexts decTexts =<< textListFiles) + , testGroup "VarBind" (testEncodingDecoding "var_bind" SnmpEncoding.varBind SnmpDecoding.varBind =<< varBindFiles) + , testGroup "Message V2" (testEncodingDecoding "message" SnmpEncoding.messageV2 SnmpDecoding.messageV2 =<< messageFiles) + -- , testGroup "Message V3" (testEncodingDecoding "message_v3" SnmpEncoding.messageV3 SnmpDecoding.messageV3 =<< messageV3Files) + ] + -- , testCase "DES Encryption Isomorphism" testDesEncryption + , testGroup "SNMP Client" + [ testCase "V2" $ testSnmpClient (CredentialsConstructV2 (CredentialsV2 "public")) + , testCase "V3 NoAuthNoPriv" + $ testSnmpClient + $ CredentialsConstructV3 + $ CredentialsV3 NoAuthNoPriv "" "usr_NoAuthNoPriv" + , testCase "V3 AuthNoPriv MD5" $ testSnmpClient $ authCreds + AuthTypeMd5 "usr_MD5AuthNoPriv" "password_MD5AuthNoPriv" + , testCase "V3 AuthNoPriv SHA" $ testSnmpClient $ authCreds + AuthTypeSha "usr_SHAAuthNoPriv" "password_SHAAuthNoPriv" + , testCase "V3 AuthPriv MD5 DES" $ testSnmpClient $ privCreds + AuthTypeMd5 PrivTypeDes "usr_MD5AuthDESPriv" "password_MD5AuthDESPriv" "encryption_MD5AuthDESPriv" + , testCase "V3 AuthPriv SHA DES" $ testSnmpClient $ privCreds + AuthTypeSha PrivTypeDes "usr_SHAAuthDESPriv" "password_SHAAuthDESPriv" "encryption_SHAAuthDESPriv" + , testCase "V3 AuthPriv MD5 AES" $ testSnmpClient $ privCreds + AuthTypeMd5 PrivTypeAes "usr_MD5AuthAESPriv" "password_MD5AuthAESPriv" "encryption_MD5AuthAESPriv" + , testCase "V3 AuthPriv SHA AES" $ testSnmpClient $ privCreds + AuthTypeSha PrivTypeAes "usr_SHAAuthAESPriv" "password_SHAAuthAESPriv" "encryption_SHAAuthAESPriv" + ] + ] + +-- This does not check for correctness in the case of concurrent +-- SNMP requests. +testSnmpClient :: Credentials -> IO () +testSnmpClient creds = do + s <- openSession (Config 1 2000000 1) + let ctx = Context s (Destination (127,0,0,1) 161) creds + _ <- get ctx (ObjectIdentifier (Vector.fromList [1,3,6,1,2,1,1,1,0])) + closeSession s + +authCreds :: AuthType -> ByteString -> ByteString -> Credentials +authCreds typ user pass = CredentialsConstructV3 + $ CredentialsV3 + (AuthNoPriv (AuthParameters typ pass)) + "" + user + +privCreds :: AuthType -> PrivType -> ByteString -> ByteString -> ByteString -> Credentials +privCreds authType privType user authPass privPass = CredentialsConstructV3 + $ CredentialsV3 + (AuthPriv + (AuthParameters authType authPass) + (PrivParameters privType privPass) + ) + "" + user + +testDesEncryption :: IO () +testDesEncryption = do + let plaintext = "abcdefghijklmnopqrstuvwxyz" + key = SnmpEncoding.passwordToKey AuthTypeMd5 "weakpassword" (EngineId "foobar") + (encrypted,salt) = SnmpEncoding.desEncrypt key 1 2 plaintext + restored = SnmpEncoding.desDecrypt key salt encrypted + restored @?= Just plaintext + +isChildTestDir :: String -> Bool +isChildTestDir s = s /= "." && s /= ".." && s /= "definition.asn1" + +data Human = Human + { humanName :: Text + , humanFirstWords :: Text + , humanAge :: Maybe Age + } deriving (Eq,Show) + +data Age = AgeBiblical Integer | AgeModern Integer + deriving (Eq,Show) + +data Foo = Foo + { fooSize :: Integer + , fooIdentifier :: ObjectIdentifier + } deriving (Eq,Show) + +testEncoding :: Aeson.FromJSON a => String -> AsnEncoding a -> String -> Test +testEncoding name enc dirNum = testCase dirNum $ do + let path = "sample/" ++ name ++ "/" ++ dirNum ++ "/" + valueLbs <- fmap LB.fromStrict $ BS.readFile (path ++ "value.json") + resultLbs <- fmap LB.fromStrict $ BS.readFile (path ++ "value.der.base64") + a <- case Aeson.eitherDecode valueLbs of + Left err -> fail ("bad json file for model [" ++ name ++ "] test [" ++ dirNum ++ "], error was: " ++ err) + Right a -> return a + let encodedLbs = Encoding.der enc a + hexByteString encodedLbs @?= LBC8.unpack (LBC8.filter (not . isSpace) resultLbs) + +testEncodingDecoding :: (Aeson.FromJSON a, Eq a, Show a) => String -> AsnEncoding a -> AsnDecoding a -> String -> [Test] +testEncodingDecoding name enc dec dirNum = + let load = do + let path = "sample/" ++ name ++ "/" ++ dirNum ++ "/" + valueLbs <- fmap LB.fromStrict $ BS.readFile (path ++ "value.json") + resultLbs <- fmap LB.fromStrict $ BS.readFile (path ++ "value.der.base64") + a <- case Aeson.eitherDecode valueLbs of + Left err -> fail ("bad json file for model [" ++ name ++ "] test [" ++ dirNum ++ "], error was: " ++ err) + Right a -> return a + return (resultLbs,a) + in [ testCase (dirNum ++ " encoding") $ do + (resultLbs, a) <- load + let encodedLbs = Encoding.der enc a + hexByteString encodedLbs @?= LBC8.unpack (LBC8.filter (not . isSpace) resultLbs) + , testCase (dirNum ++ " decoding") $ do + (resultLbs, expectedA) <- load + let (bs, remaining) = Base16.decode (BC8.filter (not . isSpace) $ LB.toStrict resultLbs) + when (BS.length remaining > 0) $ fail "provided hexadecimal in DER file was invalid hex" + foundA <- case Decoding.ber dec bs of + Left err -> fail $ "decoding ASN.1 BER file failed with: " ++ show err + Right foundA -> return foundA + foundA @?= expectedA + ] + +encHuman :: AsnEncoding Human +encHuman = Encoding.sequence + [ Encoding.required "name" humanName Encoding.utf8String + , Encoding.defaulted "first-words" humanFirstWords Encoding.utf8String "Hello World" + , Encoding.optional "age" humanAge encAge + ] + +decHuman :: AsnDecoding Human +decHuman = Decoding.sequence $ Human + <$> Decoding.required "name" Decoding.utf8String + <*> Decoding.defaulted "first-words" Decoding.utf8String "Hello World" + <*> Decoding.optional "age" decAge + +decAge :: AsnDecoding Age +decAge = Decoding.choice + [ fmap AgeBiblical $ Decoding.option "biblical" $ Decoding.tag ContextSpecific 0 Explicit $ Decoding.integerRanged 0 1000 + , fmap AgeModern $ Decoding.option "modern" $ Decoding.tag ContextSpecific 1 Explicit $ Decoding.integerRanged 0 100 + ] + +encFoo :: AsnEncoding Foo +encFoo = Encoding.sequence + [ Encoding.required "size" fooSize Encoding.integer + , Encoding.required "identifier" fooIdentifier Encoding.objectIdentifier + ] + +decFoo :: AsnDecoding Foo +decFoo = Decoding.sequence $ Foo + <$> Decoding.required "size" Decoding.integer + <*> Decoding.required "identifier" Decoding.objectIdentifier + +encTexts :: AsnEncoding [Text] +encTexts = Encoding.sequenceOf Encoding.utf8String + +decTexts :: AsnDecoding [Text] +decTexts = Decoding.sequenceOf Decoding.utf8String + +encAge :: AsnEncoding Age +encAge = Encoding.choice [AgeBiblical 0, AgeModern 0] $ \x -> case x of + AgeBiblical n -> Encoding.option 0 "biblical" n $ Encoding.tag ContextSpecific 0 Explicit $ Encoding.integerRanged 0 1000 + AgeModern n -> Encoding.option 1 "modern" n $ Encoding.tag ContextSpecific 1 Explicit $ Encoding.integerRanged 0 100 + +hexByteString :: LB.ByteString -> String +hexByteString = LB.foldr (\w xs -> printf "%02X" w ++ xs) [] + +deriving instance Aeson.ToJSON ObjectIdentifier +deriving instance Aeson.FromJSON ObjectIdentifier +deriving instance Aeson.ToJSON RequestId +deriving instance Aeson.FromJSON RequestId +deriving instance Aeson.ToJSON ErrorStatus +deriving instance Aeson.FromJSON ErrorStatus +deriving instance Aeson.ToJSON ErrorIndex +deriving instance Aeson.FromJSON ErrorIndex +deriving instance Aeson.ToJSON EngineId +deriving instance Aeson.FromJSON EngineId + +instance Aeson.ToJSON ByteString where + toJSON = Aeson.String . Text.pack . ("0x" ++) . hexByteString . LB.fromStrict + +instance Aeson.FromJSON ByteString where + parseJSON = Aeson.withText "ByteString" $ \t -> case Text.unpack t of + '0' : 'x' : s -> + let (bs, remaining) = Base16.decode (BC8.pack s) in if BS.length remaining > 0 + then fail "could not parse bytestring" + else return bs + _ -> fail "bytestring hex should start with 0x" + +$(deriveJSON (myOptions "Age") ''Age) +$(deriveJSON (myOptions "Human") ''Human) +$(deriveJSON (myOptions "Foo") ''Foo) +$(deriveJSON (myOptions "SimpleSyntax") ''SimpleSyntax) +$(deriveJSON (myOptions "ObjectSyntax") ''ObjectSyntax) +$(deriveJSON (myOptions "ApplicationSyntax") ''ApplicationSyntax) +$(deriveJSON (myOptions "BindingResult") ''BindingResult) +$(deriveJSON (myOptions "VarBind") ''VarBind) +$(deriveJSON (myOptions "Pdu") ''Pdu) +$(deriveJSON (myOptions "BulkPdu") ''BulkPdu) +$(deriveJSON (myOptions "Pdus") ''Pdus) +$(deriveJSON (myOptions "HeaderData") ''HeaderData) +$(deriveJSON (myOptions "ScopedPdu") ''ScopedPdu) +$(deriveJSON (myOptions "ScopedPduData") ''ScopedPduData) +$(deriveJSON (myOptions "Usm") ''Usm) +$(deriveJSON (myOptions "MessageV2") ''MessageV2) +$(deriveJSON (myOptions "MessageV3") ''MessageV3) +