asn1-codec (empty) → 0.1.0
raw patch · 15 files changed
+2597/−0 lines, 15 filesdep +HUnitdep +aesondep +asn1-codecsetup-changed
Dependencies added: HUnit, aeson, asn1-codec, base, base16-bytestring, bytestring, containers, contravariant, cryptonite, directory, hashable, integer-gmp, memory, network, pretty, stm, test-framework, test-framework-hunit, text, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- asn1-codec.cabal +67/−0
- src/Language/Asn/Decoding.hs +342/−0
- src/Language/Asn/Encoding.hs +372/−0
- src/Language/Asn/ObjectIdentifier.hs +42/−0
- src/Language/Asn/Types.hs +11/−0
- src/Language/Asn/Types/Internal.hs +268/−0
- src/Net/Snmp/Client.hs +434/−0
- src/Net/Snmp/Decoding.hs +154/−0
- src/Net/Snmp/Encoding.hs +376/−0
- src/Net/Snmp/Types.hs +169/−0
- src/TestNetwork.hs +75/−0
- test/Internal.hs +11/−0
- test/Spec.hs +244/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ asn1-codec.cabal view
@@ -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
+ src/Language/Asn/Decoding.hs view
@@ -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+++
+ src/Language/Asn/Encoding.hs view
@@ -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)+
+ src/Language/Asn/ObjectIdentifier.hs view
@@ -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++
+ src/Language/Asn/Types.hs view
@@ -0,0 +1,11 @@+module Language.Asn.Types+ ( AsnEncoding+ , AsnDecoding+ , ObjectIdentifier(..)+ , ObjectIdentifierSuffix(..)+ , TagClass(..)+ , Explicitness(..)+ -- , AsnDecoding+ ) where++import Language.Asn.Types.Internal
+ src/Language/Asn/Types/Internal.hs view
@@ -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
+ src/Net/Snmp/Client.hs view
@@ -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+
+ src/Net/Snmp/Decoding.hs view
@@ -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+
+ src/Net/Snmp/Encoding.hs view
@@ -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+ }+ }+
+ src/Net/Snmp/Types.hs view
@@ -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)+++
+ src/TestNetwork.hs view
@@ -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) []+
+ test/Internal.hs view
@@ -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)+ }+
+ test/Spec.hs view
@@ -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)+