diff --git a/Data/Iteratee/ZoomCache.hs b/Data/Iteratee/ZoomCache.hs new file mode 100644 --- /dev/null +++ b/Data/Iteratee/ZoomCache.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- Iteratee reading of ZoomCache files. +---------------------------------------------------------------------- + +module Data.Iteratee.ZoomCache ( + -- * Types + Stream(..) + + -- * Parsing iteratees + , iterHeaders + + -- * Enumeratee + , enumCacheFile + , enumStream + + -- * Iteratee maps + , mapStream + , mapPackets + , mapSummaries +) where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) +import Control.Monad.Trans (MonadIO) +import qualified Data.ByteString.Lazy as L +import Data.Int +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.Iteratee (Iteratee) +import qualified Data.Iteratee as I +import qualified Data.Iteratee.ListLike as LL +import Data.Maybe +import Data.Ratio +import Data.Word +import Unsafe.Coerce (unsafeCoerce) + +import Data.ZoomCache.Common +import Data.ZoomCache.Packet +import Data.ZoomCache.Summary + +---------------------------------------------------------------------- + +data Stream = + StreamPacket + { strmFile :: CacheFile + , strmTrack :: TrackNo + , strmPacket :: Packet + } + | StreamSummary + { strmFile :: CacheFile + , strmTrack :: TrackNo + , strmSummary :: Summary + } + | StreamNull + +instance LL.Nullable Stream where + nullC StreamNull = True + nullC _ = False + +instance LL.NullPoint Stream where + empty = StreamNull + +---------------------------------------------------------------------- + +-- | An enumeratee of a zoom-cache file, from the global header onwards. +-- The global and track headers will be transparently read, and the +-- 'CacheFile' visible in the 'Stream' elements. +enumCacheFile :: (Functor m, MonadIO m) + => I.Enumeratee [Word8] Stream m a +enumCacheFile iter = do + fi <- iterHeaders + enumStream fi iter + +-- | An enumeratee of zoom-cache data, after global and track headers +-- have been read, or if the 'CacheFile' has been acquired elsewhere. +enumStream :: (Functor m, MonadIO m) + => CacheFile + -> I.Enumeratee [Word8] Stream m a +enumStream = I.unfoldConvStream go + where + go :: (Functor m, MonadIO m) + => CacheFile + -> Iteratee [Word8] m (CacheFile, Stream) + go cf = do + header <- I.joinI $ I.takeUpTo 8 I.stream2list + case parseHeader (L.pack header) of + Just PacketHeader -> do + (trackNo, packet) <- readPacket (cfSpecs cf) + return (cf, StreamPacket cf trackNo (fromJust packet)) + Just SummaryHeader -> do + (trackNo, summary) <- readSummary (cfSpecs cf) + return (cf, StreamSummary cf trackNo (fromJust summary)) + _ -> return (cf, StreamNull) + +------------------------------------------------------------ + +parseHeader :: L.ByteString -> Maybe HeaderType +parseHeader h + | h == globalHeader = Just GlobalHeader + | h == trackHeader = Just TrackHeader + | h == packetHeader = Just PacketHeader + | h == summaryHeader = Just SummaryHeader + | otherwise = Nothing + +------------------------------------------------------------ +-- Global, track headers + +-- | Parse only the global and track headers of a zoom-cache file, returning +-- a 'CacheFile' +iterHeaders :: (Functor m, MonadIO m) + => I.Iteratee [Word8] m CacheFile +iterHeaders = iterGlobal >>= go + where + iterGlobal :: (Functor m, MonadIO m) + => Iteratee [Word8] m CacheFile + iterGlobal = do + header <- I.joinI $ I.takeUpTo 8 I.stream2list + case parseHeader (L.pack header) of + Just GlobalHeader -> mkCacheFile <$> readGlobalHeader + _ -> error "No global header" + + go :: (Functor m, MonadIO m) + => CacheFile + -> Iteratee [Word8] m CacheFile + go fi = do + header <- I.joinI $ I.takeUpTo 8 I.stream2list + case parseHeader (L.pack header) of + Just TrackHeader -> do + (trackNo, spec) <- readTrackHeader + let fi' = fi{cfSpecs = IM.insert trackNo spec (cfSpecs fi)} + if (fiFull fi') + then return fi' + else go fi' + _ -> return fi + +readGlobalHeader :: (Functor m, MonadIO m) => Iteratee [Word8] m Global +readGlobalHeader = do + v <- readVersion + n <- zReadInt32 + p <- readRational64 + b <- readRational64 + _u <- L.pack <$> (I.joinI $ I.takeUpTo 20 I.stream2list) + return $ Global v n p b Nothing + +readTrackHeader :: (Functor m, MonadIO m) => Iteratee [Word8] m (TrackNo, TrackSpec) +readTrackHeader = do + trackNo <- zReadInt32 + trackType <- readTrackType + drType <- readDataRateType + + rate <- readRational64 + + byteLength <- zReadInt32 + name <- L.pack <$> (I.joinI $ I.takeUpTo byteLength I.stream2list) + + let spec = TrackSpec trackType drType rate name + + return (trackNo, spec) + +------------------------------------------------------------ +-- Packet, Summary reading + +readPacket :: (Functor m, MonadIO m) + => IntMap TrackSpec + -> Iteratee [Word8] m (TrackNo, Maybe Packet) +readPacket specs = do + trackNo <- zReadInt32 + entryTime <- TS <$> zReadInt32 + exitTime <- TS <$> zReadInt32 + byteLength <- zReadInt32 + count <- zReadInt32 + packet <- case IM.lookup trackNo specs of + Just TrackSpec{..} -> do + d <- case specType of + ZDouble -> do + PDDouble <$> replicateM count zReadFloat64be + ZInt -> do + PDInt <$> replicateM count zReadInt32 + ts <- map TS <$> case specDRType of + ConstantDR -> do + return $ take count [unTS entryTime ..] + VariableDR -> do + replicateM count zReadInt32 + return $ Just (Packet trackNo entryTime exitTime count d ts) + Nothing -> do + I.drop byteLength + return Nothing + return (trackNo, packet) + +readSummary :: (Functor m, MonadIO m) + => IntMap TrackSpec + -> Iteratee [Word8] m (TrackNo, Maybe Summary) +readSummary specs = do + trackNo <- zReadInt32 + lvl <- zReadInt32 + entryTime <- TS <$> zReadInt32 + exitTime <- TS <$> zReadInt32 + byteLength <- zReadInt32 + + summary <- case IM.lookup trackNo specs of + Just TrackSpec{..} -> do + case specType of + ZDouble -> do + let n = flip div 8 byteLength + [en,ex,mn,mx,avg,rms] <- replicateM n zReadFloat64be + return $ Just (SummaryDouble trackNo lvl entryTime exitTime + en ex mn mx avg rms) + ZInt -> do + [en,ex,mn,mx] <- replicateM 4 zReadInt32 + [avg,rms] <- replicateM 2 zReadFloat64be + return $ Just (SummaryInt trackNo lvl entryTime exitTime + en ex mn mx avg rms) + Nothing -> do + I.drop byteLength + return Nothing + return (trackNo, summary) + +---------------------------------------------------------------------- +-- Convenience functions + +-- | Map a monadic 'Stream' processing function over an entire zoom-cache file. +mapStream :: (Functor m, MonadIO m) + => (Stream -> m ()) + -> Iteratee [Word8] m () +mapStream = I.joinI . enumCacheFile . I.mapChunksM_ + +-- | Map a monadic 'Packet' processing function over an entire zoom-cache file. +mapPackets :: (Functor m, MonadIO m) + => (Packet -> m ()) + -> Iteratee [Word8] m () +mapPackets f = mapStream process + where + process StreamPacket{..} = f strmPacket + process _ = return () + +-- | Map a monadic 'Summary' processing function over an entire zoom-cache file. +mapSummaries :: (Functor m, MonadIO m) + => (Summary -> m ()) + -> Iteratee [Word8] m () +mapSummaries f = mapStream process + where + process StreamSummary{..} = f strmSummary + process _ = return () + +---------------------------------------------------------------------- +-- zoom-cache datatype parsers + +readVersion :: (Functor m, MonadIO m) => Iteratee [Word8] m Version +readVersion = do + vMaj <- zReadInt16 + vMin <- zReadInt16 + return $ Version vMaj vMin + +readTrackType :: (Functor m, MonadIO m) => Iteratee [Word8] m TrackType +readTrackType = do + n <- zReadInt16 + case n of + 0 -> return ZDouble + 1 -> return ZInt + _ -> error "Bad tracktype" + +readDataRateType :: (Functor m, MonadIO m) => Iteratee [Word8] m DataRateType +readDataRateType = do + n <- zReadInt16 + case n of + 0 -> return ConstantDR + 1 -> return VariableDR + _ -> error "Bad data rate type" + +---------------------------------------------------------------------- + +zReadInt16 :: (Functor m, MonadIO m) => Iteratee [Word8] m Int +zReadInt16 = fromIntegral . u16_to_s16 <$> I.endianRead2 I.MSB + where + u16_to_s16 :: Word16 -> Int16 + u16_to_s16 = fromIntegral + +zReadInt32 :: (Functor m, MonadIO m) => Iteratee [Word8] m Int +zReadInt32 = fromIntegral . u32_to_s32 <$> I.endianRead4 I.MSB + where + u32_to_s32 :: Word32 -> Int32 + u32_to_s32 = fromIntegral + +zReadInt64 :: (Functor m, MonadIO m) => Iteratee [Word8] m Int +zReadInt64 = fromIntegral . u64_to_s64 <$> I.endianRead8 I.MSB + where + u64_to_s64 :: Word64 -> Int64 + u64_to_s64 = fromIntegral + +zReadFloat64be :: (Functor m, MonadIO m) => Iteratee [Word8] m Double +zReadFloat64be = do + n <- I.endianRead8 I.MSB + return (unsafeCoerce n :: Double) + +readRational64 :: (Functor m, MonadIO m) => Iteratee [Word8] m Rational +readRational64 = do + num <- zReadInt64 + den <- zReadInt64 + if (den == 0) + then return 0 + else return $ (fromIntegral num) % (fromIntegral den) diff --git a/Data/ZoomCache/Common.hs b/Data/ZoomCache/Common.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Common.hs @@ -0,0 +1,331 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- Types used throughout zoom-cache +---------------------------------------------------------------------- + +module Data.ZoomCache.Common ( + -- * Types + HeaderType(..) + , TimeStamp(..) + , TrackType(..) + , DataRateType(..) + , TrackNo + + -- * Global header + , Global(..) + , globalHeader + + -- * CacheFile + , CacheFile(..) + , mkCacheFile + , fiFull + + -- * Version + , Version(..) + , versionMajor + , versionMinor + + -- * Track specification + , TrackMap + , TrackSpec(..) + + -- * Track header + , trackHeader + + -- * Packet header + , packetHeader + + -- * Summary header + , summaryHeader +) where + +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM + +------------------------------------------------------------ + +{- + +All fields are big-endian. + +Global header: + + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1| Byte + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identifier | 0-3 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 4-7 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Version major | Version minor | 8-11 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | No. tracks | 12-15 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Presentationtime numerator | 16-19 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 20-23 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Presentationtime denominator | 24-27 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 28-31 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Basetime numerator | 32-35 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 36-39 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Basetime denominator | 40-43 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 44-47 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | UTC | 48-51 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 52-55 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 56-59 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 60-63 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 64-67 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + +Track header: + + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1| Byte + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identifier | 0-3 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 4-7 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Track no. | 8-11 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Type | Flag: 0=CBR, 1=VBR | 12-15 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Datarate numerator | 16-19 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 20-23 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Datarate denominator | 24-27 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 28-31 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Length of name in bytes | 32-35 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Name (UTF-8) ... | 36- + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + +Type: 0 64 bit IEEE754 floating point (Double) + 1 32 bit signed integer (Int32) + +Datarate: numerator 0 indicates variable bitrate (all data values are timestamped) + +Raw Data Packet header: + + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1| Byte + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identifier | 0-3 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 4-7 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Track no. | 8-11 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Entry Timestamp | 12-15 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Exit Timestamp | 16-19 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Payload length in bytes (remainder of packet) | 20-23 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Count of data points COUNT | 24-27 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Data ... | 28- + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | ... | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Timestamps ... | TS- + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | ... | + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + +Timestamps block is only present if VBR (datarate numerator is 0) + +TS = 28 + (COUNT * sizeof(Type)) + + +Summary Data Packet header (IEEE754 floating point): + + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1| Byte + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identifier | 0-3 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 4-7 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Track no. | 8-11 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Level | 12-15 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Entry Timestamp | 16-19 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Exit Timestamp | 20-23 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Summary length in bytes | 24-27 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Entry (double) | 28-31 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 32-35 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Exit (double) | 36-39 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 40-43 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Min (double) | 44-47 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 48-51 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Max (double) | 52-55 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 56-59 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Avg (double) | 60-63 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 64-67 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | RMS (double) | 68-71 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 72-75 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + +Summary Data Packet header (signed 32-bit integer) + + 0 1 2 3 + 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1| Byte + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Identifier | 0-3 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 4-7 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Track no. | 8-11 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Level | 12-15 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Entry Timestamp | 16-19 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Exit Timestamp | 20-23 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Summary length in bytes | 24-27 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Entry (int32) | 28-31 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Exit (int32) | 32-35 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Min (int32) | 36-39 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Max (int32) | 40-43 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | Avg (double) | 44-47 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 48-51 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | RMS (double) | 52-55 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + | | 56-59 + +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ + +-} + +type TrackNo = Int + +data TimeStamp = TS { unTS :: !Int } + deriving (Eq, Ord, Show) + +data HeaderType = GlobalHeader | TrackHeader | PacketHeader | SummaryHeader + +data Version = Version Int Int + deriving (Eq, Show) + +data Global = Global + { version :: Version + , noTracks :: Int + , presentationTime :: Rational + , baseTime :: Rational + , baseUTC :: Maybe Int -- UTCTime + } + deriving (Show) + +-- | A map of all track numbers to their 'TrackSpec' +type TrackMap = IntMap TrackSpec + +-- | A specification of the type and name of each track +data TrackSpec = TrackSpec + { specType :: TrackType + , specDRType :: DataRateType + , specRate :: Rational + , specName :: L.ByteString + } + deriving (Show) + +data TrackType = ZDouble | ZInt + deriving (Eq, Show) + +-- | Constant or Variable datarate. +-- For constant datarate, timestamps are implied as incrementing by 1/datarate +-- For variable datarate, explicit timestamps are attached to each datum, encoded +-- as a separate block of timestamps in the Raw Data packet. +data DataRateType = ConstantDR | VariableDR + deriving (Show) + +------------------------------------------------------------ + +-- | Global and track headers for a zoom-cache file +data CacheFile = CacheFile + { cfGlobal :: Global + , cfSpecs :: IntMap TrackSpec + } + +-- | Create an empty 'CacheFile' using the given 'Global' +mkCacheFile :: Global -> CacheFile +mkCacheFile g = CacheFile g IM.empty + +-- | Determine whether all tracks of a 'CacheFile' are specified +fiFull :: CacheFile -> Bool +fiFull (CacheFile g specs) = IM.size specs == noTracks g + +------------------------------------------------------------ +-- Magic + +-- | Magic identifier at the beginning of a zoom-cache file. +globalHeader :: L.ByteString +globalHeader = LC.pack "\xe5ZXhe4d\0" + +-- | The major version encoded by this library +versionMajor :: Int +versionMajor = 0 + +-- | The minor version encoded by this library +versionMinor :: Int +versionMinor = 3 + +-- | Identifier for track headers +trackHeader :: L.ByteString +trackHeader = LC.pack "\xe5ZXtRcK\0" + +-- | Identifier for packet headers +packetHeader :: L.ByteString +packetHeader = LC.pack "\xe5ZXp4ck\0" + +-- | Identifier for summary headers +summaryHeader :: L.ByteString +summaryHeader = LC.pack "\xe5ZX5umm\0" + diff --git a/Data/ZoomCache/Packet.hs b/Data/ZoomCache/Packet.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Packet.hs @@ -0,0 +1,36 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- ZoomCache packet definition +---------------------------------------------------------------------- + +module Data.ZoomCache.Packet ( + -- * Types + Packet(..) + , PacketData(..) +) where + +import Data.ZoomCache.Common + +------------------------------------------------------------ + +data PacketData = PDDouble [Double] | PDInt [Int] + +data Packet = Packet + { packetTrack :: TrackNo + , packetEntryTime :: TimeStamp + , packetExitTime :: TimeStamp + , packetCount :: Int + , packetData :: PacketData + , packetTimeStamps :: [TimeStamp] + } + +------------------------------------------------------------ diff --git a/Data/ZoomCache/Pretty.hs b/Data/ZoomCache/Pretty.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Pretty.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- Pretty-printing of zoom-cache types +---------------------------------------------------------------------- + +module Data.ZoomCache.Pretty ( + prettyGlobal + , prettyTrackSpec + , prettySummary +) where + +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.Ratio +import Text.Printf + +import Data.ZoomCache.Common +import Data.ZoomCache.Summary + +---------------------------------------------------------------------- + +-- | Pretty-print a 'Global' +prettyGlobal :: Global -> String +prettyGlobal Global{..} = unlines + [ "Version:\t\t" ++ show vMaj ++ "." ++ show vMin + , "No. tracks:\t\t" ++ show noTracks + , "Presentation-time:\t" ++ ratShow presentationTime + , "Base-time:\t\t" ++ ratShow baseTime + , "UTC baseTime:\t\t" ++ maybe "undefined" show baseUTC + ] + where + Version vMaj vMin = version + +-- | Pretty-print a 'TrackSpec' +prettyTrackSpec :: TrackNo -> TrackSpec -> String +prettyTrackSpec trackNo TrackSpec{..} = unlines + [ "Track " ++ show trackNo ++ ":" + , "\tName:\t" ++ LC.unpack specName + , "\tType:\t" ++ show specType + , "\tRate:\t" ++ show specDRType ++ " " ++ ratShow specRate + ] + +-- | Pretty-print a 'Summary' +prettySummary :: Summary -> String +prettySummary s@SummaryDouble{..} = concat + [ prettySummaryTimes s + , prettySummaryLevel s + , printf "\tentry: %.3f\texit: %.3f\tmin: %.3f\tmax: %.3f\t" + summaryDoubleEntry summaryDoubleExit summaryDoubleMin summaryDoubleMax + , prettySummaryAvgRMS s + ] +prettySummary s@SummaryInt{..} = concat + [ prettySummaryTimes s + , prettySummaryLevel s + , printf "\tentry: %d\texit: %df\tmin: %d\tmax: %d\t" + summaryIntEntry summaryIntExit summaryIntMin summaryIntMax + , prettySummaryAvgRMS s + ] + +prettySummaryTimes :: Summary -> String +prettySummaryTimes s = printf "[%d - %d]" (unTS $ summaryEntryTime s) + (unTS $ summaryExitTime s) + +prettySummaryLevel :: Summary -> String +prettySummaryLevel s = printf "lvl: %d" (summaryLevel s) + +prettySummaryAvgRMS :: Summary -> String +prettySummaryAvgRMS s = printf "avg: %.3f\trms: %.3f" (summaryAvg s) (summaryRMS s) + +---------------------------------------------------------------------- + +ratShow :: Rational -> String +ratShow r + | d == 0 = "0" + | d == 1 = show n + | otherwise = show n ++ "/" ++ show d + where + n = numerator r + d = denominator r + diff --git a/Data/ZoomCache/Read.hs b/Data/ZoomCache/Read.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Read.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- Reading of ZoomCache files. +---------------------------------------------------------------------- + +module Data.ZoomCache.Read ( + -- * Functions + zoomDumpFile + , zoomDumpSummary + , zoomDumpSummaryLevel + , zoomInfoFile +) where + +import Data.Int +import qualified Data.IntMap as IM +import qualified Data.Iteratee as I +import Text.Printf + +import Data.Iteratee.ZoomCache +import Data.ZoomCache.Common +import Data.ZoomCache.Packet +import Data.ZoomCache.Pretty +import Data.ZoomCache.Summary + +------------------------------------------------------------ + +zoomInfoFile :: FilePath -> IO () +zoomInfoFile path = I.fileDriverRandom iterHeaders path >>= info + +zoomDumpFile :: FilePath -> IO () +zoomDumpFile = I.fileDriverRandom (mapPackets dumpData) + +zoomDumpSummary :: FilePath -> IO () +zoomDumpSummary = I.fileDriverRandom (mapSummaries dumpSummary) + +zoomDumpSummaryLevel :: Int -> FilePath -> IO () +zoomDumpSummaryLevel lvl = I.fileDriverRandom (mapSummaries (dumpSummaryLevel lvl)) + +---------------------------------------------------------------------- + +info :: CacheFile -> IO () +info CacheFile{..} = do + putStrLn . prettyGlobal $ cfGlobal + mapM_ (putStrLn . uncurry prettyTrackSpec) . IM.assocs $ cfSpecs + +dumpData :: Packet -> IO () +dumpData p = mapM_ (\(t,d) -> printf "%s: %s\n" t d) tds + where + tds = zip (map (show . unTS) $ packetTimeStamps p) vals + vals = case packetData p of + PDDouble ds -> map show ds + PDInt is -> map show is + +dumpSummary :: Summary -> IO () +dumpSummary = putStrLn . prettySummary + +dumpSummaryLevel :: Int -> Summary -> IO () +dumpSummaryLevel level s + | level == summaryLevel s = dumpSummary s + | otherwise = return () + diff --git a/Data/ZoomCache/Summary.hs b/Data/ZoomCache/Summary.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Summary.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- ZoomCache Summary definition +---------------------------------------------------------------------- + +module Data.ZoomCache.Summary ( + -- * Types + Summary(..) + , summaryDuration + , appendSummary +) where + +import Data.ZoomCache.Common + +---------------------------------------------------------------------- + +-- | A recorded block of summary data +data Summary = SummaryDouble + { summaryTrack :: TrackNo + , summaryLevel :: Int + , summaryEntryTime :: TimeStamp + , summaryExitTime :: TimeStamp + , summaryDoubleEntry :: Double + , summaryDoubleExit :: Double + , summaryDoubleMin :: Double + , summaryDoubleMax :: Double + , summaryAvg :: Double + , summaryRMS :: Double + } + | SummaryInt + { summaryTrack :: TrackNo + , summaryLevel :: Int + , summaryEntryTime :: TimeStamp + , summaryExitTime :: TimeStamp + , summaryIntEntry :: Int + , summaryIntExit :: Int + , summaryIntMin :: Int + , summaryIntMax :: Int + , summaryAvg :: Double + , summaryRMS :: Double + } + deriving (Show) + +-- | The duration covered by a summary, in units of 1 / the track's datarate +summaryDuration :: Summary -> Int +summaryDuration s = (unTS $ summaryExitTime s) - (unTS $ summaryEntryTime s) + +-- | Append two Summaries, merging statistical summary data. +-- XXX: summaries are only compatible if tracks and levels are equal +appendSummary :: Summary -> Summary -> Summary +appendSummary s1@SummaryDouble{} s2@SummaryDouble{} = SummaryDouble + { summaryTrack = summaryTrack s1 + , summaryLevel = summaryLevel s1 + , summaryEntryTime = summaryEntryTime s1 + , summaryExitTime = summaryExitTime s2 + , summaryDoubleEntry = summaryDoubleEntry s1 + , summaryDoubleExit = summaryDoubleExit s2 + , summaryDoubleMin = min (summaryDoubleMin s1) (summaryDoubleMin s2) + , summaryDoubleMax = max (summaryDoubleMax s1) (summaryDoubleMax s2) + , summaryAvg = ((summaryAvg s1 * dur s1) + + (summaryAvg s2 * dur s2)) / + (dur s1 + dur s2) + , summaryRMS = sqrt $ ((summaryRMS s1 * summaryRMS s1 * dur s1) + + (summaryRMS s2 * summaryRMS s2 * dur s2)) / + (dur s1 + dur s2) + } + where + dur = fromIntegral . summaryDuration +appendSummary s1@SummaryInt{} s2@SummaryInt{} = SummaryInt + { summaryTrack = summaryTrack s1 + , summaryLevel = summaryLevel s1 + , summaryEntryTime = summaryEntryTime s1 + , summaryExitTime = summaryExitTime s2 + , summaryIntEntry = summaryIntEntry s1 + , summaryIntExit = summaryIntExit s2 + , summaryIntMin = min (summaryIntMin s1) (summaryIntMin s2) + , summaryIntMax = max (summaryIntMax s1) (summaryIntMax s2) + , summaryAvg = ((summaryAvg s1 * dur s1) + + (summaryAvg s2 * dur s2)) / + (dur s1 + dur s2) + , summaryRMS = sqrt $ ((summaryRMS s1 * summaryRMS s1 * dur s1) + + (summaryRMS s2 * summaryRMS s2 * dur s2)) / + (dur s1 + dur s2) + } + where + dur = fromIntegral . summaryDuration +appendSummary _ _ = error "Incompatible summaries" diff --git a/Data/ZoomCache/Write.hs b/Data/ZoomCache/Write.hs new file mode 100644 --- /dev/null +++ b/Data/ZoomCache/Write.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Data.ZoomCache.Write +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- Stability : unstable +-- Portability : unknown +-- +-- Writing of ZoomCache files. +---------------------------------------------------------------------- + +module Data.ZoomCache.Write ( + -- * The ZoomWrite class + ZoomWrite(..) + + -- * The ZoomW monad + , ZoomW + , withFileWrite + , flush + + -- * ZoomWHandle IO functions + , ZoomWHandle + , openWrite + + -- * Watermarks + , watermark + , setWatermark + + -- * TrackSpec helpers + , oneTrack + , oneTrackVariable +) where + +import Blaze.ByteString.Builder hiding (flush) +import Control.Applicative ((<$>)) +import Control.Monad.State +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Data.Foldable as Fold +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.Monoid +import System.IO + +import Data.ZoomCache.Binary +import Data.ZoomCache.Common +import Data.ZoomCache.Summary +import Numeric.FloatMinMax + +------------------------------------------------------------ + +-- | The ZoomWrite class provides 'write', a method to write a +-- Haskell value to an open ZoomCache file. +-- +class ZoomWrite t where + -- | Write a value to an open ZoomCache file. + write :: TrackNo -> t -> ZoomW () + +instance ZoomWrite Double where + write = writeDouble + +instance ZoomWrite Int where + write = writeInt + +instance ZoomWrite (TimeStamp, Double) where + write = writeDoubleVBR + +instance ZoomWrite (TimeStamp, Int) where + write = writeIntVBR + +------------------------------------------------------------ + +data ZoomWHandle = ZoomWHandle + { whHandle :: Handle + , whTrackWork :: IntMap TrackWork + , whDeferred :: IntMap [Summary] + , whWriteData :: Bool + } + +data TrackWork = TrackWork + { twSpec :: TrackSpec + , twBuilder :: Builder + , twTSBuilder :: Builder + , twCount :: Int + , twWatermark :: Int + , twLevels :: IntMap (Maybe Summary) + , twEntryTime :: TimeStamp + , twExitTime :: TimeStamp + , twData :: ZTSData + } + +data ZTSData = ZTSDouble + { ztsTime :: TimeStamp + , ztsdEntry :: Double + , ztsdExit :: Double + , ztsdMin :: Double + , ztsdMax :: Double + , ztsdSum :: Double + , ztsSumSq :: Double + } + | ZTSInt + { ztsTime :: TimeStamp + , ztsiEntry :: Int + , ztsiExit :: Int + , ztsiMin :: Int + , ztsiMax :: Int + , ztsiSum :: Int + , ztsSumSq :: Double + } + +---------------------------------------------------------------------- +-- Public API + +-- | A StateT IO monad for writing a ZoomCache file +type ZoomW = StateT ZoomWHandle IO + +-- | Run a @ZoomW ()@ action on a given file handle, using the specified +-- 'TrackMap' specification +withFileWrite :: TrackMap + -> Bool -- ^ Whether or not to write raw data packets. + -- If False, only summary blocks are written. + -> ZoomW () + -> FilePath + -> IO () +withFileWrite ztypes doRaw f path = do + z <- openWrite ztypes doRaw path + z' <- execStateT (f >> flush) z + hClose (whHandle z') + +-- | Force a flush of ZoomCache summary blocks to disk. It is not usually +-- necessary to call this function as summary blocks are transparently written +-- at regular intervals. +flush :: ZoomW () +flush = do + h <- gets whHandle + tracks <- gets whTrackWork + doRaw <- gets whWriteData + when doRaw $ + liftIO $ Fold.mapM_ (L.hPut h) $ IM.mapWithKey bsFromTrack tracks + mapM_ (uncurry flushSummary) (IM.assocs tracks) + pending <- concat . IM.elems <$> gets whDeferred + mapM_ writeSummary pending + modify $ \z -> z + { whTrackWork = IM.map flushTrack (whTrackWork z) + , whDeferred = IM.empty + } + where + flushTrack :: TrackWork -> TrackWork + flushTrack tw = d{twLevels = twLevels tw} + where + d = mkTrackState (twSpec tw) (twExitTime tw) (twWatermark tw) + +-- | Open a new ZoomCache file for writing, using a specified 'TrackMap'. +openWrite :: TrackMap + -> Bool -- ^ Whether or not to write raw data packets. + -- If False, only summary blocks are written. + -> FilePath + -> IO ZoomWHandle +openWrite trackMap doRaw path = do + h <- openFile path WriteMode + let global = mkGlobal (IM.size trackMap) + writeGlobalHeader h global + let tracks = IM.foldWithKey addTrack IM.empty trackMap + mapM_ (uncurry (writeTrackHeader h)) (IM.assocs trackMap) + return $ ZoomWHandle h tracks IM.empty doRaw + where + addTrack :: TrackNo -> TrackSpec + -> IntMap TrackWork + -> IntMap TrackWork + addTrack trackNo spec = IM.insert trackNo trackState + where + trackState = mkTrackState spec (TS 0) 1024 + +-- | Create a track map for a single constant-rate stream of a given type, +-- as track no. 1 +oneTrack :: TrackType -> Rational -> L.ByteString -> TrackMap +oneTrack ztype rate name = IM.singleton 1 (TrackSpec ztype ConstantDR rate name) + +-- | Create a track map for a single variable-rate stream of a given type, +-- as track no. 1 +oneTrackVariable :: TrackType -> L.ByteString -> TrackMap +oneTrackVariable ztype name = IM.singleton 1 (TrackSpec ztype VariableDR 0 name) + +-- | Query the maximum number of data points to buffer for a given track before +-- forcing a flush of all buffered data and summaries. +watermark :: TrackNo -> ZoomW (Maybe Int) +watermark trackNo = do + track <- IM.lookup trackNo <$> gets whTrackWork + return (twWatermark <$> track) + +-- | Set the maximum number of data points to buffer for a given track before +-- forcing a flush of all buffered data and summaries. +setWatermark :: TrackNo -> Int -> ZoomW () +setWatermark trackNo w = modifyTrack trackNo f + where + f :: TrackWork -> TrackWork + f tw = tw { twWatermark = w } + +---------------------------------------------------------------------- +-- Global header + +writeGlobalHeader :: Handle -> Global -> IO () +writeGlobalHeader h = L.hPut h . toLazyByteString . fromGlobal + +---------------------------------------------------------------------- +-- Track header + +writeTrackHeader :: Handle -> Int -> TrackSpec -> IO () +writeTrackHeader h trackNo TrackSpec{..} = do + L.hPut h . mconcat $ + [ trackHeader + , toLazyByteString $ mconcat + [ fromTrackNo trackNo + , fromTrackType specType + , fromDataRateType specDRType + , fromRational64 specRate + , encInt . LC.length $ specName + ] + , specName + ] + +---------------------------------------------------------------------- +-- Data + +incTimeStamp :: TimeStamp -> TimeStamp +incTimeStamp (TS t) = TS (t+1) + +incTime :: TrackNo -> ZoomW () +incTime trackNo = modifyTrack trackNo $ \tw -> tw + { twEntryTime = if twCount tw == 0 + then (incTimeStamp (twEntryTime tw)) + else twEntryTime tw + , twExitTime = incTimeStamp (twExitTime tw) + } + +setTime :: TrackNo -> TimeStamp -> ZoomW () +setTime trackNo t = modifyTrack trackNo $ \tw -> tw + { twEntryTime = if twCount tw == 0 then t else twEntryTime tw + , twExitTime = t + } + +flushIfNeeded :: TrackNo -> ZoomW () +flushIfNeeded trackNo = do + zt <- IM.lookup trackNo <$> gets whTrackWork + case zt of + Just track -> when (flushNeeded track) flush + Nothing -> error "no such track" -- addTrack trackNo, if no data has been written + where + flushNeeded :: TrackWork -> Bool + flushNeeded TrackWork{..} = twCount >= twWatermark + +writeData :: (ZoomWrite a) + => (a -> Builder) + -> (Int -> TimeStamp -> a -> ZTSData -> ZTSData) + -> TrackNo -> a -> ZoomW () +writeData builder updater trackNo d = do + incTime trackNo + + doRaw <- gets whWriteData + when doRaw $ + modifyTrack trackNo $ \z -> z { twBuilder = twBuilder z <> builder d } + + modifyTrack trackNo $ \z -> z + { twCount = twCount z + 1 + , twData = updater (twCount z) (twExitTime z) d (twData z) + } + flushIfNeeded trackNo + +writeDataVBR :: (ZoomWrite a) + => (a -> Builder) + -> (Int -> TimeStamp -> a -> ZTSData -> ZTSData) + -> TrackNo -> (TimeStamp, a) -> ZoomW () +writeDataVBR builder updater trackNo (t, d) = do + setTime trackNo t + + doRaw <- gets whWriteData + when doRaw $ + modifyTrack trackNo $ \z -> z + { twBuilder = twBuilder z <> builder d + , twTSBuilder = twTSBuilder z <> + (encInt . unTS) t + } + + modifyTrack trackNo $ \z -> z + { twCount = twCount z + 1 + , twData = updater (twCount z) t d (twData z) + } + flushIfNeeded trackNo + +writeDouble :: TrackNo -> Double -> ZoomW () +writeDouble = writeData (fromWord64be . toWord64) updateZTSDouble + +writeDoubleVBR :: TrackNo -> (TimeStamp, Double) -> ZoomW () +writeDoubleVBR = writeDataVBR (fromWord64be . toWord64) updateZTSDouble + +updateZTSDouble :: Int -> TimeStamp -> Double -> ZTSData -> ZTSData +updateZTSDouble count t d ZTSDouble{..} = ZTSDouble + { ztsTime = t + , ztsdEntry = if count == 0 then d else ztsdEntry + , ztsdExit = d + , ztsdMin = min ztsdMin d + , ztsdMax = max ztsdMax d + , ztsdSum = ztsdSum + (d * dur) + , ztsSumSq = ztsSumSq + (d*d * dur) + } + where + dur = fromIntegral $ (unTS t) - (unTS ztsTime) +updateZTSDouble _ _ _ ZTSInt{..} = error "updateZTSDouble on Int data" + +writeInt :: TrackNo -> Int -> ZoomW () +writeInt = writeData encInt updateZTSInt + +writeIntVBR :: TrackNo -> (TimeStamp, Int) -> ZoomW () +writeIntVBR = writeDataVBR encInt updateZTSInt + +updateZTSInt :: Int -> TimeStamp -> Int -> ZTSData -> ZTSData +updateZTSInt count t i ZTSInt{..} = ZTSInt + { ztsTime = t + , ztsiEntry = if count == 0 then i else ztsiEntry + , ztsiExit = i + , ztsiMin = min ztsiMin i + , ztsiMax = max ztsiMax i + , ztsiSum = ztsiSum + (i * dur) + , ztsSumSq = ztsSumSq + fromIntegral (i*i * dur) + } + where + dur = fromIntegral $ (unTS t) - (unTS ztsTime) +updateZTSInt _ _ _ ZTSDouble{..} = error "updateZTSInt on Double data" + +---------------------------------------------------------------------- +-- Global + +mkGlobal :: Int -> Global +mkGlobal n = Global + { version = Version versionMajor versionMinor + , noTracks = n + , presentationTime = 0 + , baseTime = 0 + , baseUTC = Nothing + } + +---------------------------------------------------------------------- +-- TrackState + +modifyTracks :: (IntMap TrackWork -> IntMap TrackWork) -> ZoomW () +modifyTracks f = modify (\z -> z { whTrackWork = f (whTrackWork z) }) + +modifyTrack :: TrackNo -> (TrackWork -> TrackWork) -> ZoomW () +modifyTrack trackNo f = modifyTracks (IM.adjust f trackNo) + +bsFromTrack :: TrackNo -> TrackWork -> L.ByteString +bsFromTrack trackNo TrackWork{..} = toLazyByteString $ mconcat + [ fromLazyByteString packetHeader + , encInt trackNo + , encInt . unTS $ twEntryTime + , encInt . unTS $ twExitTime + , encInt (len twBuilder + len twTSBuilder) + , encInt twCount + , twBuilder + , twTSBuilder + ] + where + len = L.length . toLazyByteString + +mkTrackState :: TrackSpec -> TimeStamp -> Int -> TrackWork +mkTrackState spec entry w = TrackWork + { twSpec = spec + , twBuilder = mempty + , twTSBuilder = mempty + , twCount = 0 + , twWatermark = w + , twLevels = IM.empty + , twEntryTime = entry + , twExitTime = entry + , twData = initZTSData (specType spec) + } + where + initZTSData ZDouble = ZTSDouble + { ztsTime = entry + , ztsdEntry = 0.0 + , ztsdExit = 0.0 + , ztsdMin = floatMax + , ztsdMax = floatMin + , ztsdSum = 0.0 + , ztsSumSq = 0.0 + } + initZTSData ZInt = ZTSInt + { ztsTime = entry + , ztsiEntry = 0 + , ztsiExit = 0 + , ztsiMin = maxBound + , ztsiMax = minBound + , ztsiSum = 0 + , ztsSumSq = 0 + } + +---------------------------------------------------------------------- +-- Summary + +flushSummary :: TrackNo -> TrackWork -> ZoomW () +flushSummary trackNo trackState@TrackWork{..} = + pushSummary trackState (mkSummary trackNo trackState) + +mkSummary :: TrackNo -> TrackWork -> Summary +mkSummary trackNo TrackWork{..} = mk (specType twSpec) + where + mk ZDouble = SummaryDouble + { summaryTrack = trackNo + , summaryLevel = 1 + , summaryEntryTime = twEntryTime + , summaryExitTime = twExitTime + , summaryDoubleEntry = ztsdEntry twData + , summaryDoubleExit = ztsdExit twData + , summaryDoubleMin = ztsdMin twData + , summaryDoubleMax = ztsdMax twData + , summaryAvg = ztsdSum twData / dur + , summaryRMS = sqrt $ ztsSumSq twData / dur + } + mk ZInt = SummaryInt + { summaryTrack = trackNo + , summaryLevel = 1 + , summaryEntryTime = twEntryTime + , summaryExitTime = twExitTime + , summaryIntEntry = ztsiEntry twData + , summaryIntExit = ztsiExit twData + , summaryIntMin = ztsiMin twData + , summaryIntMax = ztsiMax twData + , summaryAvg = fromIntegral (ztsiSum twData) / dur + , summaryRMS = sqrt $ ztsSumSq twData / dur + } + dur = fromIntegral $ (unTS twExitTime) - (unTS twEntryTime) + +pushSummary :: TrackWork -> Summary -> ZoomW () +pushSummary zt s = do + deferSummary s + case IM.lookup (summaryLevel s) (twLevels zt) of + Just (Just prev) -> do + let new = (prev `appendSummary` s) { summaryLevel = summaryLevel s + 1 } + insert Nothing + pushSummary zt new + _ -> do + insert (Just s) + where + insert :: Maybe Summary -> ZoomW () + insert x = modifyTrack (summaryTrack s) (\ztt -> + ztt { twLevels = IM.insert (summaryLevel s) x (twLevels ztt) } ) + +deferSummary :: Summary -> ZoomW () +deferSummary s = do + modify $ \z -> z + { whDeferred = IM.alter f (summaryLevel s) (whDeferred z) } + where + f Nothing = Just [s] + f (Just pending) = Just (pending ++ [s]) + +writeSummary :: Summary -> ZoomW () +writeSummary s = do + h <- gets whHandle + liftIO . L.hPut h . toLazyByteString . fromSummary $ s + +------------------------------------------------------------ + +(<>) :: Monoid a => a -> a -> a +(<>) = mappend + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright Conrad Parker 2011 + +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. + +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/tools/zoom-cache.hs b/tools/zoom-cache.hs new file mode 100644 --- /dev/null +++ b/tools/zoom-cache.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} + +module Main ( + main +) where + +import Control.Monad (foldM) +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import Data.Default +import System.Console.GetOpt +import UI.Command + +import Data.ZoomCache.Common +import Data.ZoomCache.Read +import Data.ZoomCache.Write + +------------------------------------------------------------ + +data Config = Config + { noRaw :: Bool + , variable :: Bool + , intData :: Bool + , label :: L.ByteString + , rate :: Integer + , wmLevel :: Int + } + +instance Default Config where + def = defConfig + +defConfig :: Config +defConfig = Config + { noRaw = False + , variable = False + , intData = False + , label = "gen" + , rate = 1000 + , wmLevel = 1024 + } + +data Option = NoRaw + | Variable + | IntData + | Label String + | Rate String + | Watermark String + deriving (Eq) + +options :: [OptDescr Option] +options = genOptions + +genOptions :: [OptDescr Option] +genOptions = + [ Option ['z'] ["no-raw"] (NoArg NoRaw) + "Do NOT include raw data in the output" + , Option ['b'] ["variable"] (NoArg Variable) + "Generate variable-rate data" + , Option ['i'] ["integer"] (NoArg IntData) + "Generate ingeger data" + , Option ['l'] ["label"] (ReqArg Label "label") + "Set track label" + , Option ['r'] ["rate"] (ReqArg Rate "data-rate") + "Set track rate" + , Option ['w'] ["watermark"] (ReqArg Rate "watermark") + "Set high-watermark level" + ] + +processArgs :: [String] -> IO (Config, [String]) +processArgs args = do + case getOpt RequireOrder options args of + (opts, args', [] ) -> do + config <- processConfig def opts + return (config, args') + (_, _, _:_) -> return (def, args) + +processConfig :: Config -> [Option] -> IO Config +processConfig = foldM processOneOption + where + processOneOption config NoRaw = do + return $ config {noRaw = True} + processOneOption config Variable = do + return $ config {variable = True} + processOneOption config IntData = do + return $ config {intData = True} + processOneOption config (Label s) = do + return $ config {label = LC.pack s} + processOneOption config (Rate s) = do + return $ config {rate = read s} + processOneOption config (Watermark s) = do + return $ config {wmLevel = read s} + +------------------------------------------------------------ + +zoomGen :: Command () +zoomGen = defCmd { + cmdName = "gen" + , cmdHandler = zoomGenHandler + , cmdCategory = "Writing" + , cmdShortDesc = "Generate floating-point zoom-cache data" + , cmdExamples = [("Generate a file called foo.zxd", "foo.zxd")] + } + +zoomGenHandler :: App () () +zoomGenHandler = do + (config, filenames) <- liftIO . processArgs =<< appArgs + liftIO $ zoomWriteFile config filenames + +zoomWriteFile :: Config -> [FilePath] -> IO () +zoomWriteFile _ [] = return () +zoomWriteFile Config{..} (path:_) + | intData = w ZInt ints path + | otherwise = w ZDouble doubles path + where + w :: (ZoomWrite a, ZoomWrite (TimeStamp, a)) + => TrackType -> [a] -> FilePath -> IO () + w ztype d + | variable = withFileWrite (oneTrackVariable ztype label) + (not noRaw) + (sW >> mapM_ (write 1) (zip (map TS [1,3..]) d)) + | otherwise = withFileWrite (oneTrack ztype rate' label) + (not noRaw) + (sW >> mapM_ (write 1) d) + rate' = fromInteger rate + sW = setWatermark 1 wmLevel + +------------------------------------------------------------ + +doubles :: [Double] +doubles = take 1000000 $ map ((* 1000.0) . sin) [0.0, 0.01 ..] + +ints :: [Int] +ints = map round doubles + +------------------------------------------------------------ + +zoomInfo :: Command () +zoomInfo = defCmd { + cmdName = "info" + , cmdHandler = zoomInfoHandler + , cmdCategory = "Reading" + , cmdShortDesc = "Display basic info about a zoom-cache file" + , cmdExamples = [("Display info about foo.zxd", "foo.zxd")] + } + +zoomInfoHandler :: App () () +zoomInfoHandler = mapM_ (liftIO . zoomInfoFile) =<< appArgs + +------------------------------------------------------------ + +zoomDump :: Command () +zoomDump = defCmd { + cmdName = "dump" + , cmdHandler = zoomDumpHandler + , cmdCategory = "Reading" + , cmdShortDesc = "Read zoom-cache data" + , cmdExamples = [("Yo", "")] + } + +zoomDumpHandler :: App () () +zoomDumpHandler = mapM_ (liftIO . zoomDumpFile) =<< appArgs + +------------------------------------------------------------ + +zoomSummary :: Command () +zoomSummary = defCmd { + cmdName = "summary" + , cmdHandler = zoomSummaryHandler + , cmdCategory = "Reading" + , cmdShortDesc = "Read zoom-cache summary data" + , cmdExamples = [("Read summary level 3 from foo.zxd", "3 foo.zxd")] + } + +zoomSummaryHandler :: App () () +zoomSummaryHandler = liftIO . f =<< appArgs + where + f (lvl:paths) = mapM_ (zoomDumpSummaryLevel (read lvl)) paths + f _ = putStrLn "Usage: zoom-cache summary n file.zxd" + +------------------------------------------------------------ +-- The Application +-- + +zoom :: Application () () +zoom = def { + appName = "zoom" + , appVersion = "0.1" + , appAuthors = ["Conrad Parker"] + , appBugEmail = "conrad@metadecks.org" + , appShortDesc = "Trivial zoom-cache inspection tools" + , appLongDesc = longDesc + , appCategories = ["Reading", "Writing"] + , appSeeAlso = [""] + , appProject = "Zoom" + , appCmds = [ zoomGen + , zoomInfo + , zoomDump + , zoomSummary + ] + } + +longDesc :: String +longDesc = "Manipulate zoom-cache files" + +------------------------------------------------------------ +-- Main +-- + +main :: IO () +main = appMain zoom diff --git a/zoom-cache.cabal b/zoom-cache.cabal new file mode 100644 --- /dev/null +++ b/zoom-cache.cabal @@ -0,0 +1,88 @@ +-- zoom-cabal.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: zoom-cache + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1.0.0 + +-- A short (one-line) description of the package. +Synopsis: A streamable, seekable, zoomable cache file format + +-- A longer description of the package. +Description: This library provides a monadic writing and iteratee reading + interface for zoom-cache files. + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Conrad Parker + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: conrad@metadecks.org + +-- A copyright notice. +-- Copyright: + +-- Stability of the pakcage (experimental, provisional, stable...) +Stability: Experimental + +Category: Development + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + + +Library + -- Modules exported by the library. + Exposed-modules: Data.ZoomCache.Common + Data.ZoomCache.Packet + Data.ZoomCache.Pretty + Data.ZoomCache.Read + Data.ZoomCache.Summary + Data.ZoomCache.Write + Data.Iteratee.ZoomCache + + -- Packages needed in order to build this package. + -- Build-depends: + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +Executable zoom-cache + Main-is: zoom-cache.hs + Hs-Source-Dirs: ., tools + Build-Depends: base < 5, + blaze-builder, + bytestring, + containers, + data-default, + iteratee >= 0.8.0, + MonadCatchIO-transformers, + mtl >= 2.0.0.0 && < 3, + ui-command + +------------------------------------------------------------------------ +-- Git repo +-- +source-repository head + type: git + location: git://github.com/kfish/zoom-cache.git +