module Crypto.Store.ASN1.Parse
( ParseASN1
, runParseASN1State
, runParseASN1State_
, runParseASN1
, runParseASN1_
, throwParseError
, onNextContainer
, onNextContainerMaybe
, getNextContainer
, getNextContainerMaybe
, getNext
, getNextMaybe
, hasNext
, getMany
, withAnnotations
) where
import Data.ASN1.Types
import Data.Monoid
import Control.Applicative
import Control.Arrow (first)
import Control.Monad (MonadPlus(..), liftM2)
import Control.Monad.Fail
data State e = State [(ASN1, e)] !e
newtype ParseASN1 e a = P { runP :: State e -> Either String (a, State e) }
instance Functor (ParseASN1 e) where
fmap f m = P (fmap (first f) . runP m)
instance Applicative (ParseASN1 e) where
pure a = P $ \s -> Right (a, s)
(<*>) mf ma = P $ \s ->
case runP mf s of
Left err -> Left err
Right (f, s2) ->
case runP ma s2 of
Left err -> Left err
Right (a, s3) -> Right (f a, s3)
instance Alternative (ParseASN1 e) where
empty = throwParseError "empty"
(<|>) = mplus
instance Monad (ParseASN1 e) where
return = pure
(>>=) m1 m2 = P $ \s ->
case runP m1 s of
Left err -> Left err
Right (a, s2) -> runP (m2 a) s2
fail = throwParseError
instance MonadFail (ParseASN1 e) where
fail = throwParseError
instance MonadPlus (ParseASN1 e) where
mzero = throwParseError "mzero"
mplus m1 m2 = P $ \s ->
case runP m1 s of
Left _ -> runP m2 s
success -> success
get :: ParseASN1 e (State e)
get = P $ \stream -> Right (stream, stream)
put :: State e -> ParseASN1 e ()
put stream = P $ \_ -> Right ((), stream)
throwParseError :: String -> ParseASN1 e a
throwParseError s = P $ \_ -> Left s
wrap :: ASN1 -> (ASN1, ())
wrap a = (a, ())
unwrap :: (ASN1, ()) -> ASN1
unwrap (a, ()) = a
runParseASN1State :: ParseASN1 () a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State f a = do
(a', list) <- runParseASN1State_ f (map wrap a)
return (a', map unwrap list)
runParseASN1State_ :: Monoid e => ParseASN1 e a -> [(ASN1, e)] -> Either String (a, [(ASN1, e)])
runParseASN1State_ f a = do
(r, State a' _) <- runP f (State a mempty)
return (r, a')
runParseASN1 :: ParseASN1 () a -> [ASN1] -> Either String a
runParseASN1 f s = runParseASN1_ f (map wrap s)
runParseASN1_ :: Monoid e => ParseASN1 e a -> [(ASN1, e)] -> Either String a
runParseASN1_ f s =
case runP f (State s mempty) of
Left err -> Left err
Right (o, State [] _) -> Right o
Right (_, State er _) ->
Left ("runParseASN1_: remaining state " ++ show (map fst er))
getNext :: Monoid e => ParseASN1 e ASN1
getNext = do
list <- get
case list of
State [] _ -> throwParseError "empty"
State ((h,e):l) es -> put (State l (es <> e)) >> return h
getMany :: ParseASN1 e a -> ParseASN1 e [a]
getMany getOne = do
next <- hasNext
if next
then liftM2 (:) getOne (getMany getOne)
else return []
getNextMaybe :: Monoid e => (ASN1 -> Maybe a) -> ParseASN1 e (Maybe a)
getNextMaybe f = do
list <- get
case list of
State [] _ -> return Nothing
State ((h,e):l) es -> let r = f h
in do case r of
Nothing -> put list
Just _ -> put (State l (es <> e))
return r
getNextContainer :: Monoid e => ASN1ConstructionType -> ParseASN1 e [(ASN1, e)]
getNextContainer ty = do
list <- get
case list of
State [] _ -> throwParseError "empty"
State ((h,e):l) es | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 (State l (es <> e))
put l2 >> return l1
| otherwise -> throwParseError "not an expected container"
onNextContainer :: Monoid e => ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e a
onNextContainer ty f = getNextContainer ty >>= either throwParseError return . runParseASN1_ f
getNextContainerMaybe :: Monoid e => ASN1ConstructionType -> ParseASN1 e (Maybe [(ASN1, e)])
getNextContainerMaybe ty = do
list <- get
case list of
State [] _ -> return Nothing
State ((h,e):l) es | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 (State l (es <> e))
put l2 >> return (Just l1)
| otherwise -> return Nothing
onNextContainerMaybe :: Monoid e => ASN1ConstructionType -> ParseASN1 e a -> ParseASN1 e (Maybe a)
onNextContainerMaybe ty f = do
n <- getNextContainerMaybe ty
case n of
Just l -> either throwParseError (return . Just) $ runParseASN1_ f l
Nothing -> return Nothing
hasNext :: ParseASN1 e Bool
hasNext = do State l _ <- get; return . not . null $ l
withAnnotations :: Monoid e => ParseASN1 e a -> ParseASN1 e (a, e)
withAnnotations f = do
State l es <- get
case runP f (State l mempty) of
Left err -> throwParseError err
Right (a, State l' es') -> do put (State l' (es <> es'))
return (a, es')
getConstructedEnd :: Monoid e => Int -> State e -> ([(ASN1, e)], State e)
getConstructedEnd _ xs@(State [] _) = ([], xs)
getConstructedEnd i (State (x@(Start _, e):xs) es) = let (yz, zs) = getConstructedEnd (i+1) (State xs (es <> e)) in (x:yz, zs)
getConstructedEnd i (State (x@(End _, e):xs) es)
| i == 0 = ([], State xs (es <> e))
| otherwise = let (ys, zs) = getConstructedEnd (i-1) (State xs (es <> e)) in (x:ys, zs)
getConstructedEnd i (State (x@(_, e):xs) es) = let (ys, zs) = getConstructedEnd i (State xs (es <> e)) in (x:ys, zs)