{-|
Module: GoPro.GPMF
Description: Parser for GoPro GPMF telemetry data.
Copyright: (c) Dustin Sallings, 2020
License: BSD3
Maintanier: dustin@spy.net
Stability: experimental

A low-level parser for <https://github.com/gopro/gpmf-parser GPMF> telemetry data.
-}

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}

module GoPro.GPMF (parseGPMF, Value(..), FourCC(..)) where

import           Control.Monad                    (replicateM)
import           Control.Monad.State              (StateT, evalStateT, get, lift, put)
import           Data.Attoparsec.Binary           (anyWord16be, anyWord32be, anyWord64be)
import qualified Data.Attoparsec.ByteString       as A
import qualified Data.Attoparsec.ByteString.Char8 as AC
import           Data.Binary.Get                  (getInt32be, runGet)
import           Data.Binary.IEEE754              (getFloat32be)
import qualified Data.ByteString                  as BS
import qualified Data.ByteString.Lazy             as BL
import           Data.Int                         (Int16, Int32, Int64, Int8)
import           Data.String                      (IsString (..))
import           Data.Time.Clock                  (UTCTime)
import           Data.Time.Format                 (defaultTimeLocale, parseTimeM)
import           Data.Word                        (Word16, Word32, Word64, Word8)
import           GHC.Generics                     (Generic)

{-
Type Char	Definition	typedef	Comment
b	single byte signed integer	int8_t	-128 to 127
B	single byte unsigned integer	uint8_t	0 to 255
c	single byte 'c' style ASCII character string	char	Optionally NULL terminated - size/repeat sets the length
d	64-bit double precision (IEEE 754)	double
f	32-bit float (IEEE 754)	float
F	32-bit four character key -- FourCC	char fourcc[4]
G	128-bit ID (like UUID)	uint8_t guid[16]
j	64-bit signed unsigned number	int64_t
J	64-bit unsigned unsigned number	uint64_t
l	32-bit signed integer	int32_t
L	32-bit unsigned integer	uint32_t
q	32-bit Q Number Q15.16	uint32_t	16-bit integer (A) with 16-bit fixed point (B) for A.B value (range -32768.0 to 32767.99998)
Q	64-bit Q Number Q31.32	uint64_t	32-bit integer (A) with 32-bit fixed point (B) for A.B value.
s	16-bit signed integer	int16_t	-32768 to 32768
S	16-bit unsigned integer	uint16_t	0 to 65536
U	UTC Date and Time string	char utcdate[16]	Date + UTC Time format yymmddhhmmss.sss - (years 20xx covered)
?	data structure is complex	TYPE	Structure is defined with a preceding TYPE
null	Nested metadata	uint32_t	The data within is GPMF structured KLV data
-}

newtype FourCC = FourCC (Char, Char, Char, Char) deriving (Int -> FourCC -> ShowS
[FourCC] -> ShowS
FourCC -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FourCC] -> ShowS
$cshowList :: [FourCC] -> ShowS
show :: FourCC -> [Char]
$cshow :: FourCC -> [Char]
showsPrec :: Int -> FourCC -> ShowS
$cshowsPrec :: Int -> FourCC -> ShowS
Show, FourCC -> FourCC -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FourCC -> FourCC -> Bool
$c/= :: FourCC -> FourCC -> Bool
== :: FourCC -> FourCC -> Bool
$c== :: FourCC -> FourCC -> Bool
Eq, forall x. Rep FourCC x -> FourCC
forall x. FourCC -> Rep FourCC x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FourCC x -> FourCC
$cfrom :: forall x. FourCC -> Rep FourCC x
Generic)

instance IsString FourCC where
  fromString :: [Char] -> FourCC
fromString [Char
a,Char
b,Char
c,Char
d] = (Char, Char, Char, Char) -> FourCC
FourCC (Char
a,Char
b,Char
c,Char
d)
  fromString [Char]
_         = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid FourCC"

data Value = GInt8 [Int8]
    | GUint8 [Word8]
    | GString String
    | GDouble Double
    | GFloat [Float]
    | GFourCC FourCC
    | GUUID [Word8]
    | GInt64 [Int64]
    | GUint64 [Word64]
    | GInt32 [Int32]
    | GUint32 [Word32]
    | GQ32 [Word32]
    | GQ64 [Word64]
    | GInt16 [Int16]
    | GUint16 [Word16]
    | GTimestamp UTCTime
    | GComplex String [Value]
    | GNested (FourCC, [Value])
    | GUnknown (Char, Int, Int, [[Word8]])
    deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> [Char]
