{-# LANGUAGE LambdaCase #-}
module Data.ASN1.Parse
( ParseASN1
, runParseASN1State
, runParseASN1
, throwParseError
, onNextContainer
, onNextContainerMaybe
, getNextContainer
, getNextContainerMaybe
, getNext
, getNextMaybe
, hasNext
, getObject
, getMany
) where
import Control.Applicative ( Alternative (..) )
import Control.Arrow ( first )
import Control.Monad ( liftM2 )
import Data.ASN1.Types
( ASN1 (..), ASN1ConstructionType (..), ASN1Object (..) )
import Data.ASN1.Stream ( getConstructedEnd )
newtype ParseASN1 a = P { forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP :: [ASN1] -> Either String (a, [ASN1]) }
instance Functor ParseASN1 where
fmap :: forall a b. (a -> b) -> ParseASN1 a -> ParseASN1 b
fmap a -> b
f ParseASN1 a
m = ([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (((a, [ASN1]) -> (b, [ASN1]))
-> Either String (a, [ASN1]) -> Either String (b, [ASN1])
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (a, [ASN1]) -> (b, [ASN1])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> b
f) (Either String (a, [ASN1]) -> Either String (b, [ASN1]))
-> ([ASN1] -> Either String (a, [ASN1]))
-> [ASN1]
-> Either String (b, [ASN1])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m)
instance Applicative ParseASN1 where
pure :: forall a. a -> ParseASN1 a
pure a
a = ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a)
-> ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a b. (a -> b) -> a -> b
$ \[ASN1]
s -> (a, [ASN1]) -> Either String (a, [ASN1])
forall a b. b -> Either a b
Right (a
a, [ASN1]
s)
<*> :: forall a b. ParseASN1 (a -> b) -> ParseASN1 a -> ParseASN1 b
(<*>) ParseASN1 (a -> b)
mf ParseASN1 a
ma = ([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b)
-> ([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b
forall a b. (a -> b) -> a -> b
$ \[ASN1]
s ->
case ParseASN1 (a -> b) -> [ASN1] -> Either String (a -> b, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 (a -> b)
mf [ASN1]
s of
Left String
err -> String -> Either String (b, [ASN1])
forall a b. a -> Either a b
Left String
err
Right (a -> b
f, [ASN1]
s2) ->
case ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
ma [ASN1]
s2 of
Left String
err -> String -> Either String (b, [ASN1])
forall a b. a -> Either a b
Left String
err
Right (a
a, [ASN1]
s3) -> (b, [ASN1]) -> Either String (b, [ASN1])
forall a b. b -> Either a b
Right (a -> b
f a
a, [ASN1]
s3)
instance Monad ParseASN1 where
return :: forall a. a -> ParseASN1 a
return = a -> ParseASN1 a
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
>>= :: forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
(>>=) ParseASN1 a
m1 a -> ParseASN1 b
m2 = ([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b)
-> ([ASN1] -> Either String (b, [ASN1])) -> ParseASN1 b
forall a b. (a -> b) -> a -> b
$ \[ASN1]
s ->
case ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m1 [ASN1]
s of
Left String
err -> String -> Either String (b, [ASN1])
forall a b. a -> Either a b
Left String
err
Right (a
a, [ASN1]
s2) -> ParseASN1 b -> [ASN1] -> Either String (b, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP (a -> ParseASN1 b
m2 a
a) [ASN1]
s2
instance Alternative ParseASN1 where
empty :: forall a. ParseASN1 a
empty = ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a)
-> ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a b. (a -> b) -> a -> b
$ \[ASN1]
_ -> String -> Either String (a, [ASN1])
forall a b. a -> Either a b
Left String
"empty Alternative"
<|> :: forall a. ParseASN1 a -> ParseASN1 a -> ParseASN1 a
(<|>) ParseASN1 a
m1 ParseASN1 a
m2 = ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a)
-> ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a b. (a -> b) -> a -> b
$ \[ASN1]
s ->
case ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m1 [ASN1]
s of
Left String
_ -> ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m2 [ASN1]
s
Right (a
a, [ASN1]
s2) -> (a, [ASN1]) -> Either String (a, [ASN1])
forall a b. b -> Either a b
Right (a
a, [ASN1]
s2)
instance MonadFail ParseASN1 where
fail :: forall a. String -> ParseASN1 a
fail = String -> ParseASN1 a
forall a. String -> ParseASN1 a
throwParseError
runParseASN1State :: ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State :: forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State = ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP
runParseASN1 :: ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 :: forall a. ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 ParseASN1 a
f [ASN1]
list =
case ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
f [ASN1]
list of
Left String
err -> String -> Either String a
forall a b. a -> Either a b
Left String
err
Right (a
result, []) -> a -> Either String a
forall a b. b -> Either a b
Right a
result
Right (a
_, [ASN1]
rest) -> String -> Either String a
forall a b. a -> Either a b
Left (String
"runParseASN1: remaining state " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ASN1] -> String
forall a. Show a => a -> String
show [ASN1]
rest)
throwParseError ::
String
-> ParseASN1 a
throwParseError :: forall a. String -> ParseASN1 a
throwParseError String
err = ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a)
-> ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
forall a b. (a -> b) -> a -> b
$ \[ASN1]
_ -> String -> Either String (a, [ASN1])
forall a b. a -> Either a b
Left String
err
get :: ParseASN1 [ASN1]
get :: ParseASN1 [ASN1]
get = ([ASN1] -> Either String ([ASN1], [ASN1])) -> ParseASN1 [ASN1]
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String ([ASN1], [ASN1])) -> ParseASN1 [ASN1])
-> ([ASN1] -> Either String ([ASN1], [ASN1])) -> ParseASN1 [ASN1]
forall a b. (a -> b) -> a -> b
$ \[ASN1]
list -> ([ASN1], [ASN1]) -> Either String ([ASN1], [ASN1])
forall a b. b -> Either a b
Right ([ASN1]
list, [ASN1]
list)
put :: [ASN1] -> ParseASN1 ()
put :: [ASN1] -> ParseASN1 ()
put [ASN1]
list = ([ASN1] -> Either String ((), [ASN1])) -> ParseASN1 ()
forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (([ASN1] -> Either String ((), [ASN1])) -> ParseASN1 ())
-> ([ASN1] -> Either String ((), [ASN1])) -> ParseASN1 ()
forall a b. (a -> b) -> a -> b
$ \[ASN1]
_ -> ((), [ASN1]) -> Either String ((), [ASN1])
forall a b. b -> Either a b
Right ((), [ASN1]
list)
onNextContainer :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
onNextContainer :: forall a. ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
onNextContainer ASN1ConstructionType
ty ParseASN1 a
f =
ASN1ConstructionType -> ParseASN1 [ASN1]
getNextContainer ASN1ConstructionType
ty ParseASN1 [ASN1] -> ([ASN1] -> ParseASN1 a) -> ParseASN1 a
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> ParseASN1 a)
-> (a -> ParseASN1 a) -> Either String a -> ParseASN1 a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ParseASN1 a
forall a. String -> ParseASN1 a
throwParseError a -> ParseASN1 a
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String a -> ParseASN1 a)
-> ([ASN1] -> Either String a) -> [ASN1] -> ParseASN1 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseASN1 a -> [ASN1] -> Either String a
forall a. ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 ParseASN1 a
f
onNextContainerMaybe ::
ASN1ConstructionType
-> ParseASN1 a
-> ParseASN1 (Maybe a)
onNextContainerMaybe :: forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe ASN1ConstructionType
ty ParseASN1 a
f =
ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
getNextContainerMaybe ASN1ConstructionType
ty ParseASN1 (Maybe [ASN1])
-> (Maybe [ASN1] -> ParseASN1 (Maybe a)) -> ParseASN1 (Maybe a)
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe [ASN1]
Nothing -> Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Just [ASN1]
list -> (String -> ParseASN1 (Maybe a))
-> (a -> ParseASN1 (Maybe a))
-> Either String a
-> ParseASN1 (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ParseASN1 (Maybe a)
forall a. String -> ParseASN1 a
throwParseError (Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> ParseASN1 (Maybe a))
-> (a -> Maybe a) -> a -> ParseASN1 (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) (Either String a -> ParseASN1 (Maybe a))
-> Either String a -> ParseASN1 (Maybe a)
forall a b. (a -> b) -> a -> b
$ ParseASN1 a -> [ASN1] -> Either String a
forall a. ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 ParseASN1 a
f [ASN1]
list
getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]
getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]
getNextContainer ASN1ConstructionType
ty =
ParseASN1 [ASN1]
get ParseASN1 [ASN1]
-> ([ASN1] -> ParseASN1 [ASN1]) -> ParseASN1 [ASN1]
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> String -> ParseASN1 [ASN1]
forall a. String -> ParseASN1 a
throwParseError String
"empty"
(ASN1
item : [ASN1]
rest)
| ASN1
item ASN1 -> ASN1 -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
ty -> do
let ([ASN1]
list, [ASN1]
rest') = Int -> [ASN1] -> ([ASN1], [ASN1])
getConstructedEnd Int
0 [ASN1]
rest
[ASN1] -> ParseASN1 ()
put [ASN1]
rest' ParseASN1 () -> ParseASN1 [ASN1] -> ParseASN1 [ASN1]
forall a b. ParseASN1 a -> ParseASN1 b -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ASN1] -> ParseASN1 [ASN1]
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ASN1]
list
| Bool
otherwise -> String -> ParseASN1 [ASN1]
forall a. String -> ParseASN1 a
throwParseError String
"not an expected container"
getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
getNextContainerMaybe ASN1ConstructionType
ty =
ParseASN1 [ASN1]
get ParseASN1 [ASN1]
-> ([ASN1] -> ParseASN1 (Maybe [ASN1])) -> ParseASN1 (Maybe [ASN1])
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> Maybe [ASN1] -> ParseASN1 (Maybe [ASN1])
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [ASN1]
forall a. Maybe a
Nothing
(ASN1
item : [ASN1]
rest)
| ASN1
item ASN1 -> ASN1 -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
ty -> do
let ([ASN1]
list, [ASN1]
rest') = Int -> [ASN1] -> ([ASN1], [ASN1])
getConstructedEnd Int
0 [ASN1]
rest
[ASN1] -> ParseASN1 ()
put [ASN1]
rest' ParseASN1 ()
-> ParseASN1 (Maybe [ASN1]) -> ParseASN1 (Maybe [ASN1])
forall a b. ParseASN1 a -> ParseASN1 b -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe [ASN1] -> ParseASN1 (Maybe [ASN1])
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ASN1] -> Maybe [ASN1]
forall a. a -> Maybe a
Just [ASN1]
list)
| Bool
otherwise -> Maybe [ASN1] -> ParseASN1 (Maybe [ASN1])
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [ASN1]
forall a. Maybe a
Nothing
getNext :: ParseASN1 ASN1
getNext :: ParseASN1 ASN1
getNext =
ParseASN1 [ASN1]
get ParseASN1 [ASN1] -> ([ASN1] -> ParseASN1 ASN1) -> ParseASN1 ASN1
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> String -> ParseASN1 ASN1
forall a. String -> ParseASN1 a
throwParseError String
"empty"
(ASN1
item : [ASN1]
rest) -> [ASN1] -> ParseASN1 ()
put [ASN1]
rest ParseASN1 () -> ParseASN1 ASN1 -> ParseASN1 ASN1
forall a b. ParseASN1 a -> ParseASN1 b -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ASN1 -> ParseASN1 ASN1
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ASN1
item
getNextMaybe :: (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
getNextMaybe :: forall a. (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
getNextMaybe ASN1 -> Maybe a
f =
ParseASN1 [ASN1]
get ParseASN1 [ASN1]
-> ([ASN1] -> ParseASN1 (Maybe a)) -> ParseASN1 (Maybe a)
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
list :: [ASN1]
list@(ASN1
item : [ASN1]
rest) -> do
let result :: Maybe a
result = ASN1 -> Maybe a
f ASN1
item
case Maybe a
result of
Maybe a
Nothing -> [ASN1] -> ParseASN1 ()
put [ASN1]
list
Just a
_ -> [ASN1] -> ParseASN1 ()
put [ASN1]
rest
Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
result
hasNext :: ParseASN1 Bool
hasNext :: ParseASN1 Bool
hasNext = Bool -> Bool
not (Bool -> Bool) -> ([ASN1] -> Bool) -> [ASN1] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ASN1] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ASN1] -> Bool) -> ParseASN1 [ASN1] -> ParseASN1 Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 [ASN1]
get
getObject :: ASN1Object a => ParseASN1 a
getObject :: forall a. ASN1Object a => ParseASN1 a
getObject = do
[ASN1]
list <- ParseASN1 [ASN1]
get
case [ASN1] -> Either String (a, [ASN1])
forall a. ASN1Object a => [ASN1] -> Either String (a, [ASN1])
fromASN1 [ASN1]
list of
Left String
err -> String -> ParseASN1 a
forall a. String -> ParseASN1 a
throwParseError String
err
Right (a
object, [ASN1]
rest) -> [ASN1] -> ParseASN1 ()
put [ASN1]
rest ParseASN1 () -> ParseASN1 a -> ParseASN1 a
forall a b. ParseASN1 a -> ParseASN1 b -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ParseASN1 a
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
object
getMany :: ParseASN1 a -> ParseASN1 [a]
getMany :: forall a. ParseASN1 a -> ParseASN1 [a]
getMany ParseASN1 a
getOne =
ParseASN1 Bool
hasNext ParseASN1 Bool -> (Bool -> ParseASN1 [a]) -> ParseASN1 [a]
forall a b. ParseASN1 a -> (a -> ParseASN1 b) -> ParseASN1 b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> (a -> [a] -> [a]) -> ParseASN1 a -> ParseASN1 [a] -> ParseASN1 [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) ParseASN1 a
getOne (ParseASN1 a -> ParseASN1 [a]
forall a. ParseASN1 a -> ParseASN1 [a]
getMany ParseASN1 a
getOne)
Bool
False -> [a] -> ParseASN1 [a]
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []