1-- |
2-- Module      : Data.ASN1.Parse
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8-- A parser combinator for ASN1 Stream.
9{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE CPP #-}
11module Data.ASN1.Parse
12    ( ParseASN1
13    -- * run
14    , runParseASN1State
15    , runParseASN1
16    , throwParseError
17    -- * combinators
18    , onNextContainer
19    , onNextContainerMaybe
20    , getNextContainer
21    , getNextContainerMaybe
22    , getNext
23    , getNextMaybe
24    , hasNext
25    , getObject
26    , getMany
27    ) where
28
29import Data.ASN1.Types
30import Data.ASN1.Stream
31import Control.Applicative
32import Control.Arrow (first)
33import Control.Monad (liftM2)
34#if MIN_VERSION_base(4,9,0)
35import Control.Monad.Fail
36#endif
37
38newtype ParseASN1 a = P { runP :: [ASN1] -> Either String (a, [ASN1]) }
39
40instance Functor ParseASN1 where
41    fmap f m = P (either Left (Right . first f) . runP m)
42instance Applicative ParseASN1 where
43    pure a = P $ \s -> Right (a, s)
44    (<*>) mf ma = P $ \s ->
45        case runP mf s of
46            Left err      -> Left err
47            Right (f, s2) ->
48                case runP ma s2 of
49                    Left err      -> Left err
50                    Right (a, s3) -> Right (f a, s3)
51instance Monad ParseASN1 where
52    return a    = pure a
53    (>>=) m1 m2 = P $ \s ->
54        case runP m1 s of
55            Left err      -> Left err
56            Right (a, s2) -> runP (m2 a) s2
57instance Alternative ParseASN1 where
58    empty = P $ \_ -> Left "empty Alternative"
59    (<|>) m1 m2 = P $ \s ->
60        case runP m1 s of
61            Left _        -> runP m2 s
62            Right (a, s2) -> Right (a, s2)
63#if MIN_VERSION_base(4,9,0)
64instance MonadFail ParseASN1 where
65    fail = throwParseError
66#endif
67
68get :: ParseASN1 [ASN1]
69get = P $ \stream -> Right (stream, stream)
70
71put :: [ASN1] -> ParseASN1 ()
72put stream = P $ \_ -> Right ((), stream)
73
74-- | throw a parse error
75throwParseError :: String -> ParseASN1 a
76throwParseError s = P $ \_ -> Left s
77
78-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream.
79runParseASN1State :: ParseASN1 a -> [ASN1] -> Either String (a,[ASN1])
80runParseASN1State f s = runP f s
81
82-- | run the parse monad over a stream and returns the result.
83--
84-- If there's still some asn1 object in the state after calling f,
85-- an error will be raised.
86runParseASN1 :: ParseASN1 a -> [ASN1] -> Either String a
87runParseASN1 f s =
88    case runP f s of
89        Left err      -> Left err
90        Right (o, []) -> Right o
91        Right (_, er) -> Left ("runParseASN1: remaining state " ++ show er)
92
93-- | get next object
94getObject :: ASN1Object a => ParseASN1 a
95getObject = do
96    l <- get
97    case fromASN1 l of
98        Left err     -> throwParseError err
99        Right (a,l2) -> put l2 >> return a
100
101-- | get next element from the stream
102getNext :: ParseASN1 ASN1
103getNext = do
104    list <- get
105    case list of
106        []    -> throwParseError "empty"
107        (h:l) -> put l >> return h
108
109-- | get many elements until there's nothing left
110getMany :: ParseASN1 a -> ParseASN1 [a]
111getMany getOne = do
112    next <- hasNext
113    if next
114        then liftM2 (:) getOne (getMany getOne)
115        else return []
116
117-- | get next element from the stream maybe
118getNextMaybe :: (ASN1 -> Maybe a) -> ParseASN1 (Maybe a)
119getNextMaybe f = do
120    list <- get
121    case list of
122        []    -> return Nothing
123        (h:l) -> let r = f h
124                  in do case r of
125                            Nothing -> put list
126                            Just _  -> put l
127                        return r
128
129-- | get next container of specified type and return all its elements
130getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]
131getNextContainer ty = do
132    list <- get
133    case list of
134        []                    -> throwParseError "empty"
135        (h:l) | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 l
136                                    put l2 >> return l1
137              | otherwise     -> throwParseError "not an expected container"
138
139
140-- | run a function of the next elements of a container of specified type
141onNextContainer :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a
142onNextContainer ty f = getNextContainer ty >>= either throwParseError return . runParseASN1 f
143
144-- | just like getNextContainer, except it doesn't throw an error if the container doesn't exists.
145getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])
146getNextContainerMaybe ty = do
147    list <- get
148    case list of
149        []                    -> return Nothing
150        (h:l) | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 l
151                                    put l2 >> return (Just l1)
152              | otherwise     -> return Nothing
153
154-- | just like onNextContainer, except it doesn't throw an error if the container doesn't exists.
155onNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)
156onNextContainerMaybe ty f = do
157    n <- getNextContainerMaybe ty
158    case n of
159        Just l  -> either throwParseError (return . Just) $ runParseASN1 f l
160        Nothing -> return Nothing
161
162-- | returns if there's more elements in the stream.
163hasNext :: ParseASN1 Bool
164hasNext = not . null <$> get
165