$cshow :: Value -> [Char]
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Value x -> Value
$cfrom :: forall x. Value -> Rep Value x
Generic)

type Parser = StateT String A.Parser

anyInt8 :: A.Parser Int8
anyInt8 :: Parser Int8
anyInt8 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
A.anyWord8

-- | Parse GPMF data from a telemetry stream.  A successful return
-- value contains a list of FourCC tagged value lists.
--
-- Note that the input is the telemetry stream itself, not the
-- container that contains it.
parseGPMF :: BS.ByteString -> Either String [(FourCC, [Value])]
parseGPMF :: ByteString -> Either [Char] [(FourCC, [Value])]
parseGPMF = forall a. Parser a -> ByteString -> Either [Char] a
A.parseOnly (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser (FourCC, [Value])
parseNested) [Char]
"")

parseNested :: Parser (FourCC, [Value])
parseNested :: Parser (FourCC, [Value])
parseNested = do
  FourCC
fourcc <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser FourCC
parseFourCC
  Char
t <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser Char
AC.anyChar
  Int
ss <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser Word8
A.anyWord8
  Int
rpt <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser Word16
anyWord16be
  let padding :: Int
padding = (Int
4 forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ss forall a. Num a => a -> a -> a
* Int
rpt) forall a. Integral a => a -> a -> a
`mod` Int
4) forall a. Integral a => a -> a -> a
`mod` Int
4

  [Value]
stuffs <- Char -> Int -> Int -> Parser [Value]
parseValue Char
t Int
ss Int
rpt

  case (FourCC
fourcc, [Value]
stuffs) of
    (FourCC
"TYPE", [GString [Char]
x]) -> forall s (m :: * -> *). MonadState s m => s -> m ()
put [Char]
x
    (FourCC, [Value])
_                     -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  [Word8]
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
padding Parser Word8
A.anyWord8
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (FourCC
fourcc, [Value]
stuffs)

parseString :: Int -> A.Parser Value
parseString :: Int -> Parser Value
parseString Int
l = [Char] -> Value
GString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'\0') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l Parser Char
AC.anyChar

parseFloat :: A.Parser Float
parseFloat :: Parser Float
parseFloat = forall a. Get a -> ByteString -> a
runGet Get Float
getFloat32be forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
A.take Int
4

parseInt32 :: A.Parser Int32
parseInt32 :: Parser Int32
parseInt32 = forall a. Get a -> ByteString -> a
runGet Get Int32
getInt32be forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
A.take Int
4

replicatedParser :: Int -> Int -> Int -> A.Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser :: forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
0 Int
l Int
rpt Parser a
_ [a] -> Value
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
lforall a. Num a => a -> a -> a
*Int
rpt) Parser Word8
A.anyWord8 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
replicatedParser Int
one Int
l Int
rpt Parser a
p [a] -> Value
cons =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Value
cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rpt (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
l forall a. Integral a => a -> a -> a
`div` Int
one) Parser a
p))

parseTimestamp :: A.Parser UTCTime
parseTimestamp :: Parser UTCTime
parseTimestamp = forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> [Char] -> [Char] -> m t
parseTimeM Bool
False TimeLocale
defaultTimeLocale [Char]
"%y%m%d%H%M%S%Q" forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 Parser Char
AC.anyChar

singleParser :: Char -> (Int, A.Parser Value)
singleParser :: Char -> (Int, Parser Value)
singleParser Char
'F' = (Int
4, FourCC -> Value
GFourCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FourCC
parseFourCC)
singleParser Char
'f' = (Int
4, [Float] -> Value
GFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Float
parseFloat)
singleParser Char
'L' = (Int
4, [Word32] -> Value
GUint32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
anyWord32be)
singleParser Char
'l' = (Int
4, [Int32] -> Value
GInt32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int32
parseInt32)
singleParser Char
'B' = (Int
1, [Word8] -> Value
GUint8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word8
A.anyWord8)
singleParser Char
'b' = (Int
1, [Int8] -> Value
GInt8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int8
anyInt8)
singleParser Char
'S' = (Int
1, [Word16] -> Value
GUint16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
anyWord16be)
singleParser Char
's' = (Int
1, [Word16] -> Value
GUint16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
anyWord16be)
singleParser Char
x   = forall a. HasCallStack => [Char] -> a
error ([Char]
"unsupported parser: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Char
x)

