diff --git a/Development/Shake/Binary.hs b/Development/Shake/Binary.hs --- a/Development/Shake/Binary.hs +++ b/Development/Shake/Binary.hs @@ -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 diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs --- a/Development/Shake/Database.hs +++ b/Development/Shake/Database.hs @@ -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 diff --git a/Development/Shake/Storage.hs b/Development/Shake/Storage.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Storage.hs @@ -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 diff --git a/Development/Shake/Value.hs b/Development/Shake/Value.hs --- a/Development/Shake/Value.hs +++ b/Development/Shake/Value.hs @@ -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 diff --git a/Examples/Test/Random.hs b/Examples/Test/Random.hs --- a/Examples/Test/Random.hs +++ b/Examples/Test/Random.hs @@ -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 diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -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