-- |
-- Module      : Crypto.Store.ASN1.Parse
-- License     : BSD-style
-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- Parser combinators for ASN.1 stream.  Similar to "Data.ASN1.Parse" but
-- with the following additions:
--
-- * Parsed stream is annotated, i.e. parser input is @('ASN1', e)@ instead of
--   @'ASN1'@.  Main motivation is to allow to parse a sequence of 'ASN1Repr'
--   and hold the exact binary content that has been parsed.  As consequence,
--   no @getObject@ function is provided.  Function 'withAnnotations' runs
--   a parser and returns all annotations consumed in a monoid concatenation.
--
-- * The parser implements 'Alternative' and 'MonadPlus'.
--
-- * The 'fail' function returns a parse error so that pattern matching makes
--   monadic parsing code easier to write.
{-# LANGUAGE CPP #-}
module Crypto.Store.ASN1.Parse
    ( ParseASN1
    -- * run
    , runParseASN1State
    , runParseASN1State_
    , runParseASN1
    , runParseASN1_
    , throwParseError
    -- * combinators
    , 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

-- | ASN1 parse monad
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)

-- | throw a parse error
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

-- | 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]
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)

-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream.
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')

-- | 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 = 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)

-- | 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_ :: 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))

-- | get next element from the stream
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

-- | get many elements until there's nothing left
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 []

-- | get next element from the stream maybe
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

-- | get next container of specified type and return all its elements
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"


-- | run a function of the next elements of a container of specified type
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

-- | just like getNextContainer, except it doesn't throw an error if the container doesn't exists.
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

-- | just like onNextContainer, except it doesn't throw an error if the container doesn't exists.
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

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

-- | run a parser and return its result as well as all annotations that were used
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)