-- |
-- Module      : Data.ASN1.Parse
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- A parser combinator for ASN1 Stream.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}
module Data.ASN1.Parse
    ( ParseASN1
    -- * run
    , runParseASN1State
    , runParseASN1
    , throwParseError
    -- * combinators
    , onNextContainer
    , onNextContainerMaybe
    , getNextContainer
    , getNextContainerMaybe
    , getNext
    , getNextMaybe
    , hasNext
    , getObject
    , getMany
    ) where

import Data.ASN1.Types
import Data.ASN1.Stream
import Control.Applicative
import Control.Arrow (first)
import Control.Monad (liftM2)
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail
#endif

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 ((String -> Either String (b, [ASN1]))
-> ((a, [ASN1]) -> Either String (b, [ASN1]))
-> Either String (a, [ASN1])
-> Either String (b, [ASN1])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Either String (b, [ASN1])
forall a b. a -> Either a b
Left ((b, [ASN1]) -> Either String (b, [ASN1])
forall a b. b -> Either a b
Right ((b, [ASN1]) -> Either String (b, [ASN1]))
-> ((a, [ASN1]) -> (b, [ASN1]))
-> (a, [ASN1])
-> Either String (b, [ASN1])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
a    = a -> ParseASN1 a
forall a. a -> ParseASN1 a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    >>= :: 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)
#if MIN_VERSION_base(4,9,0)
instance MonadFail ParseASN1 where
    fail :: forall a. String -> ParseASN1 a
fail = String -> ParseASN1 a
forall a. String -> ParseASN1 a
throwParseError
#endif

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]
stream -> ([ASN1], [ASN1]) -> Either String ([ASN1], [ASN1])
forall a b. b -> Either a b
Right ([ASN1]
stream, [ASN1]
stream)

put :: [ASN1] -> ParseASN1 ()
put :: [ASN1] -> ParseASN1 ()
put [ASN1]
stream = ([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]
stream)

-- | throw a parse error
throwParseError :: String -> ParseASN1 a
throwParseError :: forall a. String -> ParseASN1 a
throwParseError String
s = ([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
s

-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream.
runParseASN1State :: ParseASN1 a -> [ASN1] -> Either String (a,[ASN1])
runParseASN1State :: forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runParseASN1State ParseASN1 a
f [ASN1]
s = ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
f [ASN1]
s

-- | run the parse monad over a stream and returns the result.
--
-- If there's still some asn1 object in the state after calling f,
-- an error will be raised.
runParseASN1 :: ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 :: forall a. ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 ParseASN1 a
f [ASN1]
s =
    case ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
f [ASN1]
s of
        Left String
err      -> String -> Either String a
forall a b. a -> Either a b
Left String
err
        Right (a
o, []) -> a -> Either String a
forall a b. b -> Either a b
Right a
o
        Right (a
_, [ASN1]
er) -> 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]
er)

-- | get next object
getObject :: ASN1Object a => ParseASN1 a
getObject :: forall a. ASN1Object a => ParseASN1 a
getObject = do
    [ASN1]
l <- ParseASN1 [ASN1]
get
    case [ASN1] -> Either String (a, [ASN1])
forall a. ASN1Object a => [ASN1] -> Either String (a, [ASN1])
fromASN1 [ASN1]
l of
        Left String
