packages feed

fit (empty) → 0.5

raw patch · 12 files changed

+1276/−0 lines, 12 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bytestring, containers, contravariant, fit, hspec, hspec-attoparsec, mtl, text

Files

+ LICENSE view
@@ -0,0 +1,12 @@+Copyright 2014-2015, Matt Giles+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fit.cabal view
@@ -0,0 +1,68 @@+name:                fit+version:             0.5+license:             BSD3+license-file:        LICENSE+author:              Matt Giles+maintainer:          matt.w.giles@gmail.com+copyright:           2014-2015 Matt Giles+synopsis:            FIT file decoder+description:+ The FIT protocol is used by many sport and fitness devices made by companies+ like Garmin, for example running watches and bike computers. `fit` provides an+ API for parsing these files for analysis or conversion.+ .+ Currently this package is a pretty low-level effort, and you'll need to be familiar+ with FIT to get much value from it. Specifically, the notion of the FIT \"profile\" is+ ignored entirely, so to make use of the decoded file you'll need to reference the+ \"Profile.xls\" spreadsheet in the <http://www.thisisant.com/resources/fit FIT SDK>.+ .+ The "Fit" module exports a convenient set of data types for examining FIT files, as+ well as some lenses for extracting specific data. It's intended that the API in the+ "Fit" module should be sufficient and convenient for most uses, but if you need access+ to the exact structure of the file you can use the data types in "Fit.Internal.FitFile"+ and parsers in "Fit.Internal.Parse".+category:            Data, Parsing, Fitness+stability:           experimental+build-type:          Simple+cabal-version:       >=1.10++bug-reports:         https://github.com/mgiles/fit/issues+source-repository head+  type:              git+  location:          https://github.com/mgiles/fit/++library+  hs-source-dirs:      src+  exposed-modules:     Fit+                     , Fit.Messages+                     , Fit.Messages.Lens+                     , Fit.Internal.Architecture+                     , Fit.Internal.FitFile+                     , Fit.Internal.FitParser+                     , Fit.Internal.Numbers+                     , Fit.Internal.Parse+  ghc-options:         -Wall+  build-depends:       base >=4.7 && <4.8+                     , attoparsec >= 0.10.3+                     , bytestring+                     , text+                     , mtl >= 1.1+                     , containers >= 0.5+                     , contravariant+  default-language:    Haskell2010++test-suite test-fit+  type:              exitcode-stdio-1.0+  main-is:           test/TestFit.hs+  default-language:  Haskell2010+  ghc-options:       -Wall+  build-depends:      base >=4.7 && <4.8+                    , fit+                    , hspec+                    , hspec-attoparsec+                    , QuickCheck+                    , attoparsec+                    , bytestring+                    , text+                    , mtl+                    , containers
+ src/Fit.hs view
@@ -0,0 +1,55 @@+module Fit (+  -- * Messages API+  -- $messages+  readMessages,+  readFileMessages,+  parseMessages,+  Messages(..),+  Message(..),+  Field(..),+  Value(..),+  SingletonValue(..),+  ArrayValue(..),++  -- ** Lenses for the Messages API+  messages,+  message,+  messageNumber,+  fields,+  field,+  fieldNumber,+  fieldValue,+  int,+  real,+  text,+  byte,+  ints,+  reals,+  bytestring+  ) where++import Fit.Messages+import Fit.Messages.Lens++-- $messages+-- A high-level view of a FIT file as a sequence of data messages. This is the+-- recommended API for pulling information out of a FIT file, but if you need+-- access to the exact structure of the file you can use the API in "Fit.Internal.FitFile" and "Fit.Internal.Parse".+--+-- Some basic lenses are also provided for working with the Messages API. These+-- can make it much easier to extract information from a FIT file, especially+-- since you usually know what sort of data you're expecting to find.+--+-- For example, from the FIT global profile we can find that the global message+-- number for 'record' messages is 20, and within a `record` message the 'speed'+-- field has field number 6. The following code gets the `speed` field from all+-- 'record' messages in the file:+--+-- @+-- Right fit <- readFileMessages "file.fit"+-- let speeds = fit ^.. message 20 . field 6 . int+-- -- speeds :: [Int]+-- @+--+-- Note that this package doesn't provide any lens combinators (like @(^..)@),+-- so you'll need to use ones from a lens package.
+ src/Fit/Internal/Architecture.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}++-- | FIT files can contain values encoded with both little-endian and big-endian orderings, and this+-- can vary throughout the file. This module provides some helper types for using parsers+-- with the correct endian-ness during the parse. See the "Fit.Internal.Numbers" and+-- "Fit.Internal.FitParser" modules for example use.+module Fit.Internal.Architecture (+  Arch(..),+  WithArch(..),+  LittleEndian,+  BigEndian,+  withLE,+  withBE+  ) where++import Control.Applicative (Applicative, pure, (<*>))++data Arch = ArchLittle+          | ArchBig+          deriving (Show, Eq)++-- | Tag a value for use in a little- or big-endian context (with 'ArchLittle' and 'ArchBig', respectively)+newtype WithArch (a :: Arch) b = WithArch { unArch :: b }++instance Functor (WithArch a) where+  fmap f (WithArch x) = WithArch (f x)++instance Applicative (WithArch a) where+  pure = WithArch+  (WithArch f) <*> (WithArch x) = WithArch (f x)++-- | Convenience type for values to use in a little-endian context+type LittleEndian a = WithArch ArchLittle a++-- | Convenience type for values to use in a big-endian context+type BigEndian a = WithArch ArchBig a++-- | Alias for 'pure'+withLE :: a -> LittleEndian a+withLE = pure++-- | Alias for 'pure'+withBE :: a -> BigEndian a+withBE = pure
+ src/Fit/Internal/FitFile.hs view
@@ -0,0 +1,198 @@+module Fit.Internal.FitFile (+  Fit(..),+  FitHeader(..),+  Message(..),+  msgLmt,+  MessageDefinition(..),+  FieldDef(..),+  Field(..),+  Value(..),+  Array(..),+  MessageHeader(..),+  LocalMessageType(..),+  mkLocalMessageType,+  unLocalMessageType,+  TimeOffset(..),+  mkTimeOffset,+  Timestamp(..),+  BaseType(..),+  btSize+  ) where++import Fit.Internal.Architecture++import Data.Bits (Bits, (.&.))+import Data.ByteString (ByteString)+import Data.Int (Int8, Int16, Int32)+import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Word (Word8, Word16, Word32)++-- | A FIT file consists of a header and a collection of messages.+data Fit = Fit {+  fHeader :: FitHeader,+  fMessages :: [Message]+  } deriving (Show)++-- | The FIT file header+data FitHeader = FH {+  fhSize            :: !Word8,         -- ^ Size of the header in bytes. Will always be 12 or 14,+                                       -- based on presence of the CRC++  fhProtocolVersion :: !Word8,         -- ^ Protocol version number++  fhProfileVersion  :: !Word16,        -- ^ Profile version number++  fhDataSize        :: !Word32,        -- ^ Combined length of the FIT messages, in bytes++  fhDataType        :: ByteString,     -- ^ File tag, should always be ".FIT"++  fhCrc             :: !(Maybe Word16) -- ^ Optional checksum for header contents+  } deriving (Show)++-- | There are two kinds of FIT messages:+--+--     * __Definition messages__ set the structure for messages of a particular /local message type/+--     * __Data messages__ contain the actual information, according to the structure given by a+--       definition message.+data Message = DefM MessageDefinition+             | DataM !LocalMessageType !Int [Field]+             deriving (Show)++msgLmt :: Message -> LocalMessageType+msgLmt (DefM (MessageDef lmt _ _ _)) = lmt+msgLmt (DataM lmt _ _) = lmt++-- | A @MessageDefinition@ for a local message type (LMT) determines how future data messages with+-- that LMT are decoded. LMTs can be re-used: a data message with LMT @n@ will use the /most recent/+-- message definition for LMT @n@.+data MessageDefinition = MessageDef {+  defLocalType  :: !LocalMessageType, -- ^ The local message type being defined++  defGlobalType :: !Int,              -- ^ The /global/ message type this LMT will refer to. Must be a+                                      -- valid @mesg_num@ value from the FIT profile++  defArch       :: !Arch,             -- ^ The /architecture/ this messages with this LMT will use+                                      -- for multi-byte values (little- or big-endian)++  defFields     :: [FieldDef]         -- ^ Definitions for the fields messages with this LMT will contain+  } deriving (Show, Eq)++-- | Defines the structure for a single field in a message+data FieldDef = FieldDef {+  fdNum      :: !Int,     -- ^ The /field number/. The interpretation of the field number depends on the+                          -- global message type and is found in the FIT profile++  fdSize     :: !Int,     -- ^ The size, in bytes, of the field's contents. This will be a multiple of+                          -- the base type size. In a singleton field this size will be the same as the+                          -- base type size. In an array field it will be some multiple of the base type+                          -- size.++  fdBaseType :: !BaseType -- ^ The FIT base type of values in the field+  } deriving (Show, Eq)++-- | A single field in a data message, containing the field number and the value(s)+data Field = SingletonField !Int Value+           | ArrayField !Int Array+           deriving (Show)++-- | Singleton values. There is a Value constructor for each BaseType constructor. The wrapped+-- value in these constructors corresponds to the specific format used in the FIT file, for+-- example an 'enum' in FIT is stored as an 8-bit unsigned int (ie a Word8). The primary exception+-- to this is using @Text@ for string values.+data Value = EnumValue !Word8+           | SInt8Value !Int8+           | UInt8Value !Word8+           | SInt16Value !Int16+           | UInt16Value !Word16+           | SInt32Value !Int32+           | UInt32Value !Word32+           | StringValue Text -- ^ A 'string' in FIT is a null-terminated arrays of UTF-8+                              -- code units, but @Text@ is used here instead+           | Float32Value !Float+           | Float64Value !Double+           | UInt8ZValue !Word8+           | UInt16ZValue !Word16+           | UInt32ZValue !Word32+           | ByteValue !Word8+           deriving (Show)++-- | Array values use similar constructors to singleton values. However, there is no constructor+-- for arrays of strings, which seem to be unused in FIT.+data Array = EnumArray (Seq Word8)+           | SInt8Array (Seq Int8)+           | UInt8Array (Seq Word8)+           | SInt16Array (Seq Int16)+           | UInt16Array (Seq Word16)+           | SInt32Array (Seq Int32)+           | UInt32Array (Seq Word32)+           | Float32Array (Seq Float)+           | Float64Array (Seq Double)+           | UInt8ZArray (Seq Word8)+           | UInt16ZArray (Seq Word16)+           | UInt32ZArray (Seq Word32)+           | ByteArray (Seq Word8)+           deriving (Show)++-- | Each message has a header that primarily determines whether the message is a+-- definition or data message. If the message uses a /compressed timestamp header/,+-- the header also contains the compressed time offset.+data MessageHeader = DefHeader !LocalMessageType+                   | DataHeader !LocalMessageType+                   | CTDataHeader !LocalMessageType !TimeOffset+                   deriving (Show)++-- | A local message type is a 4 bit unsigned integer+newtype LocalMessageType = LMT { unLmt :: Int8 } deriving (Show, Eq)++-- | Only the lower 4 bits of the integer are used to construct a @LocalMessageType@+mkLocalMessageType :: (Integral a, Bits a) => a -> LocalMessageType+mkLocalMessageType = LMT . fromIntegral . ((.&.) 0xF)++-- | Unwrap a @LocalMessageType@. The resulting integer will be between 0 and 15+unLocalMessageType :: Integral a => LocalMessageType -> a+unLocalMessageType = fromIntegral . unLmt++-- | A time offset is 5 bits+newtype TimeOffset = TO { unTo :: Word8 } deriving (Show)++-- | Only the lower 5 bits of the number are used+mkTimeOffset :: (Integral a, Bits a) => a -> TimeOffset+mkTimeOffset = TO . fromIntegral . ((.&.) 0x1F)++newtype Timestamp = Timestamp { unTimestamp :: Word32 } deriving (Show, Eq)++-- | The different types that FIT uses for field values+data BaseType = FitEnum+              | FitSInt8+              | FitUInt8+              | FitSInt16+              | FitUInt16+              | FitSInt32+              | FitUInt32+              | FitString+              | FitFloat32+              | FitFloat64+              | FitUInt8Z+              | FitUInt16Z+              | FitUInt32Z+              | FitByte+              deriving (Show, Eq)++-- | Get the size in bytes for a single value of the given base type+btSize :: BaseType -> Int+btSize bt = case bt of+                FitEnum -> 1+                FitSInt8 -> 1+                FitUInt8 -> 1+                FitSInt16 -> 2+                FitUInt16 -> 2+                FitSInt32 -> 4+                FitUInt32 -> 4+                FitString -> 1+                FitFloat32 -> 4+                FitFloat64 -> 8+                FitUInt8Z -> 1+                FitUInt16Z -> 2+                FitUInt32Z -> 4+                FitByte -> 1
+ src/Fit/Internal/FitParser.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE LambdaCase #-}++module Fit.Internal.FitParser (+  -- * FitParser+  FitParser,+  runFitParser,+  FpState(..),+  Definitions(..),++  addMessageDef,+  lookupMessageDef,+  withArchitecture,+  storeTimestamp,+  updateTimestamp,++  -- * Architecture-independent parsers+  word8,+  int8,++  -- * Architecture-dependent parsers+  -- $archparsers+  archWord16,+  archWord32,+  archWord64,++  archInt16,+  archInt32,+  archInt64,++  archFloat32,+  archFloat64+  ) where++import Fit.Internal.Architecture+import Fit.Internal.FitFile+import qualified Fit.Internal.Numbers as N++import Control.Applicative ((<$>), (<*), (*>))+import Control.Monad.State.Class (get, modify)+import Control.Monad.State.Strict (StateT, evalStateT)+import Control.Monad.Trans (lift)+import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as A (anyWord8)+import Data.Bits ((.&.))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap (insert, lookup, empty)+import Data.Word (Word8, Word16, Word32, Word64)++type FitParser a = StateT FpState Parser a++-- | Turn a 'FitParser' into a plain attoparsec 'Parser'. This doesn't require any+-- configuration as the initial state for a FIT parse is always the same.+runFitParser :: FitParser a -> Parser a+runFitParser = flip evalStateT (FpState ArchLittle defEmpty Nothing)++-- | Little-endian interpretation is used by default by 'FitParser'.+-- Use this function to set the endianness to use for the scope of a particular action.+-- After the action is finished the previous endianness is restored.+withArchitecture :: Arch -> FitParser a -> FitParser a+withArchitecture arch action =+  use fpArch >>= \old -> setArch arch *> action <* setArch old++setArch :: Arch -> FitParser ()+setArch = assign fpArch++-- | Register a 'MessageDefinition' with the parser, so it can decode+-- subsequent data messages using the definition+addMessageDef :: MessageDefinition -> FitParser ()+addMessageDef def = fpMessageDefs %= (defAdd def)++-- | Look up the 'MessageDefinition' for the given message type.+-- It is an error to look up a message type that has no registered definition,+-- since it is impossible to decode a data message with no definition+lookupMessageDef :: LocalMessageType -> FitParser MessageDefinition+lookupMessageDef lmt = do+  msgDefs <- use fpMessageDefs+  case defLookup lmt msgDefs of+   Just def -> return def+   Nothing -> error $ "No definition for local type " ++ (show lmt)++-- | Store the given 'Timestamp' as the most recent. Is used to store timestamps+-- from non-compressed timestamp messages. For compressed-timestamp messages use+-- 'updateTimestamp' instead.+storeTimestamp :: Timestamp -> FitParser ()+storeTimestamp t = fpLastTimestamp .= Just t++-- | Use the given 'TimeOffset' and the previous 'Timestamp' to compute a new+-- Timestamp. The new 'Timestamp' is stored as most recent and is returned.+--+-- This function fails if there is no previously-stored 'Timestamp'. This+-- condition should never come up when parsing a valid FIT file.+updateTimestamp :: TimeOffset -> FitParser Timestamp+updateTimestamp offset = do+  previous <- use fpLastTimestamp+  let new = addOffset offset previous+  fpLastTimestamp .= Just new+  return new++  where addOffset _ Nothing = error "No base timestamp to update"+        addOffset (TO off) (Just (Timestamp previous)) =+          let off' = fromIntegral off+              low5Prev = previous .&. 0x1F+              high27Prev = previous .&. 0xFFFFFFE0+              rollover = off' < low5Prev+          in if rollover+             then Timestamp $ high27Prev + 0x20 + off'+             else Timestamp $ high27Prev + off'++-- | The necessary state for parsing FIT files+data FpState = FpState {+  _fpArch          :: !Arch,             -- ^ The active endian-ness+  _fpMessageDefs   :: Definitions,       -- ^ The set of active message definitions+  _fpLastTimestamp :: !(Maybe Timestamp) -- ^ The most recently stored timestamp+  }++-- | The definitions are stored as a map on the local message type number. When a definition+-- is parsed with a previously-used local message type, the previous definition is+-- overwritten.+newtype Definitions = Defs { unDefs :: IntMap MessageDefinition }++{- Lenses for FpState -}+fpArch :: Functor f => Lens f FpState Arch+fpArch f (FpState arch defs ts) = (\arch' -> FpState arch' defs ts) <$> (f arch)++fpMessageDefs :: Functor f => Lens f FpState Definitions+fpMessageDefs f (FpState arch defs ts) = (\defs' -> FpState arch defs' ts) <$> (f defs)++fpLastTimestamp :: Functor f => Lens f FpState (Maybe Timestamp)+fpLastTimestamp f (FpState arch defs ts) = (\ts' -> FpState arch defs ts') <$> (f ts)++defAdd :: MessageDefinition -> Definitions -> Definitions+defAdd md = Defs . (IntMap.insert lmt md) . unDefs+  where lmt = unLocalMessageType . defLocalType $ md++defLookup :: LocalMessageType -> Definitions -> Maybe MessageDefinition+defLookup (LMT lmt) (Defs defs) = IntMap.lookup (fromIntegral lmt) defs++defEmpty :: Definitions+defEmpty = Defs (IntMap.empty)+++word8 :: FitParser Word8+word8 = lift A.anyWord8++int8 :: FitParser Int8+int8 = fromIntegral <$> word8++-- $archparsers+-- The following parsers are all sensitive to the active endianness. For example,+-- 'archWord16' will use a little-endian or big-endian interpretation according+-- to the architecture for the 'MessageDefinition' for the current message.+-- Internally, these parsers use the endian-specific parsers from "Fit.Internal.Numbers".++-- | Parse a Word16 using the active endianness+archWord16 :: FitParser Word16+archWord16 = withArch N.word16le N.word16be++-- | Parse a Word32 using the active endianness+archWord32 :: FitParser Word32+archWord32 = withArch N.word32le N.word32be++-- | Parse a Word64 using the active endianness+archWord64 :: FitParser Word64+archWord64 = withArch N.word64le N.word64be++-- | Parse an Int16 using the active endianness+archInt16 :: FitParser Int16+archInt16 = withArch N.int16le N.int16be++-- | Parse an Int32 using the active endiannessa+archInt32 :: FitParser Int32+archInt32 = withArch N.int32le N.int32be++-- | Parse an Int64 using the active endianness+archInt64 :: FitParser Int64+archInt64 = withArch N.int64le N.int64be++-- | Parse a Float using the active endianness+archFloat32 :: FitParser Float+archFloat32 = withArch N.float32le N.float32be++-- | Parse a Double using the active endianness+archFloat64 :: FitParser Double+archFloat64 = withArch N.float64le N.float64be++-- | Perform an architecture-sensitive operation with separate+-- actions for little- and big-endian parsing+withArch :: LittleEndian (Parser a) -> BigEndian (Parser a) -> FitParser a+withArch little big = use fpArch >>= \case+  ArchLittle -> lift (unArch little)+  ArchBig -> lift (unArch big)+++{- Quick lens implementation for handling state in FitParser -}++view :: Getter s a -> s -> a+view l x = getConst $ l Const x++over :: Setter s a -> (a -> a) -> s -> s+over l f x = runIdentity $ l (Identity . f) x++set :: Setter s a -> a -> s -> s+set l x = over l (const x)++use :: (Monad m, Functor m) => Getter s a -> StateT s m a+use l = fmap (view l) get++assign :: (Monad m, Functor m) => Setter s a -> a -> StateT s m ()+assign l x = modify (set l x)++(.=) :: (Monad m, Functor m) => Setter s a -> a -> StateT s m ()+l .= x = assign l x++(%=) :: (Monad m, Functor m) => Setter s a -> (a -> a) -> StateT s m ()+l %= f = modify (over l f)++type Lens f s a = (a -> f a) -> s -> f s++type Getter s a = Lens (Const a) s a++type Setter s a = Lens Identity s a++newtype Identity a = Identity { runIdentity :: a }++instance Functor Identity where+  fmap f (Identity a) = Identity (f a)++newtype Const a b = Const { getConst :: a }++instance Functor (Const a) where+  fmap _ (Const x) = (Const x)
+ src/Fit/Internal/Numbers.hs view
@@ -0,0 +1,142 @@+-- | Little-endian and big-endian parsers for signed and unsigned integers, and+-- for single-precision and double-precision floating point numbers.+--+-- The parsers are tagged for endianness using the tools in "Fit.Internal.Architecture".+module Fit.Internal.Numbers (+  -- * Little-endian parsers+  int16le,+  int32le,+  int64le,+  word16le,+  word32le,+  word64le,+  float32le,+  float64le,++  -- * Big-endian parsers+  int16be,+  int32be,+  int64be,+  word16be,+  word32be,+  word64be,+  float32be,+  float64be,++  -- * Helpers+  nByteIntLe,+  nByteIntBe+  ) where++import Fit.Internal.Architecture++import Control.Applicative ((<$>))++import Data.Int (Int16, Int32, Int64)+import Data.Bits (Bits, shiftL, FiniteBits, finiteBitSize)+import Data.Word (Word16, Word32, Word64)++import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as A (take)+import qualified Data.ByteString as B (foldr, foldl')++import qualified Foreign as F (alloca, poke, peek, castPtr)+import System.IO.Unsafe (unsafePerformIO)++{- little-endian parsers -}+word16le :: LittleEndian (Parser Word16)+word16le = parseLe++word32le :: LittleEndian (Parser Word32)+word32le = parseLe++word64le :: LittleEndian (Parser Word64)+word64le = parseLe++int16le :: LittleEndian (Parser Int16)+int16le = parseLe++int32le :: LittleEndian (Parser Int32)+int32le = parseLe++int64le :: LittleEndian (Parser Int64)+int64le = parseLe++parseLe :: (Integral a, FiniteBits a) => LittleEndian (Parser a)+parseLe = withLE $ p 0+  where p :: (Integral a, FiniteBits a) => a -> Parser a+        p proxy = let n = byteSize proxy+                  in nByteIntLe n++float32le :: LittleEndian (Parser Float)+float32le = fmap (fmap toFloat) word32le++float64le :: LittleEndian (Parser Double)+float64le = fmap (fmap toDouble) word64le++-- | Parse @n@ bytes and interpret them as a little-endian integer. The caller+-- must ensure that the returned type is the correct size for the number of+-- bytes parsed.+nByteIntLe :: (Integral a, Bits a) => Int -> Parser a+nByteIntLe nbytes = B.foldr go 0 <$> A.take nbytes+  where go b acc = (acc `shiftL` 8) + (fromIntegral b)++{- big-endian parsers -}+word16be :: BigEndian (Parser Word16)+word16be = parseBe++word32be :: BigEndian (Parser Word32)+word32be = parseBe++word64be :: BigEndian (Parser Word64)+word64be = parseBe++int16be :: BigEndian (Parser Int16)+int16be = parseBe++int32be :: BigEndian (Parser Int32)+int32be = parseBe++int64be :: BigEndian (Parser Int64)+int64be = parseBe++parseBe :: (Integral a, FiniteBits a) => BigEndian (Parser a)+parseBe = withBE $ p 0+  where p :: (Integral a, FiniteBits a) => a -> Parser a+        p proxy = let n = byteSize proxy+                  in nByteIntBe n++float32be :: BigEndian (Parser Float)+float32be = fmap (fmap toFloat) word32be++float64be :: BigEndian (Parser Double)+float64be = fmap (fmap toDouble) word64be++-- | Parse @n@ bytes and interpret them as a big-endian integer. The caller+-- must ensure that the returned type is the correct size for the number of+-- bytes parsed.+nByteIntBe :: (Integral a, Bits a) => Int -> Parser a+nByteIntBe nbytes = B.foldl' go 0 <$> A.take nbytes+  where go acc b = (acc `shiftL` 8) + (fromIntegral b)++-- | Get the number of 8-bit bytes used to represent the given number.+-- The actual value passed is not used at all.+byteSize :: (FiniteBits a) => a -> Int+byteSize n = finiteBitSize n `div` 8++{-+  Conversion helpers for re-interpreting bytes as floating-point numbers.+  See this Stack Overflow post for details on word -> float conversion:++  https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-float/7002812+-}++toFloat :: Word32 -> Float+toFloat word = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) word+  F.peek buf++toDouble :: Word64 -> Double+toDouble word = unsafePerformIO $ F.alloca $ \buf -> do+  F.poke (F.castPtr buf) word+  F.peek buf
+ src/Fit/Internal/Parse.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++module Fit.Internal.Parse (+  readFitRaw,+  parseFit,++  -- * Parsers for components of FIT files+  parseHeader,+  parseMessages,+  parseMessage,+  parseMessageDef,+  parseFieldDef,+  parseDataMessage,+  parseField,+  parseValue,+  parseArray,+  parseSeq,+  parseString,+  parseCTDataMessage,+  mkHeader+  ) where++import Fit.Internal.Architecture+import Fit.Internal.FitFile+import Fit.Internal.FitParser++import Control.Applicative ((<$>), (<*>), (<*))+import Control.Monad (replicateM)+import Control.Monad.Trans (lift)+import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString as A (parseOnly, string, anyWord8, takeTill)+import qualified Data.Attoparsec.Combinator as A (count, many')+import Data.Bits (testBit, shiftR, (.&.))+import Data.ByteString (ByteString)+import qualified Data.ByteString as B (init)+import Data.Sequence (Seq)+import qualified Data.Sequence as S (fromList)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Data.Word (Word8)++-- TODO ignores final CRC bytes+-- | Parse a strict @ByteString@ containing the FIT data into a @Fit@ value+readFitRaw :: ByteString -> Either String Fit+readFitRaw bs = let noCrc = B.init (B.init bs) -- Drop CRC bytes+                in A.parseOnly parseFit noCrc++-- | An Attoparsec parser for @Fit@ values+parseFit :: Parser Fit+parseFit = runFitParser $ Fit <$> parseHeader <*> parseMessages++-- Numbers in the FIT header are all little-endian+parseHeader :: FitParser FitHeader+parseHeader = withArchitecture ArchLittle $ do+  headerSize <- word8+  protocolVersion <- word8+  profileVersion <- archWord16+  dataSize <- archWord32+  marker <- lift $ A.string ".FIT"+  crc <- if headerSize == 14+         then Just <$> archWord16+         else return Nothing++  return $ FH headerSize protocolVersion profileVersion dataSize marker crc++parseMessages :: FitParser [Message]+parseMessages = A.many' parseMessage++parseMessage :: FitParser Message+parseMessage = do+  headerByte <- lift A.anyWord8+  let header = mkHeader headerByte+  case header of+   DefHeader t -> do+     msgDef <- parseMessageDef t+     addMessageDef msgDef+     return (DefM msgDef)+   DataHeader t -> lookupMessageDef t >>= parseDataMessage+   CTDataHeader t o -> lookupMessageDef t >>= parseCTDataMessage o++parseMessageDef :: LocalMessageType -> FitParser MessageDefinition+parseMessageDef lmt = do+  _ <- word8 -- Unused reserved byte+  arch <- word8 >>= \case+           0 -> return ArchLittle+           1 -> return ArchBig+           _ -> error "Architecture neither 0 nor 1"+  globalNum <- fromIntegral <$> withArchitecture arch archInt16+  numFields <- fromIntegral <$> word8+  fieldDefs <- replicateM numFields (parseFieldDef)+  return $ MessageDef lmt globalNum arch fieldDefs++parseFieldDef :: FitParser FieldDef+parseFieldDef = FieldDef <$> num <*> size <*> baseType+  where num = fromIntegral <$> word8+        size = fromIntegral <$> word8+        baseType = word8 >>= return . \case+          0x00 -> FitEnum+          0x01 -> FitSInt8+          0x02 -> FitUInt8+          0x83 -> FitSInt16+          0x84 -> FitUInt16+          0x85 -> FitSInt32+          0x86 -> FitUInt32+          0x07 -> FitString+          0x88 -> FitFloat32+          0x89 -> FitFloat64+          0x0A -> FitUInt8Z+          0x8B -> FitUInt16Z+          0x8C -> FitUInt32Z+          0x0D -> FitByte+          _ -> error "Invalid base type field"++parseDataMessage :: MessageDefinition -> FitParser Message+parseDataMessage (MessageDef lmt gmt arch fieldDefs) = withArchitecture arch $ do+  fields <- mapM parseField fieldDefs+  return (DataM lmt gmt fields)++parseField :: FieldDef -> FitParser Field+parseField (FieldDef num size bt) = do+  let numValues = size `div` (btSize bt)++  field <- if numValues == 1 || (bt == FitString)+           then SingletonField num <$> parseValue bt+           else ArrayField num <$> parseArray num bt++  case field of+   TimestampField t -> storeTimestamp (Timestamp t) >> return field+   _ -> return field++parseValue :: BaseType -> FitParser Value+parseValue bt =+  case bt of+   FitEnum -> EnumValue <$> word8+   FitSInt8 -> SInt8Value <$> int8+   FitUInt8 -> UInt8Value <$> word8+   FitSInt16 -> SInt16Value <$> archInt16+   FitUInt16 -> UInt16Value <$> archWord16+   FitSInt32 -> SInt32Value <$> archInt32+   FitUInt32 -> UInt32Value <$> archWord32+   FitString -> StringValue <$> lift parseString+   FitFloat32 -> Float32Value <$> archFloat32+   FitFloat64 -> Float64Value <$> archFloat64+   FitUInt8Z -> UInt8ZValue <$> word8+   FitUInt16Z -> UInt16ZValue <$> archWord16+   FitUInt32Z -> UInt32ZValue <$> archWord32+   FitByte -> ByteValue <$> word8++-- | This function will fail if the 'BaseType' is 'FitString'. This implementation+-- currently doesn't support arrays of strings, but treats char arrays as always+-- being a single string.+parseArray :: Int         -- ^ The number of elements in the array+              -> BaseType -- ^ The base element type+              -> FitParser Array+parseArray n bt = let seqOf = parseSeq n+  in case bt of+   FitEnum -> EnumArray <$> seqOf word8+   FitSInt8 -> SInt8Array <$> seqOf int8+   FitUInt8 -> UInt8Array <$> seqOf word8+   FitSInt16 -> SInt16Array <$> seqOf archInt16+   FitUInt16 -> UInt16Array <$> seqOf archWord16+   FitSInt32 -> SInt32Array <$> seqOf archInt32+   FitUInt32 -> UInt32Array <$> seqOf archWord32+   FitString -> error "String arrays not supported -- how was this line reached?"+   FitFloat32 -> Float32Array <$> seqOf (fmap fromIntegral archInt32)+   FitFloat64 -> Float64Array <$> seqOf (fmap fromIntegral archInt64)+   FitUInt8Z -> UInt8ZArray <$> seqOf word8+   FitUInt16Z -> UInt16ZArray <$> seqOf archWord16+   FitUInt32Z -> UInt32ZArray <$> seqOf archWord32+   FitByte -> ByteArray <$> seqOf word8++-- | Run a 'FitParser' @n@ times to parse a 'Seq' of values+parseSeq :: Int -> FitParser a -> FitParser (Seq a)+parseSeq n p = S.fromList <$> A.count n p++-- | Parse a null-terminated UTF-8 string.+parseString :: Parser Text+parseString = decodeUtf8 <$> A.takeTill (== 0) <* A.anyWord8++-- | Parse a compressed-timestamp message, using the 'TimeOffset' from the+-- compressed-timestamp message header.+parseCTDataMessage :: TimeOffset -> MessageDefinition -> FitParser Message+parseCTDataMessage offset (MessageDef lmt gmt arch fieldDefs) = withArchitecture arch $ do+  fields <- mapM parseField fieldDefs+  newTimestamp <- updateTimestamp offset+  let timestampField = TimestampField (unTimestamp newTimestamp)+  return $ DataM lmt gmt (timestampField : fields)++-- | Transform a FIT message header byte into a 'MessageHeader'+mkHeader :: Word8 -> MessageHeader+mkHeader byte =+  if isNormalHeader+  then if isDefMessage+       then defHeader+       else dataHeader+  else ctDataHeader++  where+    isNormalHeader = not (testBit byte 7) -- 0 indicates normal header+    isDefMessage = testBit byte 6 -- 0 indicates data message+    defHeader = DefHeader normalLmt+    dataHeader = DataHeader normalLmt+    ctDataHeader = CTDataHeader ctLmt ctOffset+    normalLmt = mkLocalMessageType byte -- in a normal header the lmt is already low 4 bits+    ctLmt = mkLocalMessageType $ (byte `shiftR` 5) .&. 0x3 -- in CT header the lmt is bits 5 and 6+    ctOffset = mkTimeOffset byte -- in CT header the time offset is already low 5 bits++-- Originally this was exported from Fit.Raw.Types, but haddock chokes on patterns+-- between modules. I think the bug is fixed in GHC 7.8.4, so can move this back to+-- that module once we're off 7.8.3.+pattern TimestampField t = SingletonField 253 (UInt32Value t)
+ src/Fit/Messages.hs view
@@ -0,0 +1,132 @@+-- | The Messages API abtracts over the structure of a FIT file slightly and presents+-- the FIT file as just the sequence of data messages in the file. The Messages API+-- also abstracts over the various FIT base types (for example, signed/unsigned integers+-- of different sizes) to give a simpler set of types to work with.+--+-- If you need to know about the very specifics of the FIT file structure, use the Raw API+-- instead. However, for pulling information out of a FIT file this API is much more+-- convenient.+module Fit.Messages (+  readMessages,+  readFileMessages,+  parseMessages,+  Messages(..),+  Message(..),+  Field(..),+  Value(..),+  SingletonValue(..),+  ArrayValue(..)+  ) where++import qualified Fit.Internal.FitFile as Raw+import qualified Fit.Internal.Parse as Raw++import Control.Applicative ((<$>))+import Data.Attoparsec.ByteString (Parser)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B (readFile, pack)+import qualified Data.Foldable as F (toList)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as Map (empty, insert)+import Data.Maybe (catMaybes)+import Data.Sequence (Seq)+import qualified Data.Sequence as S (fromList)+import Data.Text (Text)+import Data.Word (Word8)++-- | The collection of data messages from the FIT file.+newtype Messages = Messages {+  _messages :: Seq Message+  } deriving (Show)++-- | A FIT data message+data Message = Message {+  _mNumber :: !Int,        -- ^ The global message number, as found in the FIT profile+  _mFields :: IntMap Field -- ^ The fields in the message, mapped from field number to @Field@+  } deriving (Show)++-- | A single field in a FIT data message+data Field = Field {+  _fNumber :: !Int, -- ^ The field number, as found in the FIT profile+  _fValue  :: Value+  } deriving (Show)++-- | FIT values can either contain a single piece of data or an array. FIT arrays are homogenous+data Value = Singleton SingletonValue+           | Array ArrayValue+           deriving (Show)++-- | A singleton value. In the Messages API we abstract over the specific FIT base type of the field. For example, the FIT types uint8, sint8, uint16, etc. are all presented as an @IntValue@. FIT strings (ie. character arrays) are presented as singleton @TextValue@s. If you need to know the specific base type of a field you can use the Raw API.+data SingletonValue = IntValue !Int+                    | RealValue !Double+                    | ByteValue !Word8+                    | TextValue Text+                    deriving (Show)++-- | Array values. Like singleton values these ignore the specific FIT base type to present a simpler interface. Byte arrays are presented as strict @ByteString@s. There are no character arrays, since the singleton @TextValue@ handles that case.+data ArrayValue = IntArray (Seq Int)+                | RealArray (Seq Double)+                | ByteArray ByteString+                deriving (Show)++-- | Parse a strict @ByteString@ containing the FIT data into its @Messages@+readMessages :: ByteString -> Either String Messages+readMessages bs = toMessages <$> Raw.readFitRaw bs++-- | Parse the given FIT file into its @Messages@+readFileMessages :: FilePath -> IO (Either String Messages)+readFileMessages fp = B.readFile fp >>= return . readMessages++-- | An Attoparsec parser for @Messages@+parseMessages :: Parser Messages+parseMessages = fmap toMessages Raw.parseFit++toMessages :: Raw.Fit -> Messages+toMessages rFit = Messages . S.fromList . catMaybes $ fmap toMessage (Raw.fMessages rFit)++toMessage :: Raw.Message -> Maybe Message+toMessage (Raw.DefM _) = Nothing+toMessage (Raw.DataM _ gmt fields) = Just $ Message gmt (foldr go Map.empty fields)+  where go f@(Raw.SingletonField num _) fieldMap = Map.insert num (toField f) fieldMap+        go f@(Raw.ArrayField num _) fieldMap = Map.insert num (toField f) fieldMap++toField :: Raw.Field -> Field+toField (Raw.SingletonField num value) = Field num . Singleton $ (fromSingletonValue value)+toField (Raw.ArrayField num array) = Field num . Array $ (fromArray array)++fromSingletonValue :: Raw.Value -> SingletonValue+fromSingletonValue v =+  case v of+   Raw.EnumValue i -> IntValue (fromIntegral i)+   Raw.SInt8Value i -> IntValue (fromIntegral i)+   Raw.UInt8Value i -> IntValue (fromIntegral i)+   Raw.SInt16Value i -> IntValue (fromIntegral i)+   Raw.UInt16Value i -> IntValue (fromIntegral i)+   Raw.SInt32Value i -> IntValue (fromIntegral i)+   Raw.UInt32Value i -> IntValue (fromIntegral i)+   Raw.StringValue t -> TextValue t+   Raw.Float32Value f -> RealValue (fromRational (toRational f))+   Raw.Float64Value f -> RealValue f+   Raw.UInt8ZValue i -> IntValue (fromIntegral i)+   Raw.UInt16ZValue i -> IntValue (fromIntegral i)+   Raw.UInt32ZValue i -> IntValue (fromIntegral i)+   Raw.ByteValue b -> ByteValue b++fromArray :: Raw.Array -> ArrayValue+fromArray a =+  case a of+   Raw.EnumArray xs -> intArray xs+   Raw.SInt8Array xs -> intArray xs+   Raw.UInt8Array xs -> intArray xs+   Raw.SInt16Array xs -> intArray xs+   Raw.UInt16Array xs -> intArray xs+   Raw.SInt32Array xs -> intArray xs+   Raw.UInt32Array xs -> intArray xs+   Raw.Float32Array xs -> realArray xs+   Raw.Float64Array xs -> realArray xs+   Raw.UInt8ZArray xs -> intArray xs+   Raw.UInt16ZArray xs -> intArray xs+   Raw.UInt32ZArray xs -> intArray xs+   Raw.ByteArray bs -> ByteArray . B.pack $ F.toList bs+  where intArray is = IntArray $ fmap fromIntegral is+        realArray rs = RealArray $ fmap (fromRational . toRational) rs
+ src/Fit/Messages/Lens.hs view
@@ -0,0 +1,166 @@+-- | Some basic lenses for the Messages API. These are compatible with both lens and lens-family.+-- This package doesn't provide any lens combinators like @^.@ or @^..@, so you'll need to use+-- ones from a lens package.+--+-- For example, the following code gets the values of the 'speed' fields+-- from all of the 'record' messages in the file:+--+-- @+-- Right fit <- readFileMessages "file.fit"+-- let speeds = fit ^.. message 20 . field 6 . int+-- @+module Fit.Messages.Lens (+  -- * Messages+  messages,+  message,+  messageNumber,++  -- * Fields+  fields,+  field,+  fieldNumber,+  fieldValue,++  -- * Values+  -- $values+  int,+  real,+  text,+  byte,+  ints,+  reals,+  bytestring+  ) where++import Fit.Messages++import Control.Applicative ((<$>), pure, Applicative)+import Data.ByteString (ByteString)+import Data.Functor.Contravariant (Contravariant, contramap)+import qualified Data.IntMap as Map (filterWithKey)+import Data.Sequence (Seq)+import qualified Data.Sequence as S (filter)+import Data.Text (Text)+import Data.Traversable (traverse)+import Data.Word (Word8)++-- Helper for building Folds+coerce :: (Contravariant f, Applicative f) => f a -> f b+coerce = contramap (const ()) . fmap (const ())++-- | Traverse all the messages in a @Messages@+--+-- @messages :: Traversal' Messages Message@+messages :: Applicative f => (Message -> f Message) -> Messages -> f Messages+messages f ms =  Messages <$> traverse f (_messages ms)+{-# INLINE messages #-}++-- | A Fold over the messages with the given message number+--+-- @message :: Int -> Fold Messages Message@+message :: (Contravariant f, Applicative f) => Int -> (Message -> f Message) -> Messages -> f Messages+message msgNum f ms = coerce (traverse f targets)+  where targets = S.filter ((== msgNum) . _mNumber) (_messages ms)+{-# INLINE message #-}++-- | Lens on the message number from a @Message@+--+-- @messageNumber :: Lens' Message Int@+messageNumber :: Functor f => (Int -> f Int) -> Message -> f Message+messageNumber f m = (\n -> m { _mNumber = n }) <$> f (_mNumber m)+{-# INLINE messageNumber #-}++-- | Traverse all the fields in a @Message@+--+-- @fields :: Traversal' Message Field@+fields :: Applicative f => (Field -> f Field) -> Message -> f Message+fields f (Message n flds) = Message n <$> traverse f flds+{-# INLINE fields #-}++-- | A Fold over the fields in a @Message@ with the given field number+--+-- @field :: Int -> Fold Message Field@+field :: (Contravariant f, Applicative f) => Int -> (Field -> f Field) -> Message -> f Message+field n f msg = coerce (traverse f targetFields)+  where targetFields = Map.filterWithKey (\k _ -> k == n) (_mFields msg)+{-# INLINE field #-}++-- | Lens on the field number from a @Field@+--+-- @fieldNumber :: Lens Field Int@+fieldNumber :: Functor f => (Int -> f Int) -> Field -> f Field+fieldNumber f fld = (\n -> fld { _fNumber = n }) <$> f (_fNumber fld)+{-# INLINE fieldNumber #-}++-- | Lens on the @Value@ from a @Field@+--+-- @fieldValue :: Lens Field Value@+fieldValue :: Functor f => (Value -> f Value) -> Field -> f Field+fieldValue f fld = (\v -> fld { _fValue = v }) <$> f (_fValue fld)+{-# INLINE fieldValue #-}+++-- $values+-- Generally when you're looking up the value for a particular field you'll know+-- the expected type ahead of time. If you know the field you're looking at holds+-- integers, then you can use @int@ to directly get an @Int@ instead of a+-- @Singleton (IntValue x)@.+--+-- These traversals are not prisms, because to reconstruct the @Field@ we need+-- the field number in addition to the wrapped value.++-- | Traverse the @Singleton@ and @IntValue@ constructors for a field value+--+-- @int :: Traversal' Field Int@+int :: Applicative f => (Int -> f Int) -> Field -> f Field+int f (Field n (Singleton (IntValue i))) = Field n . Singleton . IntValue <$> f i+int _ fld = pure fld+{-# INLINE int #-}++-- | Traverse the @Singleton@ and @RealValue@ constructors for a field value+--+-- @real :: Traversal' Field Double@+real :: Applicative f => (Double -> f Double) -> Field -> f Field+real f (Field n (Singleton (RealValue d))) = Field n . Singleton . RealValue <$> f d+real _ fld = pure fld+{-# INLINE real #-}++-- | Traverse the @Singleton@ and @TextValue@ constructors for a field value+--+-- @text :: Traversal' Field Text@+text :: Applicative f => (Text -> f Text) -> Field -> f Field+text f (Field n (Singleton (TextValue t))) = Field n . Singleton . TextValue <$> f t+text _ fld = pure fld+{-# INLINE text #-}++-- | Traverse the @Singleton@ and @ByteValue@ constructors for a field value+--+-- @byte :: Traversal' Field Word8@+byte :: Applicative f => (Word8 -> f Word8) -> Field -> f Field+byte f (Field n (Singleton (ByteValue b))) = Field n . Singleton . ByteValue <$> f b+byte _ fld = pure fld+{-# INLINE byte #-}++-- | Traverse the @Array@ and @IntArray@ constructors for a field value+--+-- @ints :: Traversal' Field (Seq Int)@+ints :: Applicative f => (Seq Int -> f (Seq Int)) -> Field -> f Field+ints f (Field n (Array (IntArray s))) = Field n . Array . IntArray <$> f s+ints _ fld = pure fld+{-# INLINE ints #-}++-- | Traverse the @Array@ and @RealArray@ constructors for a field value+--+-- @reals :: Traversal' Field (Seq Double)@+reals :: Applicative f => (Seq Double -> f (Seq Double)) -> Field -> f Field+reals f (Field n (Array (RealArray s))) = Field n . Array . RealArray <$> f s+reals _ fld = pure fld+{-# INLINE reals #-}++-- | Travese the @Array@ and @ByteArray@ constructors for a field value+--+-- @bytestring :: Traversal' Field ByteString@+bytestring :: Applicative f => (ByteString -> f ByteString) -> Field -> f Field+bytestring f (Field n (Array (ByteArray bs))) = Field n . Array . ByteArray <$> f bs+bytestring _ fld = pure fld+{-# INLINE bytestring #-}
+ test/TestFit.hs view
@@ -0,0 +1,11 @@+import Test.Fit.Internal.Numbers as Numbers+import Test.Fit.Internal.FitParser as FitParser+import Test.Fit.Internal.FitFile as FitFile++import Test.Hspec++main :: IO ()+main = hspec $ do+  Numbers.specs+  FitParser.specs+  FitFile.specs