parseComplex :: Int -> Int -> Parser [Value]
parseComplex :: Int -> Int -> Parser [Value]
parseComplex Int
l Int
rpt = do
  [Char]
fmt <- forall s (m :: * -> *). MonadState s m => m s
get
  let sz :: Int
sz = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
x Int
o -> (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> (Int, Parser Value)
singleParser) Char
x forall a. Num a => a -> a -> a
+ Int
o) Int
0 [Char]
fmt
  let parsers :: Parser ByteString [Value]
parsers = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> (Int, Parser Value)
singleParser) [Char]
fmt
  forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
sz Int
l Int
rpt Parser ByteString [Value]
parsers ([Char] -> [Value] -> Value
GComplex [Char]
fmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat)

parseValue :: Char -> Int -> Int -> Parser [Value]
parseValue :: Char -> Int -> Int -> Parser [Value]
parseValue Char
'\0' Int
l Int
rpt = do
  ByteString
inp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Int -> Parser ByteString
A.take (Int
l forall a. Num a => a -> a -> a
* Int
rpt)
  [Char]
t <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FourCC, [Value]) -> Value
GNested forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Parser a -> ByteString -> Either [Char] a
A.parseOnly (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (f :: * -> *) a. Alternative f => f a -> f [a]
A.many1 Parser (FourCC, [Value])
parseNested) [Char]
t) ByteString
inp)
parseValue Char
'F' Int
4 Int
rpt = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rpt (FourCC -> Value
GFourCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser FourCC
parseFourCC)
parseValue Char
'L' Int
l Int
rpt = forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
4 Int
l Int
rpt Parser Word32
anyWord32be [Word32] -> Value
GUint32
parseValue Char
'l' Int
l Int
rpt = forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
4 Int
l Int
rpt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word32
anyWord32be) [Int32] -> Value
GInt32
parseValue Char
'c' Int
l Int
rpt = (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Parser Value
parseString forall a b. (a -> b) -> a -> b
$ (Int
l forall a. Num a => a -> a -> a
* Int
rpt))
parseValue Char
's' Int
l Int
rpt = forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
2 Int
l Int
rpt (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Word16
anyWord16be) [Int16] -> Value
GInt16
parseValue Char
'S' Int
l Int
rpt = forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
2 Int
l Int
rpt Parser Word16
anyWord16be [Word16] -> Value
GUint16
parseValue Char
'J' Int
l Int
rpt = forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
8 Int
l Int
rpt Parser Word64
anyWord64be [Word64] -> Value
GUint64
parseValue Char
'f' Int
l Int
rpt = forall a.
Int -> Int -> Int -> Parser a -> ([a] -> Value) -> Parser [Value]
replicatedParser Int
4 Int
l Int
rpt Parser Float
parseFloat [Float] -> Value
GFloat
parseValue Char
'b' Int
l Int
rpt = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rpt ([Int8] -> Value
GInt8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l Parser Int8
anyInt8)
parseValue Char
'B' Int
l Int
rpt = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rpt ([Word8] -> Value
GUint8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l Parser Word8
A.anyWord8)
parseValue Char
'U' Int
16 Int
1 = (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Value
GTimestamp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Parser UTCTime
parseTimestamp
parseValue Char
'?' Int
l Int
rpt = Int -> Int -> Parser [Value]
parseComplex Int
l Int
rpt
parseValue Char
x Int
l Int
rpt = do
  [[Word8]]
u <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
rpt (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l Parser Word8
A.anyWord8)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Char, Int, Int, [[Word8]]) -> Value
GUnknown (Char
x, Int
l, Int
rpt, [[Word8]]
u)]

parseFourCC :: A.Parser FourCC
parseFourCC :: Parser FourCC
parseFourCC = do
  Char
a <- Parser Char
AC.anyChar
  Char
b <- Parser Char
AC.anyChar
  Char
c <- Parser Char
AC.anyChar
  Char
d <- Parser Char
AC.anyChar
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Char, Char, Char, Char) -> FourCC
FourCC (Char
a,Char
b,Char
c,Char
d)