shake 0.2.11 → 0.3
raw patch · 6 files changed
+248/−221 lines, 6 files
Files
- Development/Shake/Binary.hs +5/−0
- Development/Shake/Database.hs +38/−210
- Development/Shake/Storage.hs +181/−0
- Development/Shake/Value.hs +9/−1
- Examples/Test/Random.hs +13/−9
- shake.cabal +2/−1
Development/Shake/Binary.hs view
@@ -18,3 +18,8 @@ instance BinaryWith ctx a => BinaryWith ctx [a] where putWith ctx xs = put (length xs) >> mapM_ (putWith ctx) xs getWith ctx = do n <- get; replicateM n $ getWith ctx++instance BinaryWith ctx a => BinaryWith ctx (Maybe a) where+ putWith ctx Nothing = putWord8 0+ putWith ctx (Just x) = putWord8 1 >> putWith ctx x+ getWith ctx = do i <- getWord8; if i == 0 then return Nothing else fmap Just $ getWith ctx
Development/Shake/Database.hs view
@@ -1,11 +1,6 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}-{--Files stores the meta-data so its very important its always accurate-We can't rely on getting a Ctrl+C at the end, so we'd better write out a journal-But if we do happen to get a Ctrl+C then that is very handy-The journal is idempotent, i.e. if we replay the journal twice all is good--}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Development.Shake.Database( Time, startTime, Duration, duration, Trace,@@ -18,44 +13,28 @@ import Development.Shake.Pool import Development.Shake.Value import Development.Shake.Locks+import Development.Shake.Storage +import Control.DeepSeq+import Data.Hashable+import Data.Typeable import Prelude hiding (catch)-import Control.Arrow import Control.Exception import Control.Monad-import Data.Binary.Get-import Data.Binary.Put-import Data.Char import qualified Data.HashMap.Strict as Map import Data.IORef import Data.Maybe import Data.List import Data.Time.Clock-import System.Directory-import System.FilePath-import System.IO --- we want readFile/writeFile to be byte orientated, not do windows line end conversion-import qualified Data.ByteString.Lazy as LBS (readFile,writeFile)-import qualified Data.ByteString.Lazy.Char8 as LBS hiding (readFile,writeFile)----- Increment every time the on-disk format/semantics change,--- @i@ is for the users version number-databaseVersion i = "SHAKE-DATABASE-2-" ++ show (i :: Int) ++ "\r\n"-journalVersion i = "SHAKE-JOURNAL-2-" ++ show (i :: Int) ++ "\r\n"---removeFile_ :: FilePath -> IO ()-removeFile_ x = catch (removeFile x) (\(e :: SomeException) -> return ())- type Map = Map.HashMap --------------------------------------------------------------------- -- UTILITY TYPES -newtype Step = Step Int deriving (Eq,Ord,Show)+-- FIXME: Binary instance writes out 8 bytes, probably should be 2+newtype Step = Step Int deriving (Eq,Ord,Show,Binary,NFData,Hashable,Typeable) incStep (Step i) = Step $ i + 1 @@ -92,9 +71,7 @@ {lock :: Lock ,status :: IORef (Map Key Status) ,step :: Step- ,journal :: Journal- ,filename :: FilePath- ,version :: Int -- user supplied version+ ,journal :: Key -> Maybe Result -> IO () ,logger :: String -> IO () -- logging function } @@ -105,6 +82,7 @@ | Waiting Pending (Maybe Result) -- Currently checking if I am valid or building deriving Show +-- FIXME: Probably want Step's to be strict and unpacked? Benchmark on a large example data Result = Result {result :: Value -- the result associated with the Key ,built :: Step -- when it was actually run@@ -237,7 +215,10 @@ case ans of Ready r -> do logger $ "result " ++ atom k ++ " = " ++ atom (result r)- appendJournal journal k r -- leave the DB lock before appending+ journal k $ Just r -- leave the DB lock before appending+ Error _ -> do+ logger $ "result " ++ atom k ++ " = error"+ journal k Nothing _ -> return () k #= w @@ -329,194 +310,41 @@ special k = s == "AlwaysRun" || "Oracle " `isPrefixOf` s where s = show k ------------------------------------------------------------------------- DATABASE -withDatabase :: (String -> IO ()) -> FilePath -> Int -> (Database -> IO a) -> IO a-withDatabase logger filename version act = do- -- expand the filename, in case pwd has changed by the close action- -- filename <- canonicalizePath filename- bracket (openDatabase logger filename version) closeDatabase act----- Files are named based on the FilePath, but with different extensions,--- such as .database, .journal, .trace-openDatabase :: (String -> IO ()) -> FilePath -> Int -> IO Database-openDatabase logger filename version = do- let dbfile = filename <.> "database"- jfile = filename <.> "journal"- createDirectoryIfMissing True $ takeDirectory dbfile-- lock <- newLock- logger $ "readDatabase " ++ dbfile- (step, status) <- readDatabase dbfile version- step <- return $ incStep step-- b <- doesFileExist jfile- (status,step) <- if not b then return (status,step) else do- logger $ "replayJournal " ++ jfile- status <- replayJournal jfile version status- removeFile_ jfile- -- the journal potentially things at the current step, so increment my step- writeDatabase dbfile version step status- logger $ "rewriteDatabase " ++ jfile- return (status, incStep step)-- status <- newIORef status- journal <- openJournal jfile version- logger "openDatabase complete"- return Database{..}---closeDatabase :: Database -> IO ()-closeDatabase Database{..} = do- status <- readIORef status- let dbfile = filename <.> "database"- logger $ "writeDatabase " ++ dbfile- writeDatabase dbfile version step status- logger $ "closeJournal"- closeJournal journal- logger "closeDatabase complete"---writeDatabase :: FilePath -> Int -> Step -> Map Key Status -> IO ()-writeDatabase file version step status = do- ws <- currentWitness- LBS.writeFile file $- LBS.pack (databaseVersion version) `LBS.append`- encode (step, Witnessed ws $ Statuses status)---readDatabase :: FilePath -> Int -> IO (Step, Map Key Status)-readDatabase file version = do- let zero = (Step 1, Map.fromList [])- b <- doesFileExist file- if not b- then return zero- else catch (do- src <- readFileVer file $ databaseVersion version- let (a,b) = decode src- c = fromStatuses $ fromWitnessed b- -- FIXME: The LBS.length shouldn't be necessary, but it is- a `seq` c `seq` LBS.length src `seq` return (a,c)) $- \(err :: SomeException) -> do- putStrLn $ unlines $- ("Error when reading Shake database " ++ file) :- map (" "++) (lines $ show err) ++- ["All files will be rebuilt"]- removeFile_ file -- so it doesn't error next time- return zero-- ------------------------------------------------------------------------ JOURNAL--data Journal = Journal- {handle :: Var (Maybe Handle)- ,journalFile :: FilePath- ,witness :: Witness- }--openJournal :: FilePath -> Int -> IO Journal-openJournal journalFile ver = do- h <- openBinaryFile journalFile WriteMode- hSetFileSize h 0- LBS.hPut h $ LBS.pack $ journalVersion ver- witness <- currentWitness- writeChunk h $ encode witness- hFlush h- handle <- newVar $ Just h- return Journal{..}---replayJournal :: FilePath -> Int -> Map Key Status -> IO (Map Key Status)-replayJournal file ver mp = catch (do- src <- readFileVer file $ journalVersion ver- let ws:rest = readChunks src- ws :: Witness <- return $ decode ws- rest <- return $ map (runGet (getWith ws)) rest- return $ foldl' (\mp (k,v) -> Map.insert k (Loaded v) mp) mp rest)- $ \(err :: SomeException) -> do- putStrLn $ unlines $- ("Error when reading Shake journal " ++ file) :- map (" "++) (lines $ show err) ++- ["All files built in the last exceution will be rebuilt"]- return mp+-- STORAGE +-- To simplify journaling etc we smuggle the Step in the database, with a special StepKey+newtype StepKey = StepKey ()+ deriving (Show,Eq,Typeable,Hashable,Binary,NFData) -appendJournal :: Journal -> Key -> Result -> IO ()-appendJournal Journal{..} k i = modifyVar_ handle $ \v -> case v of- Nothing -> return Nothing- Just h -> do- writeChunk h $ runPut $ putWith witness (k,i)- return $ Just h+stepKey :: Key+stepKey = newKey $ StepKey () +toStepResult :: Step -> Result+toStepResult i = Result (newValue i) i i [] 0 [] -closeJournal :: Journal -> IO ()-closeJournal Journal{..} =- modifyVar_ handle $ \v -> case v of- Nothing -> return Nothing- Just h -> do- hClose h- removeFile_ journalFile- return Nothing+fromStepResult :: Result -> Step+fromStepResult = fromValue . result ------------------------------------------------------------------------- SERIALISATION--instance Binary Step where- put (Step i) = put i- get = fmap Step get+withDatabase :: (String -> IO ()) -> FilePath -> Int -> (Database -> IO a) -> IO a+withDatabase logger filename version act = do+ registerWitness $ StepKey ()+ registerWitness $ Step 0+ witness <- currentWitness+ withStorage logger filename version witness $ \mp journal -> do+ status <- newIORef $ Map.map Loaded mp+ let step = maybe (Step 1) (incStep . fromStepResult) $ Map.lookup stepKey mp+ journal stepKey $ Just $ toStepResult step+ lock <- newLock+ act Database{..} -data Witnessed a = Witnessed Witness a-fromWitnessed (Witnessed _ x) = x--instance BinaryWith Witness a => Binary (Witnessed a) where- put (Witnessed ws x) = put ws >> putWith ws x- get = do ws <- get; x <- getWith ws; return $ Witnessed ws x---- Only for serialisation-newtype Statuses = Statuses {fromStatuses :: Map Key Status}--instance BinaryWith Witness Statuses where- putWith ws (Statuses x) = putWith ws [(k,i) | (k,v) <- Map.toList x, Just i <- [getResult v]]- getWith ws = do- x <- getWith ws- return $ Statuses $ Map.fromList $ map (second Loaded) x+instance BinaryWith Witness Step where+ putWith _ x = put x+ getWith _ = get instance BinaryWith Witness Result where putWith ws (Result x1 x2 x3 x4 x5 x6) = putWith ws x1 >> put x2 >> put x3 >> putWith ws x4 >> put x5 >> put x6 getWith ws = do x1 <- getWith ws; x2 <- get; x3 <- get; x4 <- getWith ws; x5 <- get; x6 <- get; return $ Result x1 x2 x3 x4 x5 x6---readFileVer :: FilePath -> String -> IO LBS.ByteString-readFileVer file ver = do- let ver2 = LBS.pack ver- src <- LBS.readFile file- unless (ver2 `LBS.isPrefixOf` src) $ do- let bad = LBS.takeWhile (\x -> isAlphaNum x || x `elem` "-_ ") $ LBS.take 50 src- error $ "Invalid version stamp\n" ++- "Expected: " ++ ver ++ "\n" ++- "Got : " ++ LBS.unpack bad- return $ LBS.drop (fromIntegral $ length ver) src---readChunks :: LBS.ByteString -> [LBS.ByteString]-readChunks x- | Just (n, x) <- grab 4 x- , Just (y, x) <- grab (fromIntegral (decode n :: Word32)) x- = y : readChunks x- | otherwise = []- where- grab i x | LBS.length a == i = Just (a, b)- | otherwise = Nothing- where (a,b) = LBS.splitAt i x---writeChunk :: Handle -> LBS.ByteString -> IO ()-writeChunk h x = do- let n = encode (fromIntegral $ LBS.length x :: Word32)- LBS.hPut h $ n `LBS.append` x- hFlush h
+ Development/Shake/Storage.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-+This module stores the meta-data so its very important its always accurate+We can't rely on getting any exceptions or termination at the end, so we'd better write out a journal+We store a series of records, and if they contain twice as many records as needed, we compress+-}++module Development.Shake.Storage(+ withStorage+ ) where++import Development.Shake.Binary+import Development.Shake.Locks++import Prelude hiding (catch)+import Control.Arrow+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Binary.Get+import Data.Binary.Put+import Data.Char+import Data.Hashable+import qualified Data.HashMap.Strict as Map+import Data.List+import System.Directory+import System.Exit+import System.FilePath+import System.IO++import qualified Data.ByteString.Lazy.Char8 as LBS+++type Map = Map.HashMap++-- Increment every time the on-disk format/semantics change,+-- @i@ is for the users version number+databaseVersion i = "SHAKE-DATABASE-4-" ++ show (i :: Int) ++ "\r\n"+++withStorage+ :: (Eq w, Eq k, Hashable k+ ,Binary w, BinaryWith w k, BinaryWith w v)+ => (String -> IO ()) -- ^ Logging function+ -> FilePath -- ^ File prefix to use+ -> Int -- ^ User supplied version number+ -> w -- ^ Witness+ -> (Map k v -> (k -> Maybe v -> IO ()) -> IO a) -- ^ Execute+ -> IO a+withStorage logger file version witness act = do+ let dbfile = file <.> "database"+ bupfile = file <.> "bup"+ createDirectoryIfMissing True $ takeDirectory file++ -- complete a partially failed compress+ b <- doesFileExist bupfile+ when b $ do+ logger $ "Backup file move to original"+ catch (removeFile dbfile) (\(e :: SomeException) -> return ())+ renameFile bupfile dbfile++ withBinaryFile dbfile ReadWriteMode $ \h -> do+ n <- hFileSize h+ logger $ "Reading file of size " ++ show n+ src <- LBS.hGet h $ fromInteger n++ if not $ ver `LBS.isPrefixOf` src then do+ unless (LBS.null src) $ do+ let good x = isAlphaNum x || x `elem` "-_ "+ let bad = LBS.takeWhile good $ LBS.take 50 src+ putStr $ unlines+ ["Error when reading Shake database " ++ dbfile+ ," Invalid version stamp detected"+ ," Expected: " ++ takeWhile good (LBS.unpack ver)+ ," Found : " ++ LBS.unpack bad+ ,"All files will be rebuilt"]+ continue h Map.empty+ else+ -- make sure you are not handling exceptions from inside+ join $ handleJust (\e -> if asyncException e then Nothing else Just e) (\err -> do+ msg <- showException err+ putStrLn $ unlines $+ ("Error when reading Shake database " ++ dbfile) :+ map (" "++) (lines msg) +++ ["All files will be rebuilt"]+ -- exitFailure -- should never happen without external corruption+ -- add back to check during random testing+ return $ continue h Map.empty) $+ case readChunks $ LBS.drop (LBS.length ver) src of+ (slop, []) -> do+ logger $ "Read 0 chunks, plus " ++ show slop ++ " slop"+ return $ continue h Map.empty+ (slop, w:xs) -> do+ logger $ "Read " ++ show (length xs + 1) ++ " chunks, plus " ++ show slop ++ " slop"+ logger $ "Chunk sizes " ++ show (map LBS.length (w:xs))+ let ws = decode w+ f mp (k, Nothing) = Map.delete k mp+ f mp (k, Just v ) = Map.insert k v mp+ mp = foldl' f Map.empty $ map (runGet $ getWith ws) xs+ -- if mp is null, continue will reset it, so no need to clean up+ if Map.null mp || (ws == witness && Map.size mp * 2 > length xs - 2) then do+ -- make sure we reset to before the slop+ when (not (Map.null mp) && slop /= 0) $ do+ logger $ "Dropping last " ++ show slop ++ " bytes of database (incomplete)"+ now <- hFileSize h+ hSetFileSize h $ now - slop+ hSeek h AbsoluteSeek $ now - slop+ hFlush h+ logger $ "Drop complete"+ return $ continue h mp+ else do+ logger "Compressing database"+ hClose h -- two hClose are fine+ return $ do+ renameFile dbfile bupfile+ withBinaryFile dbfile ReadWriteMode $ \h -> do+ reset h mp+ removeFile bupfile+ logger "Compression complete"+ continue h mp+ where+ ver = LBS.pack $ databaseVersion version++ writeChunk h s = do+ logger $ "Writing chunk " ++ show (LBS.length s)+ LBS.hPut h $ toChunk s++ reset h mp = do+ logger $ "Resetting database to " ++ show (Map.size mp) ++ " elements"+ hSetFileSize h 0+ hSeek h AbsoluteSeek 0+ LBS.hPut h ver+ writeChunk h $ encode witness+ mapM_ (writeChunk h . runPut . putWith witness . second Just) $ Map.toList mp+ hFlush h+ logger "Flush"++ -- continuation (since if we do a compress, h changes)+ continue h mp = do+ when (Map.null mp) $+ reset h mp -- might as well, no data to lose, and need to ensure a good witness table+ lock <- newLock+ act mp $ \k v -> do+ -- QUESTION: Should the logging be on a different thread? Does that reduce blocking?+ withLock lock $ writeChunk h $ runPut $ putWith witness (k,v)+ hFlush h+ logger "Flush"+++-- Return the amount of junk at the end, along with all the chunk+readChunks :: LBS.ByteString -> (Integer, [LBS.ByteString])+readChunks x+ | Just (n, x) <- grab 4 x+ , Just (y, x) <- grab (fromIntegral (decode n :: Word32)) x+ = second (y :) $ readChunks x+ | otherwise = (toInteger $ LBS.length x, [])+ where+ grab i x | LBS.length a == i = Just (a, b)+ | otherwise = Nothing+ where (a,b) = LBS.splitAt i x+++toChunk :: LBS.ByteString -> LBS.ByteString+toChunk x = n `LBS.append` x+ where n = encode (fromIntegral $ LBS.length x :: Word32)+++-- Some exceptions may have an error message which is itself an exception,+-- make sure you show them properly+showException :: SomeException -> IO String+showException err = do+ let msg = show err+ catch (evaluate $ rnf msg `seq` msg) (\(_ :: SomeException) -> return "Unknown exception (error while showing error message)")+++-- | Is the exception asyncronous, not a "coding error" that should be ignored+asyncException :: SomeException -> Bool+asyncException e+ | Just (_ :: AsyncException) <- fromException e = True+ | Just (_ :: ExitCode) <- fromException e = True+ | otherwise = False
Development/Shake/Value.hs view
@@ -83,6 +83,10 @@ ,witnessOut :: Map.HashMap TypeRep Int -- for writing out, find the value } +instance Eq Witness where+ -- type names are ordered by the Map (on hash), so likely to remain reasonably consistent+ -- regardless of the order of registerWitness calls+ a == b = typeNames a == typeNames b currentWitness :: IO Witness currentWitness = do@@ -101,6 +105,7 @@ instance BinaryWith Witness Value where+ -- FIXME: Should probably be writing out bytes, rather than 64 bit Int's putWith ws (Value x) = do let msg = "Internal error, could not find witness type for " ++ show (typeOf x) put $ fromMaybe (error msg) $ Map.lookup (typeOf x) (witnessOut ws)@@ -109,9 +114,12 @@ getWith ws = do h <- get case Map.lookup h $ witnessIn ws of- Nothing -> error $+ Nothing | h >= 0 && h < length (typeNames ws) -> error $ "Failed to find a type " ++ (typeNames ws !! fromIntegral h) ++ " which is stored in the database.\n" ++ "The most likely cause is that your build tool has changed significantly."+ Nothing -> error $+ -- should not happen, unless proper data corruption+ "Corruption when reading Value, got type " ++ show h ++ ", but should be in range 0.." ++ show (length (typeNames ws) - 1) Just (Value t) -> do x <- get return $ Value $ x `asTypeOf` t
Examples/Test/Random.hs view
@@ -7,7 +7,7 @@ import Control.Monad import Data.List import System.Random-import System.Mem+import qualified Data.ByteString.Char8 as BS inputRange = [1..10]@@ -38,34 +38,34 @@ res <- fmap (show . Multiple) $ forM srcs $ \src -> do randomSleep need $ map toFile src- mapM (liftIO . fmap read . readFile . toFile) src+ mapM (liftIO . fmap read . readFileStrict . toFile) src randomSleep writeFileChanged out res test build obj = forM_ [1..] $ \count -> do putStrLn $ "* PERFORMING RANDOM TEST " ++ show count- performGC -- close any handles left by crashing build ["clean"] build [] -- to create the directory- forM inputRange $ \i ->+ forM_ inputRange $ \i -> writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i logic <- randomLogic runLogic [] logic chng <- filterM (const randomIO) inputRange - forM chng $ \i ->+ forM_ chng $ \i -> writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single $ negate i runLogic chng logic- forM inputRange $ \i ->+ forM_ inputRange $ \i -> writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i- logic <- addBang =<< addBang logic+ logicBang <- addBang =<< addBang logic j <- randomRIO (1::Int,8)- res <- try $ build $ ("--threads" ++ show j) : map show (logic ++ [Want [i | Logic i _ <- logic]]) + res <- try $ build $ ("--threads" ++ show j) : map show (logicBang ++ [Want [i | Logic i _ <- logicBang]]) case res of Left err | "BANG" `isInfixOf` show (err :: SomeException) -> return () -- error I expected | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err _ -> return () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt+ runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]] where runLogic :: [Int] -> [Logic] -> IO () runLogic negated xs = do@@ -84,7 +84,7 @@ Output i -> value i forM_ (concat wants) $ \i -> do let wanted = value i- got <- fmap read $ readFile $ obj $ "output-" ++ show i ++ ".txt"+ got <- fmap read $ readFileStrict $ obj $ "output-" ++ show i ++ ".txt" when (wanted /= got) $ error $ "INCORRECT VALUE for " ++ show i @@ -121,3 +121,7 @@ randomElem xs = do i <- randomRIO (0, length xs - 1) return $ xs !! i+++readFileStrict :: FilePath -> IO String+readFileStrict = fmap BS.unpack . BS.readFile
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: shake-version: 0.2.11+version: 0.3 license: BSD3 license-file: LICENSE category: Development@@ -90,6 +90,7 @@ Development.Shake.Pool Development.Shake.Report Development.Shake.Rerun+ Development.Shake.Storage Development.Shake.Value Paths_shake