err     -> String -> ParseASN1 a
forall a. String -> ParseASN1 a
throwParseError String
err
        Right (a
a,[ASN1]
l2) -> [ASN1] -> ParseASN1 ()
put [ASN1]
l2 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 (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | get next element from the stream
getNext :: ParseASN1 ASN1
getNext :: ParseASN1 ASN1
getNext = do
    [ASN1]
list <- ParseASN1 [ASN1]
get
    case [ASN1]
list of
        []    -> String -> ParseASN1 ASN1
forall a. String -> ParseASN1 a
throwParseError String
"empty"
        (ASN1
h:[ASN1]
l) -> [ASN1] -> ParseASN1 ()
put [ASN1]
l 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 (m :: * -> *) a. Monad m => a -> m a
return ASN1
h

-- | get many elements until there's nothing left
getMany :: ParseASN1 a -> ParseASN1 [a]
getMany :: forall a. ParseASN1 a -> ParseASN1 [a]
getMany ParseASN1 a
getOne = do
    Bool
next <- ParseASN1 Bool
hasNext
    if Bool
next
        then (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)
        else [a] -> ParseASN1 [a]
forall a. a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | get next element from the stream maybe
getNextMaybe :: (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
getNextMaybe :: forall a. (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
getNextMaybe ASN1 -> Maybe a
f = do
    [ASN1]
list <- ParseASN1 [ASN1]
get
    case [ASN1]
list of
        []    -> Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        (ASN1
h:[ASN1]
l) -> let r :: Maybe a
r = ASN1 -> Maybe a
f ASN1
h
                  in do case Maybe a
r of
                            Maybe a
Nothing -> [ASN1] -> ParseASN1 ()
put [ASN1]
list
                            Just a
_  -> [ASN1] -> ParseASN1 ()
put [ASN1]
l
                        Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
r

-- | get next container of specified type and return all its elements
getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]
getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]
getNextContainer ASN1ConstructionType
ty = do
    [ASN1]
list <- ParseASN1 [ASN1]
get
    case [ASN1]
list of
        []                    -> String -> ParseASN1 [ASN1]
forall a. String -> ParseASN1 a
throwParseError String
"empty"
        (ASN1
h:[ASN1]
l) | ASN1
h ASN1 -> ASN1 -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
ty -> do let ([ASN1]
l1, [ASN1]
l2) = Int -> [ASN1] -> ([ASN1], [ASN1])
getConstructedEnd Int
0 [ASN1]
l
                                    [ASN1] -> ParseASN1 ()
put [ASN1]
l2 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 (m :: * -> *) a. Monad m => a -> m a
return [ASN1]
l1
              | Bool
otherwise     -> String -> ParseASN1 [ASN1]
forall a. String -> ParseASN1 a
throwParseError String
"not an expected container"


-- | run a function of the next elements of a container of specified type
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 (m :: * -> *) a. Monad m => a -> m a
return (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

-- | just like getNextContainer, except it doesn't throw an error if the container doesn't exists.
getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
getNextContainerMaybe ASN1ConstructionType
ty = do
    [ASN1]
list <- ParseASN1 [ASN1]
get
    case [ASN1]
list of
        []                    -> Maybe [ASN1] -> ParseASN1 (Maybe [ASN1])
forall a. a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [ASN1]
forall a. Maybe a
Nothing
        (ASN1
h:[ASN1]
l) | ASN1
h ASN1 -> ASN1 -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
ty -> do let ([ASN1]
l1, [ASN1]
l2) = Int -> [ASN1] -> ([ASN1], [ASN1])
getConstructedEnd Int
0 [ASN1]
l
                                    [ASN1] -> ParseASN1 ()
put [ASN1]
l2 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 (m :: * -> *) a. Monad m => a -> m a
return ([ASN1] -> Maybe [ASN1]
forall a. a -> Maybe a
Just [ASN1]
l1)
              | Bool
otherwise     -> Maybe [ASN1] -> ParseASN1 (Maybe [ASN1])
forall a. a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [ASN1]
forall a. Maybe a
Nothing

-- | just like onNextContainer, except it doesn't throw an error if the container doesn't exists.
onNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe :: forall a.
ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
onNextContainerMaybe ASN1ConstructionType
ty ParseASN1 a
f = do
    Maybe [ASN1]
n <- ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
getNextContainerMaybe ASN1ConstructionType
ty
    case Maybe [ASN1]
n of
        Just [ASN1]
l  -> (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 (m :: * -> *) a. Monad m => a -> m a
return (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]
l
        Maybe [ASN1]
Nothing -> Maybe a -> ParseASN1 (Maybe a)
forall a. a -> ParseASN1 a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- | returns if there's more elements in the stream.
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