Whitespace cleanup
[darcs-mirror-arbtt.git] / src / TimeLog.hs
1 module TimeLog where
2
3 import Data
4
5 import Control.Applicative
6 import System.IO
7 import Control.Concurrent
8 import Control.Monad
9 import Data.Time
10 import Data.Binary
11 import Data.Binary.StringRef
12 import Data.Binary.Get
13 import Data.Function
14 import Data.Char
15 import System.Directory
16 import Control.Exception
17 import Prelude hiding (catch)
18 import Control.DeepSeq
19 import System.Posix.Files
20 import System.IO.Unsafe (unsafeInterleaveIO)
21
22 import qualified Data.ByteString.Lazy as BS
23 import Data.Maybe
24
25 magic = BS.pack $ map (fromIntegral.ord) "arbtt-timelog-v1\n"
26
27 mkTimeLogEntry :: Integer -> a -> IO (TimeLogEntry a)
28 mkTimeLogEntry delay entry = do
29     date <- getCurrentTime
30     return $ TimeLogEntry date delay entry
31
32
33 -- | Runs the given action each delay milliseconds and appends the TimeLog to the
34 -- given file.
35 runLogger :: ListOfStringable a => FilePath -> Integer -> IO a -> IO ()
36 runLogger filename delay action = flip fix Nothing $ \loop prev -> do
37         entry <- action
38         tle <- mkTimeLogEntry delay entry
39
40         createTimeLog False filename
41         setFileMode filename (ownerReadMode `unionFileModes` ownerWriteMode)
42         appendTimeLog filename prev tle
43         threadDelay (fromIntegral delay * 1000)
44         loop (Just entry)
45
46         
47 createTimeLog :: Bool -> FilePath -> IO ()
48 createTimeLog force filename = do
49         ex <- doesFileExist filename
50         when (not ex || force) $ BS.writeFile filename magic
51
52 appendTimeLog :: ListOfStringable a => FilePath -> Maybe a -> TimeLogEntry a -> IO ()
53 appendTimeLog filename prev = BS.appendFile filename . ls_encode strs
54   where strs = maybe [] listOfStrings prev
55
56 writeTimeLog :: ListOfStringable a => FilePath -> TimeLog a -> IO ()
57 writeTimeLog filename tl = do
58         createTimeLog True filename
59         foldM_ go  Nothing tl
60   where go prev v = do appendTimeLog filename prev v
61                        return (Just (tlData v))
62
63 -- | This might be very bad style, and it hogs memory, but it might help in some situations...
64 -- Use of unsafeInterleaveIO should be replaced by conduit, pipe or something the like
65 recoverTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a)
66 recoverTimeLog filename = do
67         content <- BS.readFile filename
68         start content
69   where start content = do
70                 let (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) content 0
71                 if startString /= magic
72                   then do putStrLn $ "WARNING: Timelog starts with unknown marker " ++
73                                 show (map (chr.fromIntegral) (BS.unpack startString))
74                   else do putStrLn $ "Found header, continuing... (" ++ show (BS.length rest) ++ " bytes to go)"
75                 go Nothing rest off
76
77         go prev input off = do
78                 mb <- tryGet prev input off off
79                 flip (maybe (return [])) mb $ \(v,rest,off') ->
80                         if BS.null rest
81                         then return [v]
82                         else (v:) <$> (unsafeInterleaveIO $ go (Just (tlData v)) rest off')
83
84         tryGet prev input off orig_off = catch (
85                         do -- putStrLn $ "Trying value at offset " ++ show off
86                            let (v,rest,off') = runGetState (ls_get strs) input off
87                            evaluate rest
88                            when (off /= orig_off) $
89                                 putStrLn $ "Skipped from " ++ show orig_off ++ ", succesful read at position " ++ show off ++ ", lost " ++ show (off - orig_off) ++ " bytes."
90                            return (Just (v,rest,off'))
91                         ) (
92                         \e -> do
93                            putStrLn $ "Failed to read value at position " ++ show off ++ ":"
94                            putStrLn $ "   " ++ show (e :: SomeException)
95                            if BS.length input <= 1
96                              then do putStrLn $ "End of file reached"
97                                      return Nothing
98                              else do tryGet prev (BS.tail input) (off+1) orig_off
99                         )
100           where strs = maybe [] listOfStrings prev
101
102 readTimeLog :: (NFData a, ListOfStringable a) => FilePath -> IO (TimeLog a)
103 readTimeLog filename = do
104         content <- BS.readFile filename
105         return $ parseTimeLog content
106
107 parseTimeLog :: (NFData a, ListOfStringable a) => BS.ByteString -> TimeLog a
108 parseTimeLog input =
109     if startString == magic
110        then go Nothing rest off
111        else error $
112             "Timelog starts with unknown marker " ++
113             show (map (chr.fromIntegral) (BS.unpack startString))
114   where
115     (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) input 0
116     go prev input off =
117         let (v, rest, off') = runGetState (ls_get strs) input off
118         in v `deepseq`
119            if (BS.null rest)
120            then [v]
121            else v : go (Just (tlData v)) rest off'
122       where strs = maybe [] listOfStrings prev
123