gpmf (empty) → 0.1.1.0
raw patch · 10 files changed
+688/−0 lines, 10 filesdep +HUnitdep +attoparsecdep +attoparsec-binarysetup-changed
Dependencies added: HUnit, attoparsec, attoparsec-binary, base, binary, bytestring, containers, data-binary-ieee754, gpmf, lens, mtl, tasty, tasty-golden, tasty-hunit, tasty-quickcheck, time, transformers
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +11/−0
- Setup.hs +2/−0
- app/Main.hs +14/−0
- gpmf.cabal +112/−0
- src/GoPro/Command/DEVCString.hs +64/−0
- src/GoPro/DEVC.hs +260/−0
- src/GoPro/GPMF.hs +168/−0
- test/Spec.hs +22/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for gpmf++## 0.1.0.3++Added IsString instance of FourCC to simplify specifying stuff.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dustin Sallings (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Dustin Sallings nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,11 @@+# gopro metadata parser for haskell++Recent GoPro cameras record a telemetry stream along with video that+contains quite a rich selection of data.++This library parses that stream and provides low level access to that+data (as well as some high level access to come common/tedious+parts). [GoPro's own project][gpmfdocs] documents the format and+features therein.++[gpmfdocs]: https://github.com/gopro/gpmf-parser
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,14 @@+module Main where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import System.Environment (getArgs)++import GoPro.Command.DEVCString+import GoPro.DEVC+import GoPro.GPMF++main :: IO ()+main = do+ [fn] <- getArgs+ either print (mapM_ (BL.putStrLn . maybe "" showDEVC . uncurry mkDEVC)) . parseGPMF =<< BS.readFile fn
+ gpmf.cabal view
@@ -0,0 +1,112 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.6.+--+-- see: https://github.com/sol/hpack+--+-- hash: 3eb43a91591e1cad779c5b5bde8ee5614825a5b5379a0d7951dadc0795f02024++name: gpmf+version: 0.1.1.0+description: Please see the README on GitHub at <https://github.com/dustin/gpmf#readme>+homepage: https://github.com/dustin/gpmf#readme+bug-reports: https://github.com/dustin/gpmf/issues+author: Dustin Sallings+maintainer: dustin@spy.net+copyright: MIT+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/dustin/gpmf++library+ exposed-modules:+ GoPro.Command.DEVCString+ GoPro.DEVC+ GoPro.GPMF+ other-modules:+ Paths_gpmf+ hs-source-dirs:+ src+ default-extensions:+ OverloadedStrings+ RecordWildCards+ NamedFieldPuns+ ghc-options: -Wall+ build-depends:+ attoparsec+ , attoparsec-binary >=0.2 && <1.0+ , base >=4.7 && <5+ , binary+ , bytestring+ , containers+ , data-binary-ieee754+ , lens+ , mtl+ , time+ , transformers+ default-language: Haskell2010++executable gpmf+ main-is: Main.hs+ other-modules:+ Paths_gpmf+ hs-source-dirs:+ app+ default-extensions:+ OverloadedStrings+ RecordWildCards+ NamedFieldPuns+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ attoparsec+ , attoparsec-binary >=0.2 && <1.0+ , base >=4.7 && <5+ , binary+ , bytestring+ , containers+ , data-binary-ieee754+ , gpmf+ , lens+ , mtl+ , time+ , transformers+ default-language: Haskell2010++test-suite gpmf-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_gpmf+ hs-source-dirs:+ test+ default-extensions:+ OverloadedStrings+ RecordWildCards+ NamedFieldPuns+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , attoparsec+ , attoparsec-binary >=0.2 && <1.0+ , base >=4.7 && <5+ , binary+ , bytestring+ , containers+ , data-binary-ieee754+ , gpmf+ , lens+ , mtl+ , tasty+ , tasty-golden+ , tasty-hunit+ , tasty-quickcheck+ , time+ , transformers+ default-language: Haskell2010
+ src/GoPro/Command/DEVCString.hs view
@@ -0,0 +1,64 @@+module GoPro.Command.DEVCString where++import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BC+import qualified Data.Map.Strict as Map+import Data.Foldable (toList)++import GoPro.DEVC+import GoPro.GPMF++fourcc :: FourCC -> BL.ByteString+fourcc (FourCC (a,b,c,d)) = "4cc:" <> BC.pack [a,b,c,d]++cval :: Value -> BL.ByteString+cval (GFourCC f) = fourcc f+cval x = tshow x++showValues :: Int -> [Value] -> BL.ByteString+showValues n = joinMap showValue+ where+ showValue (GNested x) = showTelemetry (n + 2) x+ showValue (GFourCC f) = (BC.pack $ replicate n ' ') <> fourcc f+ showValue (GComplex f v) = (BC.pack $ replicate n ' ') <> "Complex: " <> BC.pack f <> ": " <> BL.intercalate ", " (map cval v)+ showValue x = (BC.pack $ replicate n ' ') <> tshow x++showTelemetry :: Int -> (FourCC, [Value]) -> BL.ByteString+showTelemetry n (FourCC (a,b,c,d),vs) = (BC.pack $ (replicate n ' ') <> [a,b,c,d]) <> "\n" <> showValues (n+2) vs++tshow :: Show a => a -> BL.ByteString+tshow = BC.pack . show++joinMap :: Foldable f => (a -> BL.ByteString) -> f a -> BL.ByteString+joinMap f = BL.intercalate "\n" . fmap f . toList++showDEVC :: DEVC -> BL.ByteString+showDEVC DEVC{..} = "Device " <> tshow _dev_id <> ": " <> BC.pack _dev_name <> "\n" <> joinMap showT _dev_telems++ where+ showT Telemetry{..} = " " <> BC.pack _tele_name <> " - stmp:" <> tshow _tele_stmp <> " tsmp:" <> tshow _tele_tsmp <> "\n" <> showTVal _tele_values++ showTVal (TVUnknown vals) = " Unknown type\n" <> showValues 6 vals+ showTVal (TVAccl Accelerometer{..}) = " Temp: " <> tshow _acc_temp <> " and "+ <> tshow (length _acc_vals) <> " values like " <> (tshow.head) _acc_vals+ showTVal (TVGyro Gyroscope{..}) = " Temp: " <> tshow _gyro_temp <> " and "+ <> tshow (length _gyro_vals) <> " values like " <> (tshow.head) _gyro_vals+ showTVal (TVFaces fs) = " Faces:" <> (if null fs then "" else "\n") <>+ joinMap ((\Face{..} -> " "+ <> tshow _face_x <> "x" <> tshow _face_y+ <> ", " <> tshow _face_w <> "x" <> tshow _face_h+ <> ", smile=" <> tshow _face_smile)) fs+ showTVal (TVGPS GPS{..}) = " GPS time=" <> tshow _gps_time <> " p=" <> tshow _gps_p+ <> ", len(rs)=" <> tshow (length _gps_readings)+ <> "\n hd=" <> showGPS (head _gps_readings)+ showTVal (TVScene ss) = " Scenes, found " <> tshow (length ss) <> ", first:\n" <>+ joinMap ((\(k,v) ->+ " " <> tshow k <> "=" <> tshow v))+ (Map.assocs (head ss))+ showTVal (TVAudioLevel AudioLevel{..}) = " Audio levels:\n" <>+ " rms: " <> (tshow _audio_rms) <> "\n" <>+ " peak: " <> (tshow _audio_peak)++showGPS :: GPSReading -> BL.ByteString+showGPS GPSReading{..} = "(" <> tshow _gpsr_lat <> "," <> tshow _gpsr_lon <> ") alt=" <> tshow _gpsr_alt+ <> " spd2d=" <> tshow _gpsr_speed2d <> " spd3d=" <> tshow _gpsr_speed3d
+ src/GoPro/DEVC.hs view
@@ -0,0 +1,260 @@+{-|+Module: GoPro.DEVC+Description: Higher level representation of GPMF DEVC data.+Copyright: (c) Dustin Sallings, 2020+License: BSD3+Maintanier: dustin@spy.net+Stability: experimental++DEVC is one of the GPMF data types that contains the bulk of+interesting telemetry data from within GPMF streams. This module+doesn't currently provide high level access to *all* DEVC data (some+of it remains low level), but it currently has useful representations+of things that seemed interesting to the author.+-}++{-# LANGUAGE TemplateHaskell #-}++module GoPro.DEVC (+ mkDEVC,+ DEVC(..), dev_id, dev_name, dev_telems,+ Accelerometer(..), acc_temp, acc_vals,+ Gyroscope(..), gyro_temp, gyro_vals,+ Face(..), face_id, face_x, face_y, face_w, face_h, face_smile,+ GPSReading(..), gpsr_lat, gpsr_lon, gpsr_alt, gpsr_speed2d, gpsr_speed3d,+ GPS(..), gps_p, gps_time, gps_readings,+ AudioLevel(..), audio_rms, audio_peak,+ Location(..), _Snow, _Urban, _Indoor, _Water, _Vegetation, _Beach,+ TVals(..), _TVUnknown, _TVAccl, _TVGyro, _TVFaces, _TVGPS, _TVAudioLevel, _TVScene,+ Telemetry(..), tele_stmp, tele_tsmp, tele_name, tele_values+ ) where++import Control.Lens hiding (cons)+import Control.Monad (guard)+import Data.Foldable (fold)+import Data.List (transpose)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Time.Clock (UTCTime (..))+import Data.Word (Word64)++import GoPro.GPMF++data Accelerometer = Accelerometer+ { _acc_temp :: Float+ , _acc_vals :: [(Float, Float, Float)]+ }+ deriving Show++makeLenses ''Accelerometer++data Gyroscope = Gyroscope+ { _gyro_temp :: Float+ , _gyro_vals :: [(Float, Float, Float)]+ }+ deriving Show++makeLenses ''Gyroscope++data Face = Face+ { _face_id :: Int+ , _face_x :: Float+ , _face_y :: Float+ , _face_w :: Float+ , _face_h :: Float+ , _face_smile :: Float+ }+ deriving Show++makeLenses ''Face++data GPSReading = GPSReading+ { _gpsr_lat :: Double+ , _gpsr_lon :: Double+ , _gpsr_alt :: Double+ , _gpsr_speed2d :: Double+ , _gpsr_speed3d :: Double+ }+ deriving Show++makeLenses ''GPSReading++data GPS = GPS+ { _gps_p :: Int+ , _gps_time :: UTCTime+ , _gps_readings :: [GPSReading]+ }+ deriving Show++makeLenses ''GPS++data AudioLevel = AudioLevel+ { _audio_rms :: [Int]+ , _audio_peak :: [Int]+ }+ deriving Show++makeLenses ''AudioLevel++data Location = Snow+ | Urban+ | Indoor+ | Water+ | Vegetation+ | Beach+ deriving (Show, Read, Eq, Ord)++makePrisms ''Location++data TVals = TVUnknown [Value]+ | TVAccl Accelerometer+ | TVGyro Gyroscope+ | TVFaces [Face]+ | TVGPS GPS+ | TVAudioLevel AudioLevel+ | TVScene [Map Location Float]+ deriving Show++makePrisms ''TVals++data Telemetry = Telemetry+ { _tele_stmp :: Word64+ , _tele_tsmp :: Int+ , _tele_name :: String+ , _tele_values :: TVals+ }+ deriving Show++makeLenses ''Telemetry++data DEVC = DEVC+ { _dev_id :: Int+ , _dev_name :: String+ , _dev_telems :: Map String Telemetry+ }+ deriving Show++makeLenses ''DEVC++-- | Given a FourCC value (specifically, DEVC) and a list of Values,+-- produce a DEVC value.+mkDEVC :: FourCC -> [Value] -> Maybe DEVC+mkDEVC "DEVC" = Just . foldr addItem (DEVC 0 "" mempty)+ where+ addItem (GNested ("DVID", [GUint32 [x]])) o = o {_dev_id=fromIntegral x}+ addItem (GNested ("DVNM", [GString x])) o = o {_dev_name=x}+ addItem (GNested ("STRM", vals)) o@(DEVC{..}) = o {_dev_telems=addTelem _dev_telems vals}+ addItem _ o = o++ addTelem m vals = let t = foldr updTele (Telemetry 0 0 "" tvals) vals in+ Map.insert (_tele_name t) t m+ where+ updTele (GNested ("STMP", [GUint64 [x]])) o = o {_tele_stmp = x}+ updTele (GNested ("TSMP", [GUint32 [x]])) o = o {_tele_tsmp = fromIntegral x}+ updTele (GNested ("STNM", [GString x])) o = o {_tele_name = x}+ updTele _ o = o++ tvals :: TVals+ tvals = (fromMaybe (TVUnknown vals) . ($ vals)) . foldr findGrokker (const Nothing) . concatMap four $ vals+ where+ four (GNested (x, _)) = [x]+ four _ = []++ findGrokker "ACCL" _ = fmap TVAccl . grokAccl+ findGrokker "GYRO" _ = fmap TVGyro . grokGyro+ findGrokker "FACE" _ = fmap TVFaces . grokFaces+ findGrokker "GPS5" _ = fmap TVGPS . grokGPS+ findGrokker "AALP" _ = fmap TVAudioLevel . grokAudioLevel+ findGrokker "SCEN" _ = fmap TVScene . grokScene+ findGrokker _ o = o++mkDEVC _ = const Nothing++findVal :: FourCC -> [Value] -> Maybe [Value]+findVal f = listToMaybe . findAll f++findAll :: FourCC -> [Value] -> [[Value]]+findAll f = mapMaybe g+ where+ g (GNested (fc, vs)) | fc == f = Just vs+ g _ = Nothing++grokSens :: FourCC -> (Float -> [(Float, Float, Float)] -> a) -> [Value] -> Maybe a+grokSens sens cons vals = do+ GFloat templ <- listToMaybe =<< findVal "TMPC" vals+ GInt16 scall <- listToMaybe =<< findVal "SCAL" vals+ readings <- mapMaybe ungint <$> findVal sens vals++ temp <- listToMaybe templ+ scal <- realToFrac <$> listToMaybe scall+ scaled <- traverse (trip . fmap (\x -> realToFrac x / scal)) readings++ pure $ cons temp scaled++ where ungint (GInt16 xs) = Just xs+ ungint _ = Nothing+ trip [a,b,c] = Just (a,b,c)+ trip _ = Nothing++grokAccl :: [Value] -> Maybe Accelerometer+grokAccl = grokSens "ACCL" Accelerometer++grokGyro :: [Value] -> Maybe Gyroscope+grokGyro = grokSens "GYRO" Gyroscope++grokFaces :: [Value] -> Maybe [Face]+grokFaces = Just . mapMaybe mkFace . findAll "FACE"+ where+ mkFace :: [Value] -> Maybe Face+ mkFace [GComplex "Lffffff" [GUint32 [fid], GFloat [x], GFloat [y], GFloat [w], GFloat [h], _, GFloat [s]]] =+ Just (Face (fromIntegral fid) x y w h s)+ mkFace [GComplex "Lffff" [GUint32 [fid], GFloat [x], GFloat [y], GFloat [w], GFloat [h]]] =+ Just (Face (fromIntegral fid) x y w h 0)+ mkFace _ = Nothing++grokGPS :: [Value] -> Maybe GPS+grokGPS vals = do+ GUint16 [gpsp] <- listToMaybe =<< findVal "GPSP" vals+ GTimestamp time <- listToMaybe =<< findVal "GPSU" vals+ scals <- fmap (\(GInt32 [x]) -> realToFrac x) <$> findVal "SCAL" vals+ g5s <- findVal "GPS5" vals+ rs <- mconcat <$> traverse (readings scals) g5s++ pure $ GPS (fromIntegral gpsp) time rs++ where+ readings scals (GInt32 ns) = case zipWith (\s n -> realToFrac n / s) scals ns of+ [_gpsr_lat,_gpsr_lon,_gpsr_alt,_gpsr_speed2d,_gpsr_speed3d]+ -> Just [GPSReading{..}]+ _ -> Nothing+ readings _ _ = Nothing++grokAudioLevel :: [Value] -> Maybe AudioLevel+grokAudioLevel vals = do+ alps <- transpose . mapMaybe de <$> findVal "AALP" vals+ guard $ length alps == 2+ pure $ AudioLevel (alps !! 0) (alps !! 1)++ where de (GInt8 xs) = Just $ fmap fromIntegral xs+ de (GComplex _ xs) = Just . fold . mapMaybe de $ xs+ de _ = Nothing++grokScene :: [Value] -> Maybe [Map Location Float]+grokScene = Just . fmap mkScene . findAll "SCEN"+ where+ mkScene :: [Value] -> Map Location Float+ mkScene = Map.fromList . mapMaybe mkOne++ mkOne :: Value -> Maybe (Location, Float)+ mkOne (GComplex "Ff" [GFourCC f, GFloat [p]]) = l f >>= \x -> Just (x, p)+ mkOne _ = Nothing++ l :: FourCC -> Maybe Location+ l "SNOW" = Just Snow+ l "URBA" = Just Urban+ l "INDO" = Just Indoor+ l "WATR" = Just Water+ l "VEGE" = Just Vegetation+ l "BEAC" = Just Beach+ l _ = Nothing
+ src/GoPro/GPMF.hs view
@@ -0,0 +1,168 @@+{-|+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 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 (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)+{-+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 (Show, Eq)++instance IsString FourCC where+ fromString [a,b,c,d] = FourCC (a,b,c,d)+ fromString _ = error "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 (Show)++type Parser = StateT String A.Parser++anyInt8 :: A.Parser Int8+anyInt8 = fromIntegral <$> 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 = A.parseOnly (evalStateT (A.many1 parseNested) "")++parseNested :: Parser (FourCC, [Value])+parseNested = do+ fourcc <- lift parseFourCC+ t <- lift AC.anyChar+ ss <- fromIntegral <$> lift A.anyWord8+ rpt <- fromIntegral <$> lift anyWord16be+ let padding = (4 - (fromIntegral ss * rpt) `mod` 4) `mod` 4++ stuffs <- parseValue t ss rpt++ case (fourcc, stuffs) of+ ("TYPE", [GString x]) -> put x+ _ -> pure ()++ _ <- lift $ replicateM padding A.anyWord8+ pure (fourcc, stuffs)++parseString :: Int -> A.Parser Value+parseString l = GString . reverse . dropWhile (== '\0') . reverse <$> replicateM l AC.anyChar++parseFloat :: A.Parser Float+parseFloat = runGet getFloat32be . BL.fromStrict <$> A.take 4++replicatedParser :: Int -> Int -> Int -> A.Parser a -> ([a] -> Value) -> Parser [Value]+replicatedParser 0 l rpt _ _ = lift $ replicateM (l*rpt) A.anyWord8 >> pure []+replicatedParser one l rpt p cons =+ fmap cons <$> lift (replicateM rpt (replicateM (l `div` one) p))++parseTimestamp :: A.Parser UTCTime+parseTimestamp = parseTimeM False defaultTimeLocale "%y%m%d%H%M%S%Q" =<< replicateM 16 AC.anyChar++singleParser :: Char -> (Int, A.Parser Value)+singleParser 'F' = (4, GFourCC <$> parseFourCC)+singleParser 'f' = (4, GFloat . (:[]) <$> parseFloat)+singleParser 'L' = (4, GUint32 . (:[]) <$> anyWord32be)+singleParser 'B' = (1, GUint8 . (:[]) <$> A.anyWord8)+singleParser 'b' = (1, GInt8 . (:[]) <$> anyInt8)+singleParser 'S' = (1, GUint16 . (:[]) <$> anyWord16be)+singleParser 's' = (1, GUint16 . (:[]) . fromIntegral <$> anyWord16be)+singleParser x = error ("unsupported parser: " <> show x)++parseComplex :: Int -> Int -> Parser [Value]+parseComplex l rpt = do+ fmt <- get+ let sz = foldr (\x o -> (fst . singleParser) x + o) 0 fmt+ let parsers = traverse (snd . singleParser) fmt+ replicatedParser sz l rpt parsers (GComplex fmt . mconcat)++parseValue :: Char -> Int -> Int -> Parser [Value]+parseValue '\0' l rpt = do+ inp <- lift $ A.take (l * rpt)+ t <- get+ fmap GNested <$> either fail pure (A.parseOnly (evalStateT (A.many1 parseNested) t) inp)+parseValue 'F' 4 rpt = lift $ replicateM rpt (GFourCC <$> parseFourCC)+parseValue 'L' l rpt = replicatedParser 4 l rpt anyWord32be GUint32+parseValue 'l' l rpt = replicatedParser 4 l rpt (fromIntegral <$> anyWord32be) GInt32+parseValue 'c' l rpt = (:[]) <$> (lift . parseString $ (l * rpt))+parseValue 's' l rpt = replicatedParser 2 l rpt (fromIntegral <$> anyWord16be) GInt16+parseValue 'S' l rpt = replicatedParser 2 l rpt anyWord16be GUint16+parseValue 'J' l rpt = replicatedParser 8 l rpt anyWord64be GUint64+parseValue 'f' l rpt = replicatedParser 4 l rpt parseFloat GFloat+parseValue 'b' l rpt = lift $ replicateM rpt (GInt8 <$> replicateM l anyInt8)+parseValue 'B' l rpt = lift $ replicateM rpt (GUint8 <$> replicateM l A.anyWord8)+parseValue 'U' 16 1 = (:[]) . GTimestamp <$> lift parseTimestamp+parseValue '?' l rpt = parseComplex l rpt+parseValue x l rpt = do+ u <- lift $ replicateM rpt (replicateM l A.anyWord8)+ pure [GUnknown (x, l, rpt, u)]++parseFourCC :: A.Parser FourCC+parseFourCC = do+ a <- AC.anyChar+ b <- AC.anyChar+ c <- AC.anyChar+ d <- AC.anyChar+ pure $ FourCC (a,b,c,d)+
+ test/Spec.hs view
@@ -0,0 +1,22 @@+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BC+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC++import GoPro.Command.DEVCString+import GoPro.DEVC+import GoPro.GPMF+++tests :: [TestTree]+tests = map one ["basement", "grass", "hero6", "walking"]+ where diff ref new = ["diff", "-u", ref, new]+ go p = either BC.pack (foldMap ((<>"\n") . maybe "XXX" showDEVC . uncurry mkDEVC)) . parseGPMF <$> BS.readFile p+ one :: String -> TestTree+ one x = goldenVsStringDiff x diff ("test/" <> x <> ".golden" ) $ go ("samples/" <> x <> ".gpmf")++main :: IO ()+main = defaultMain $ testGroup "All Tests" tests