-- |
-- 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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[ASN1]
s -> 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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[ASN1]
s ->
        case forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 (a -> b)
mf [ASN1]
s of
            Left String
err      -> forall a b. a -> Either a b
Left String
err
            Right (a -> b
f, [ASN1]
s2) ->
                case forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
ma [ASN1]
s2 of
                    Left String
err      -> forall a b. a -> Either a b
Left String
err
                    Right (a
a, [ASN1]
s3) -> 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    = 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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[ASN1]
s ->
        case forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m1 [ASN1]
s of
            Left String
err      -> forall a b. a -> Either a b
Left String
err
            Right (a
a, [ASN1]
s2) -> 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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[ASN1]
s ->
        case forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m1 [ASN1]
s of
            Left String
_        -> forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
m2 [ASN1]
s
            Right (a
a, [ASN1]
s2) -> 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 = forall a. String -> ParseASN1 a
throwParseError
#endif

get :: ParseASN1 [ASN1]
get :: ParseASN1 [ASN1]
get = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[ASN1]
stream -> forall a b. b -> Either a b
Right ([ASN1]
stream, [ASN1]
stream)

put :: [ASN1] -> ParseASN1 ()
put :: [ASN1] -> ParseASN1 ()
put [ASN1]
stream = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[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 = forall a. ([ASN1] -> Either String (a, [ASN1])) -> ParseASN1 a
P forall a b. (a -> b) -> a -> b
$ \[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 = 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 forall a. ParseASN1 a -> [ASN1] -> Either String (a, [ASN1])
runP ParseASN1 a
f [ASN1]
s of
        Left String
err      -> forall a b. a -> Either a b
Left String
err
        Right (a
o, []) -> forall a b. b -> Either a b
Right a
o
        Right (a
_, [ASN1]
er) -> forall a b. a -> Either a b
Left (String
"runParseASN1: remaining state " forall a. [a] -> [a] -> [a]
++ 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 forall a. ASN1Object a => [ASN1] -> Either String (a, [ASN1])
fromASN1 [ASN1]
l of
        Left String
err     -> forall a. String -> ParseASN1 a
throwParseError String
err
        Right (a
a,[ASN1]
l2) -> [ASN1] -> ParseASN1 ()
put [ASN1]
l2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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
        []    -> forall a. String -> ParseASN1 a
throwParseError String
"empty"
        (ASN1
h:[ASN1]
l) -> [ASN1] -> ParseASN1 ()
put [ASN1]
l forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) ParseASN1 a
getOne (forall a. ParseASN1 a -> ParseASN1 [a]
getMany ParseASN1 a
getOne)
        else 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
        []    -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
                        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
        []                    -> forall a. String -> ParseASN1 a
throwParseError String
"empty"
        (ASN1
h:[ASN1]
l) | ASN1
h 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [ASN1]
l1
              | Bool
otherwise     -> 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 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 a. String -> ParseASN1 a
throwParseError forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
        []                    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        (ASN1
h:[ASN1]
l) | ASN1
h 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 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]
l1)
              | Bool
otherwise     -> forall (m :: * -> *) a. Monad m => a -> m a
return 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  -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> ParseASN1 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 a. ParseASN1 a -> [ASN1] -> Either String a
runParseASN1 ParseASN1 a
f [ASN1]
l
        Maybe [ASN1]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | returns if there's more elements in the stream.
hasNext :: ParseASN1 Bool
hasNext :: ParseASN1 Bool
hasNext = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseASN1 [ASN1]
get