diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for gpmf + +## 0.1.0.3 + +Added IsString instance of FourCC to simplify specifying stuff. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/gpmf.cabal b/gpmf.cabal new file mode 100644 --- /dev/null +++ b/gpmf.cabal @@ -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 +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 diff --git a/src/GoPro/Command/DEVCString.hs b/src/GoPro/Command/DEVCString.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/Command/DEVCString.hs @@ -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 diff --git a/src/GoPro/DEVC.hs b/src/GoPro/DEVC.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/DEVC.hs @@ -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 diff --git a/src/GoPro/GPMF.hs b/src/GoPro/GPMF.hs new file mode 100644 --- /dev/null +++ b/src/GoPro/GPMF.hs @@ -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 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) + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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