1-- | 2-- Module : Data.ASN1.Parse 3-- License : BSD-style 4-- Maintainer : Vincent Hanquez <vincent@snarc.org> 5-- Stability : experimental 6-- Portability : unknown 7-- 8-- A parser combinator for ASN1 Stream. 9{-# LANGUAGE GeneralizedNewtypeDeriving #-} 10{-# LANGUAGE CPP #-} 11module Data.ASN1.Parse 12 ( ParseASN1 13 -- * run 14 , runParseASN1State 15 , runParseASN1 16 , throwParseError 17 -- * combinators 18 , onNextContainer 19 , onNextContainerMaybe 20 , getNextContainer 21 , getNextContainerMaybe 22 , getNext 23 , getNextMaybe 24 , hasNext 25 , getObject 26 , getMany 27 ) where 28 29import Data.ASN1.Types 30import Data.ASN1.Stream 31import Control.Applicative 32import Control.Arrow (first) 33import Control.Monad (liftM2) 34#if MIN_VERSION_base(4,9,0) 35import Control.Monad.Fail 36#endif 37 38newtype ParseASN1 a = P { runP :: [ASN1] -> Either String (a, [ASN1]) } 39 40instance Functor ParseASN1 where 41 fmap f m = P (either Left (Right . first f) . runP m) 42instance Applicative ParseASN1 where 43 pure a = P $ \s -> Right (a, s) 44 (<*>) mf ma = P $ \s -> 45 case runP mf s of 46 Left err -> Left err 47 Right (f, s2) -> 48 case runP ma s2 of 49 Left err -> Left err 50 Right (a, s3) -> Right (f a, s3) 51instance Monad ParseASN1 where 52 return a = pure a 53 (>>=) m1 m2 = P $ \s -> 54 case runP m1 s of 55 Left err -> Left err 56 Right (a, s2) -> runP (m2 a) s2 57instance Alternative ParseASN1 where 58 empty = P $ \_ -> Left "empty Alternative" 59 (<|>) m1 m2 = P $ \s -> 60 case runP m1 s of 61 Left _ -> runP m2 s 62 Right (a, s2) -> Right (a, s2) 63#if MIN_VERSION_base(4,9,0) 64instance MonadFail ParseASN1 where 65 fail = throwParseError 66#endif 67 68get :: ParseASN1 [ASN1] 69get = P $ \stream -> Right (stream, stream) 70 71put :: [ASN1] -> ParseASN1 () 72put stream = P $ \_ -> Right ((), stream) 73 74-- | throw a parse error 75throwParseError :: String -> ParseASN1 a 76throwParseError s = P $ \_ -> Left s 77 78-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream. 79runParseASN1State :: ParseASN1 a -> [ASN1] -> Either String (a,[ASN1]) 80runParseASN1State f s = runP f s 81 82-- | run the parse monad over a stream and returns the result. 83-- 84-- If there's still some asn1 object in the state after calling f, 85-- an error will be raised. 86runParseASN1 :: ParseASN1 a -> [ASN1] -> Either String a 87runParseASN1 f s = 88 case runP f s of 89 Left err -> Left err 90 Right (o, []) -> Right o 91 Right (_, er) -> Left ("runParseASN1: remaining state " ++ show er) 92 93-- | get next object 94getObject :: ASN1Object a => ParseASN1 a 95getObject = do 96 l <- get 97 case fromASN1 l of 98 Left err -> throwParseError err 99 Right (a,l2) -> put l2 >> return a 100 101-- | get next element from the stream 102getNext :: ParseASN1 ASN1 103getNext = do 104 list <- get 105 case list of 106 [] -> throwParseError "empty" 107 (h:l) -> put l >> return h 108 109-- | get many elements until there's nothing left 110getMany :: ParseASN1 a -> ParseASN1 [a] 111getMany getOne = do 112 next <- hasNext 113 if next 114 then liftM2 (:) getOne (getMany getOne) 115 else return [] 116 117-- | get next element from the stream maybe 118getNextMaybe :: (ASN1 -> Maybe a) -> ParseASN1 (Maybe a) 119getNextMaybe f = do 120 list <- get 121 case list of 122 [] -> return Nothing 123 (h:l) -> let r = f h 124 in do case r of 125 Nothing -> put list 126 Just _ -> put l 127 return r 128 129-- | get next container of specified type and return all its elements 130getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1] 131getNextContainer ty = do 132 list <- get 133 case list of 134 [] -> throwParseError "empty" 135 (h:l) | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 l 136 put l2 >> return l1 137 | otherwise -> throwParseError "not an expected container" 138 139 140-- | run a function of the next elements of a container of specified type 141onNextContainer :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a 142onNextContainer ty f = getNextContainer ty >>= either throwParseError return . runParseASN1 f 143 144-- | just like getNextContainer, except it doesn't throw an error if the container doesn't exists. 145getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1]) 146getNextContainerMaybe ty = do 147 list <- get 148 case list of 149 [] -> return Nothing 150 (h:l) | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 l 151 put l2 >> return (Just l1) 152 | otherwise -> return Nothing 153 154-- | just like onNextContainer, except it doesn't throw an error if the container doesn't exists. 155onNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a) 156onNextContainerMaybe ty f = do 157 n <- getNextContainerMaybe ty 158 case n of 159 Just l -> either throwParseError (return . Just) $ runParseASN1 f l 160 Nothing -> return Nothing 161 162-- | returns if there's more elements in the stream. 163hasNext :: ParseASN1 Bool 164hasNext = not . null <$> get 165