New TimeLogEntry format, with backwards string reference
authorJoachim Breitner <mail@joachim-breitner.de>
Sun, 28 Feb 2010 20:59:45 +0000 (20:59 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Sun, 28 Feb 2010 20:59:45 +0000 (20:59 +0000)
arbtt.cabal
src/Data.hs
src/Data/Binary/StringRef.hs [new file with mode: 0644]
src/TimeLog.hs

index 3f39068..17d8c3a 100644 (file)
@@ -34,6 +34,7 @@ executable arbtt-capture
         bytestring, binary
     other-modules:
         Data
+        Data.Binary.StringRef
         Capture
         TimeLog
         UpgradeLog1
@@ -64,6 +65,7 @@ executable arbtt-stats
         base == 4.*, parsec == 2.*, containers, pcre-light
     other-modules:
         Data
+        Data.Binary.StringRef
         Categorize
         TimeLog
         Stats
@@ -80,6 +82,7 @@ executable arbtt-dump
         base == 4.*, parsec == 2.*, containers
     other-modules:
         Data
+        Data.Binary.StringRef
         TimeLog
     if os(windows) 
         cpp-options:    -DWIN32
@@ -94,6 +97,7 @@ executable arbtt-recover
         base == 4.*, parsec == 2.*, containers
     other-modules:
         Data
+        Data.Binary.StringRef
         TimeLog
     if os(windows) 
         cpp-options:    -DWIN32
index 019aabc..01671b4 100644 (file)
@@ -8,6 +8,7 @@ import Text.Read (readPrec)
 import Data.Binary
 import Data.Binary.Put
 import Data.Binary.Get
+import Data.Binary.StringRef
 import Control.Applicative
 import Control.Monad
 
@@ -60,17 +61,18 @@ isCategory _   _                        = False
 
 -- Data.Binary instances
 
-instance Binary a => Binary (TimeLogEntry a) where
put tle = do
+instance StringReferencingBinary a => StringReferencingBinary (TimeLogEntry a) where
ls_put strs tle = do
        -- A version tag
        putWord8 1
        put (tlTime tle)
        put (tlRate tle)
-       put (tlData tle)
get = do
+       ls_put strs (tlData tle)
ls_get strs = do
        v <- getWord8
-       when (v /= 1) $ error $ "Wrong TimeLogEntry version tag " ++ show v
-       TimeLogEntry <$> get <*> get <*> get
+       case v of
+        1 -> TimeLogEntry <$> get <*> get <*> ls_get strs
+        _ -> error $ "Unsupported TimeLogEntry version tag " ++ show v
 
 instance Binary UTCTime where
  put (UTCTime (ModifiedJulianDay d) t) = do
@@ -81,13 +83,34 @@ instance Binary UTCTime where
        t <- get
        return $ UTCTime (ModifiedJulianDay d) (fromRational t)
 
-instance Binary CaptureData where
- put cd = do
+instance ListOfStringable CaptureData where
+  listOfStrings = concatMap (\(b,t,p) -> [t,p]) . cWindows
+
+instance StringReferencingBinary CaptureData where
+-- Versions:
+-- 1 First version
+-- 2 Using ListOfStringable
+ ls_put strs cd = do
        -- A version tag
-       putWord8 1
-       put (cWindows cd)
-       put (cLastActivity cd)
get = do
+       putWord8 2
+       ls_put strs (cWindows cd)
+       ls_put strs (cLastActivity cd)
ls_get strs = do
        v <- getWord8
-       when (v /= 1) $ error $ "Wrong CaptureData version tag " ++ show v
-       CaptureData <$> get <*> get
+       case v of
+        1 -> CaptureData <$> get <*> get
+        2 -> CaptureData <$> ls_get strs <*> ls_get strs
+        _ -> error $ "Unsupported CaptureData version tag " ++ show v
+
+  -- | 'getMany n' get 'n' elements in order, without blowing the stack.
+  --   From Data.Binary
+getMany :: Binary a => Int -> Get [a]
+getMany n = go [] n
+ where
+    go xs 0 = return $! reverse xs
+    go xs i = do x <- get
+                 -- we must seq x to avoid stack overflows due to laziness in
+                 -- (>>=)
+                 x `seq` go (x:xs) (i-1)
+{-# INLINE getMany #-}
+
diff --git a/src/Data/Binary/StringRef.hs b/src/Data/Binary/StringRef.hs
new file mode 100644 (file)
index 0000000..09fecb5
--- /dev/null
@@ -0,0 +1,93 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances, OverlappingInstances#-}
+
+module Data.Binary.StringRef 
+       ( ListOfStringable(..)
+       , StringReferencingBinary(..)
+       , ls_encode
+       , ls_decode
+       ) where
+
+import Data.Binary
+import Data.Binary.Put
+import Data.Binary.Get
+import Control.Monad
+import Data.List
+import Data.ByteString.Lazy (ByteString)
+
+class StringReferencingBinary a => ListOfStringable a where
+  listOfStrings :: a -> [String]
+
+-- | An extended version of Binary that passes the list of strings of the
+-- previous sample
+class StringReferencingBinary a where
+ ls_put :: [String] -> a -> Put
+ ls_get :: [String] -> Get a
+
+------------------------------------------------------------------------
+-- Instances for the first few tuples
+
+instance (StringReferencingBinary a, StringReferencingBinary b) => StringReferencingBinary (a,b) where
+    ls_put strs (a,b)           = ls_put strs a >> ls_put strs b
+    ls_get strs                 = liftM2 (,) (ls_get strs) (ls_get strs)
+
+instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c) => StringReferencingBinary (a,b,c) where
+    ls_put strs (a,b,c)         = ls_put strs a >> ls_put strs b >> ls_put strs c
+    ls_get strs                 = liftM3 (,,) (ls_get strs) (ls_get strs) (ls_get strs)
+
+instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d) => StringReferencingBinary (a,b,c,d) where
+    ls_put strs (a,b,c,d)       = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d
+    ls_get strs                 = liftM4 (,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs)
+
+instance (StringReferencingBinary a, StringReferencingBinary b, StringReferencingBinary c, StringReferencingBinary d, StringReferencingBinary e) => StringReferencingBinary (a,b,c,d,e) where
+    ls_put strs (a,b,c,d,e)     = ls_put strs a >> ls_put strs b >> ls_put strs c >> ls_put strs d >> ls_put strs e
+    ls_get strs                 = liftM5 (,,,,) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs) (ls_get strs)
+
+
+instance StringReferencingBinary a => StringReferencingBinary [a] where
+    ls_put strs l  = ls_put strs (length l) >> mapM_ (ls_put strs) l
+    ls_get strs    = do n <- (ls_get strs) :: Get Int
+                        ls_getMany strs n
+
+-- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack.
+ls_getMany :: StringReferencingBinary a => [String] -> Int -> Get [a]
+ls_getMany strs n = go [] n
+ where
+    go xs 0 = return $! reverse xs
+    go xs i = do x <- ls_get strs
+                 -- we must seq x to avoid stack overflows due to laziness in
+                 -- (>>=)
+                 x `seq` go (x:xs) (i-1)
+{-# INLINE ls_getMany #-}
+
+instance StringReferencingBinary String where
+       ls_put strs s = case elemIndex s strs of
+               Just i | 0 <= i && i  < 255 - 2 ->
+                       put (fromIntegral (succ i) :: Word8)
+               _ ->    put (0 :: Word8) >> put s
+       ls_get strs = do
+               tag <- get
+               case tag :: Word8 of
+                 0 -> get
+                 i -> return $! strs !! fromIntegral (pred i)
+
+{-
+instance Binary a => StringReferencingBinary a where
+       ls_put _ = put
+       ls_get _ = get
+-}
+
+instance StringReferencingBinary Char where { ls_put _ = put; ls_get _ = get }
+instance StringReferencingBinary Int  where { ls_put _ = put; ls_get _ = get }
+instance StringReferencingBinary Integer  where { ls_put _ = put; ls_get _ = get }
+instance StringReferencingBinary Bool  where { ls_put _ = put; ls_get _ = get }
+
+ls_encode :: StringReferencingBinary a => [String] -> a -> ByteString
+ls_encode strs = runPut . ls_put strs
+{-# INLINE ls_encode #-}
+
+-- | Decode a value from a lazy ByteString, reconstructing the original structure.
+--
+ls_decode :: StringReferencingBinary a => [String] -> ByteString -> a
+ls_decode strs = runGet (ls_get strs)
+
+
index 83922aa..731b6af 100644 (file)
@@ -8,6 +8,7 @@ import Control.Concurrent
 import Control.Monad
 import Data.Time
 import Data.Binary
+import Data.Binary.StringRef
 import Data.Binary.Get
 import Data.Function
 import Data.Char
@@ -22,28 +23,34 @@ magic = BS.pack $ map (fromIntegral.ord) "arbtt-timelog-v1\n"
 
 -- | Runs the given action each delay milliseconds and appends the TimeLog to the
 -- given file.
-runLogger :: Binary a => FilePath -> Integer -> IO a -> IO ()
-runLogger filename delay action = forever $ do
+runLogger :: ListOfStringable a => FilePath -> Integer -> IO a -> IO ()
+runLogger filename delay action = flip fix Nothing $ \loop prev -> do
        entry <- action
        date <- getCurrentTime
        createTimeLog False filename
-       appendTimeLog filename (TimeLogEntry date delay entry)
+       appendTimeLog filename prev (TimeLogEntry date delay entry)
        threadDelay (fromIntegral delay * 1000)
+       loop (Just entry)
+
        
 createTimeLog :: Bool -> FilePath -> IO ()
 createTimeLog force filename = do
        ex <- doesFileExist filename
        when (not ex || force) $ BS.writeFile filename magic
 
-appendTimeLog :: Binary a => FilePath -> TimeLogEntry a -> IO ()
-appendTimeLog filename = BS.appendFile filename . encode
+appendTimeLog :: ListOfStringable a => FilePath -> Maybe a -> TimeLogEntry a -> IO ()
+appendTimeLog filename prev = BS.appendFile filename . ls_encode strs
+  where strs = maybe [] listOfStrings prev
 
-writeTimeLog :: Binary a => FilePath -> TimeLog a -> IO ()
-writeTimeLog filename tl = do createTimeLog True filename
-                             mapM_ (appendTimeLog filename) tl
+writeTimeLog :: ListOfStringable a => FilePath -> TimeLog a -> IO ()
+writeTimeLog filename tl = do
+       createTimeLog True filename
+       foldM_ go  Nothing tl
+  where go prev v = do appendTimeLog filename prev v
+                      return (Just (tlData v))
 
 -- | This might be very bad style, and it hogs memory, but it might help in some situations...
-recoverTimeLog :: Binary a => FilePath -> IO (TimeLog a)
+recoverTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a)
 recoverTimeLog filename = do
        content <- BS.readFile filename
         start content
@@ -53,15 +60,16 @@ recoverTimeLog filename = do
                  then do putStrLn $ "WARNING: Timelog starts with unknown marker " ++
                                show (map (chr.fromIntegral) (BS.unpack startString))
                  else do putStrLn $ "Found header, continuing... (" ++ show (BS.length rest) ++ " bytes to go)"
-               go rest off
-        go input off = do mb <- tryGet False input off
-                         flip (maybe (return [])) mb $
-                               \(v,rest,off') -> if BS.null rest
-                                                 then return [v]
-                                                 else (v :) <$> go rest off'
-       tryGet retrying input off = catch (
+               go Nothing rest off
+        go prev input off = do
+               mb <- tryGet prev False input off
+               flip (maybe (return [])) mb $ \(v,rest,off') ->
+                       if BS.null rest
+                       then return [v]
+                       else (v :) <$> go (Just (tlData v)) rest off'
+       tryGet prev retrying input off = catch (
                        do -- putStrLn $ "Trying value at offset " ++ show off
-                          let (v,rest,off') = runGetState get input off
+                          let (v,rest,off') = runGetState (ls_get strs) input off
                           evaluate rest
                           when retrying $
                                putStrLn $ "Succesfully read value at position " ++ show off
@@ -74,21 +82,24 @@ recoverTimeLog filename = do
                             then do putStrLn $ "End of file reached"
                                     return Nothing
                             else do putStrLn $ "Trying at position " ++ show (off+1) ++ "."
-                                    tryGet True (BS.tail input) (off+1)
+                                    tryGet prev True (BS.tail input) (off+1)
                        )
+         where strs = maybe [] listOfStrings prev
 
-readTimeLog :: Binary a => FilePath -> IO (TimeLog a)
+readTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a)
 readTimeLog filename = do
        content <- BS.readFile filename
         return $ runGet start content
   where start = do
                startString <- getLazyByteString (BS.length magic)
                if startString == magic
-                then go
+                then go Nothing
                 else error $
                        "Timelog starts with unknown marker " ++
                        show (map (chr.fromIntegral) (BS.unpack startString))
-        go = do v <- get
-               m <- isEmpty
-               if m then return [v]
-                    else (v :) <$> go
+        go prev = do v <- ls_get strs
+                    m <- isEmpty
+                    if m then return [v]
+                         else (v :) <$> go (Just (tlData v))
+         where strs = maybe [] listOfStrings prev
+