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