top page > computer > web > rfc > x_690 > 8_1_common > coding > existential > ber_only_decode.html
更新日:
文責: 重城良国

X.690: ASN.1のBER方式の共通部分の存在型を利用したコーディング: デコード

decodeTag, decodeLength関数

decodeTagとdecodeLength関数を含む独立したモジュールを作成。

BasicDecoder.hs

BerDecodeクラス

Decoder.hs

class BerDecode a where
	getAsn1Tag :: a -> Asn1Tag
	decodeRule :: a -> Rule
data Rule = Rule { runRule :: RuleType }
type RuleType = [Rule] -> Asn1Tag -> Maybe Integer ->
	Maybe (Analyzer ByteString BerDecodeBox)

デコード関数

decodeWith :: [Rule] -> Analyzer ByteString BerDecodeBox
decodeWith rl = do
	t <- decodeTag
	l <- decodeLength
	fromJust . fromJust . find isJust $
		map (($ l) . ($ t) . ($ rl) . runRule) rl

BerDecodeBoxの定義

data BerDecodeBox = forall a .
	(Typeable a, BerDecode a) => BerDecodeBox a
	deriving Typeable
instance BerDecode BerDecodeBox where
	getAsn1Tag (BerDecodeBox a) = getAsn1Tag a
	decodeRule (BerDecodeBox a) = decodeRule a
getBerDecode :: Typeable a => BerDecodeBox -> Maybe a
getBerDecode (BerDecodeBox a) = cast a

基本的な型の定義

Raw

data Raw = Raw Asn1Tag ByteString
	deriving (Show, Typeable)
instance BerDecode Raw where
	getAsn1Tag (Raw t _) = t
	decodeRule _ = Rule rawRule
rawRule :: RuleType
rawRule _ t (Just l) =
	Just $ BerDecodeBox . Raw t <$> tokens l
rawRule _ _ _ = Just $ fail "Raw needs length"

RawBytes

data RawBytes = RawBytes ByteString
	deriving (Show, Typeable)
instance BerDecode RawBytes where
	getAsn1Tag (RawBytes bs)
		| Right (t, _) <-
			runAnalyzer decodeTag bs in t
		| otherwise = error "Bad RawBytes"
	decodeRule _ = Rule rawBytesRule
rawBytesRule :: RuleType
rawBytesRule _ t (Just l) =
	Just $ BerDecodeBox . RawBytes <$> do
		bs <- tokens l
		return $ encodeTag t
			`append` encodeLength 0 (Just .
				fromIntegral $ length bs)
			`append` bs
rawBytesRule _ _ _ = Just $ fail "RawBytes needs length"

RawConstructed

data RawConstructed = RawConstructed Asn1Tag [BerDecodeBox]
	deriving Typeable
instance Show RawConstructed where
	showsPrec d (RawConstructed t _) =
		showParen (d > 10) $
			showString "RawConstructed " .
			showsPrec 11 t . showString " [...]"
instance BerDecode RawConstructed where
	getAsn1Tag (RawConstructed t _) = t
	decodeRule _ = Rule rcRule
rcRule :: RuleType
rcRule _ (Asn1Tag Universal Primitive 0) (Just l)
	| l /= 0 = fail "Bad end-of-contents"
rcRule _ (Asn1Tag Universal Primitive 0) Nothing =
	fail "Bad end-of-contents"
rcRule r t@(Asn1Tag _ Constructed _) (Just l) = Just $ do
	s <- tokens l
	let eas = runAnalyzer (listAll $ decodeWith r) s
	case eas of
		Left em -> fail em
		Right (as, "") -> return .
			BerDecodeBox $ RawConstructed t as
		_ -> error "never occur"
rcRule r t@(Asn1Tag _ Constructed _) _ = Just $ do
	as <- loopWhileM notEndOfContents $ decodeWith r
	return . BerDecodeBox $ RawConstructed t as
rcRule _ _ _ = fail "Primitive needs length"
loopWhileM :: Monad m => (a -> Bool) -> m a -> m [a]
loopWhileM p m = m >>= \x -> if p x
	then (x :) `liftM` loopWhileM p m
	else return []
notEndOfContents :: BerDecodeBox -> Bool
notEndOfContents =
	(/= Asn1Tag Universal Primitive 0) . getAsn1Tag

試してみる

% ghci testDecoder.hs
Decoder> :set -XOverloadedStrings
Decoder> let Right (ab, "") = runAnalyzer (decodeWith
[decodeRule (undefined :: RawConstructed), decodeRule
(undefined :: Raw)] cert
Decoder> toRw ab
RC (Asn1Tag Universal Constructed 16) ...

「」へもどる「存在型を利用」トップへ

正当なCSSです! HTML5 Powered with CSS3 / styling, and Semantics