{-# 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)
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
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)