zoom-cache (empty) → 0.1.0.0
raw patch · 11 files changed
+1742/−0 lines, 11 filesdep +MonadCatchIO-transformersdep +basedep +blaze-buildersetup-changed
Dependencies added: MonadCatchIO-transformers, base, blaze-builder, bytestring, containers, data-default, iteratee, mtl, ui-command
Files
- Data/Iteratee/ZoomCache.hs +313/−0
- Data/ZoomCache/Common.hs +331/−0
- Data/ZoomCache/Packet.hs +36/−0
- Data/ZoomCache/Pretty.hs +89/−0
- Data/ZoomCache/Read.hs +72/−0
- Data/ZoomCache/Summary.hs +97/−0
- Data/ZoomCache/Write.hs +472/−0
- LICENSE +26/−0
- Setup.hs +4/−0
- tools/zoom-cache.hs +214/−0
- zoom-cache.cabal +88/−0
+ Data/Iteratee/ZoomCache.hs view
@@ -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 <conrad@metadecks.org>+-- 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)
+ Data/ZoomCache/Common.hs view
@@ -0,0 +1,331 @@+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.ZoomCache.Write+-- Copyright : Conrad Parker+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Conrad Parker <conrad@metadecks.org>+-- 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"+
+ Data/ZoomCache/Packet.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.ZoomCache.Write+-- Copyright : Conrad Parker+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Conrad Parker <conrad@metadecks.org>+-- 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]+ }++------------------------------------------------------------
+ Data/ZoomCache/Pretty.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.ZoomCache.Write+-- Copyright : Conrad Parker+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Conrad Parker <conrad@metadecks.org>+-- 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+
+ Data/ZoomCache/Read.hs view
@@ -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 <conrad@metadecks.org>+-- 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 ()+
+ Data/ZoomCache/Summary.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Data.ZoomCache.Write+-- Copyright : Conrad Parker+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Conrad Parker <conrad@metadecks.org>+-- 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"
+ Data/ZoomCache/Write.hs view
@@ -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 <conrad@metadecks.org>+-- 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+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple + +main :: IO () +main = defaultMain
+ tools/zoom-cache.hs view
@@ -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
+ zoom-cache.cabal view
@@ -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+