{-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}
{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}
{-
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 compact
-}

module Development.Shake.Internal.Core.Storage(
    usingStorage
    ) where

import General.Chunks
import General.Cleanup
import General.Binary
import General.Intern
import Development.Shake.Internal.Options
import Development.Shake.Internal.Errors
import General.Timing
import General.FileLock
import qualified General.Ids as Ids

import Control.Exception.Extra
import Control.Monad.Extra
import Data.Monoid
import Data.Either.Extra
import Data.Time
import Data.Char
import Data.Word
import System.Info
import Development.Shake.Classes
import Numeric
import General.Extra
import Data.List.Extra
import Data.Maybe
import System.FilePath
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.HashMap.Strict as Map

import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString as BS8
import Prelude


-- Increment every time the on-disk format/semantics change,
-- @x@ is for the users version number
databaseVersion :: String -> String
-- THINGS I WANT TO DO ON THE NEXT CHANGE
-- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8
-- * Duration and Time should be stored as number of 1/10000th seconds Int32
databaseVersion :: String -> String
databaseVersion String
x = String
"SHAKE-DATABASE-14-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
os String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arch String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r\n"
    where s :: String
s = String -> String
forall a. [a] -> [a]
tailErr (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. HasCallStack => [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. Show a => a -> String
show String
x -- call show, then take off the leading/trailing quotes
                                      -- ensures we do not get \r or \n in the user portion


messageCorrupt :: FilePath -> SomeException -> IO [String]
messageCorrupt :: String -> SomeException -> IO [String]
messageCorrupt String
dbfile SomeException
err = do
    msg <- SomeException -> IO String
forall e. Show e => e -> IO String
showException SomeException
err
    pure $
        ("Error when reading Shake database " ++ dbfile) :
        map ("  "++) (lines msg) ++
        ["All files will be rebuilt"]


messageDatabaseVersionChange :: FilePath -> BS.ByteString -> BS.ByteString -> [String]
messageDatabaseVersionChange :: String -> ByteString -> ByteString -> [String]
messageDatabaseVersionChange String
dbfile ByteString
old ByteString
new =
    [String
"Shake database version changed (either shake library version, or shakeVersion):"
    ,String
"  File:         " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
    ,String
"  Old version:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (String -> String
limit (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
old)
    ,String
"  New version:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (ByteString -> String
BS.unpack ByteString
new)
    ,String
"All rules will be rebuilt"]
    where
        limit :: String -> String
limit String
x = let (String
a,String
b) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
200 String
x in String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then String
"" else String
"...")
        disp :: String -> String
disp = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isPrint Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
x then Char
x else Char
'?') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (String
"\r\n" :: String))


messageMissingTypes :: FilePath -> [String] -> [String]
messageMissingTypes :: String -> [String] -> [String]
messageMissingTypes String
dbfile [String]
types =
    [String
"Shake database rules have changed for the following types:"
    ,String
"  File:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"  Type:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x | String
x <- [String]
types] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    [String
"All rules using these types will be rebuilt"]


-- | Storage of heterogeneous things. In the particular case of Shake,
--   k ~ QTypeRep, v ~ (Key, Status{Value}).
--
--   The storage starts with a witness table saying what can be contained.
--   If any entries in the witness table don't have a current Witness then a fake
--   error witness is manufactured. If the witness ever changes the entire DB is
--   rewritten.
usingStorage
    :: (Show k, Eq k, Hashable k, NFData k, Show v, NFData v)
    => Cleanup
    -> ShakeOptions                                    -- ^ Storage options
    -> (IO String -> IO ())                            -- ^ Logging function
    -> Map.HashMap k (Ver, BinaryOp v)                 -- ^ Witnesses
    -> IO (Ids.Ids v, k -> Id -> v -> IO ())
usingStorage :: forall k v.
(Show k, Eq k, Hashable k, NFData k, Show v, NFData v) =>
Cleanup
-> ShakeOptions
-> (IO String -> IO ())
-> HashMap k (Ver, BinaryOp v)
-> IO (Ids v, k -> Id -> v -> IO ())
usingStorage Cleanup
_ ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
..} IO String -> IO ()
diagnostic HashMap k (Ver, BinaryOp v)
_ | String
shakeFiles String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"/dev/null" = do
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Using in-memory database"
    ids <- IO (Ids v)
forall a. IO (Ids a)
Ids.empty
    pure (ids, \k
_ Id
_ v
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

usingStorage Cleanup
cleanup ShakeOptions{Bool
Int
String
[String]
[(String, String)]
[(Rebuild, String)]
[CmdOption]
Maybe Seconds
Maybe String
Maybe Lint
HashMap TypeRep Dynamic
Verbosity
Change
String -> String -> Bool -> IO ()
IO Progress -> IO ()
Verbosity -> String -> IO ()
shakeExtra :: ShakeOptions -> HashMap TypeRep Dynamic
shakeTrace :: ShakeOptions -> String -> String -> Bool -> IO ()
shakeOutput :: ShakeOptions -> Verbosity -> String -> IO ()
shakeProgress :: ShakeOptions -> IO Progress -> IO ()
shakeAllowRedefineRules :: ShakeOptions -> Bool
shakeNeedDirectory :: ShakeOptions -> Bool
shakeSymlink :: ShakeOptions -> Bool
shakeCloud :: ShakeOptions -> [String]
shakeShare :: ShakeOptions -> Maybe String
shakeColor :: ShakeOptions -> Bool
shakeVersionIgnore :: ShakeOptions -> Bool
shakeLiveFiles :: ShakeOptions -> [String]
shakeCreationCheck :: ShakeOptions -> Bool
shakeChange :: ShakeOptions -> Change
shakeRunCommands :: ShakeOptions -> Bool
shakeTimings :: ShakeOptions -> Bool
shakeLineBuffering :: ShakeOptions -> Bool
shakeStorageLog :: ShakeOptions -> Bool
shakeAbbreviations :: ShakeOptions -> [(String, String)]
shakeRebuild :: ShakeOptions -> [(Rebuild, String)]
shakeFlush :: ShakeOptions -> Maybe Seconds
shakeCommandOptions :: ShakeOptions -> [CmdOption]
shakeLintWatch :: ShakeOptions -> [String]
shakeLintIgnore :: ShakeOptions -> [String]
shakeLintInside :: ShakeOptions -> [String]
shakeLint :: ShakeOptions -> Maybe Lint
shakeReport :: ShakeOptions -> [String]
shakeStaunch :: ShakeOptions -> Bool
shakeVerbosity :: ShakeOptions -> Verbosity
shakeVersion :: ShakeOptions -> String
shakeThreads :: ShakeOptions -> Int
shakeFiles :: ShakeOptions -> String
shakeFiles :: String
shakeThreads :: Int
shakeVersion :: String
shakeVerbosity :: Verbosity
shakeStaunch :: Bool
shakeReport :: [String]
shakeLint :: Maybe Lint
shakeLintInside :: [String]
shakeLintIgnore :: [String]
shakeLintWatch :: [String]
shakeCommandOptions :: [CmdOption]
shakeFlush :: Maybe Seconds
shakeRebuild :: [(Rebuild, String)]
shakeAbbreviations :: [(String, String)]
shakeStorageLog :: Bool
shakeLineBuffering :: Bool
shakeTimings :: Bool
shakeRunCommands :: Bool
shakeChange :: Change
shakeCreationCheck :: Bool
shakeLiveFiles :: [String]
shakeVersionIgnore :: Bool
shakeColor :: Bool
shakeShare :: Maybe String
shakeCloud :: [String]
shakeSymlink :: Bool
shakeNeedDirectory :: Bool
shakeAllowRedefineRules :: Bool
shakeProgress :: IO Progress -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeTrace :: String -> String -> Bool -> IO ()
shakeExtra :: HashMap TypeRep Dynamic
..} IO String -> IO ()
diagnostic HashMap k (Ver, BinaryOp v)
witness = do
    let lockFile :: String
lockFile = String
shakeFiles String -> String -> String
</> String
".shake.lock"
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Before usingLockFile on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lockFile
    Cleanup -> String -> IO ()
usingLockFile Cleanup
cleanup String
lockFile
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"After usingLockFile"

    let dbfile :: String
dbfile = String
shakeFiles String -> String -> String
</> String
".shake.database"
    String -> IO ()
createDirectoryRecursive String
shakeFiles

    -- complete a partially failed compress
    IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
restoreChunksBackup String
dbfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
unexpected String
"Backup file exists, restoring over the previous file\n"
        IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Backup file move to original"

    String -> IO ()
addTiming String
"Database read"
    h <- Cleanup -> String -> Maybe Seconds -> IO Chunks
usingChunks Cleanup
cleanup String
dbfile Maybe Seconds
shakeFlush
    let corrupt
            | Bool -> Bool
not Bool
shakeStorageLog = Maybe String -> Chunks -> IO ()
resetChunksCorrupt Maybe String
forall a. Maybe a
Nothing Chunks
h
            | Bool
otherwise = do
                let file :: String
file = String
dbfile String -> String -> String
<.> String
"corrupt"
                Maybe String -> Chunks -> IO ()
resetChunksCorrupt (String -> Maybe String
forall a. a -> Maybe a
Just String
file) Chunks
h
                String -> IO ()
unexpected (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Backup of corrupted file stored at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

    -- check the version information matches
    let ver = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> String
databaseVersion String
shakeVersion
    oldVer <- readChunkMax h $ fromIntegral $ BS.length ver + 100000
    let verEq = ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right ByteString
ver Either ByteString ByteString
-> Either ByteString ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Either ByteString ByteString
oldVer
    when (not shakeVersionIgnore && not verEq && oldVer /= Left BS.empty) $ do
        outputErr $ messageDatabaseVersionChange dbfile (fromEither oldVer) ver
        corrupt

    (!witnessNew, !save) <- evaluate $ saveWitness witness
    witnessOld <- readChunk h
    ids <- case witnessOld of
        Left ByteString
_ -> do
            Maybe String -> Chunks -> IO ()
resetChunksCorrupt Maybe String
forall a. Maybe a
Nothing Chunks
h
            Maybe (Ids v) -> IO (Maybe (Ids v))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ids v)
forall a. Maybe a
Nothing
        Right ByteString
witnessOld ->  (SomeException -> Bool)
-> (SomeException -> IO (Maybe (Ids v)))
-> IO (Maybe (Ids v))
-> IO (Maybe (Ids v))
forall e a.
Exception e =>
(e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool (Bool -> Bool
not (Bool -> Bool) -> (SomeException -> Bool) -> SomeException -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Bool
isAsyncException) (\SomeException
err -> do
            [String] -> IO ()
outputErr ([String] -> IO ()) -> IO [String] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> SomeException -> IO [String]
messageCorrupt String
dbfile SomeException
err
            IO ()
corrupt
            Maybe (Ids v) -> IO (Maybe (Ids v))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Ids v)
forall a. Maybe a
Nothing) (IO (Maybe (Ids v)) -> IO (Maybe (Ids v)))
-> IO (Maybe (Ids v)) -> IO (Maybe (Ids v))
forall a b. (a -> b) -> a -> b
$ do

            (!missing, !load) <- ([String], ByteString -> (Id, Maybe (k, v)))
-> IO ([String], ByteString -> (Id, Maybe (k, v)))
forall a. a -> IO a
evaluate (([String], ByteString -> (Id, Maybe (k, v)))
 -> IO ([String], ByteString -> (Id, Maybe (k, v))))
-> ([String], ByteString -> (Id, Maybe (k, v)))
-> IO ([String], ByteString -> (Id, Maybe (k, v)))
forall a b. (a -> b) -> a -> b
$ HashMap k (Ver, BinaryOp v)
-> ByteString -> ([String], ByteString -> (Id, Maybe (k, v)))
forall k v.
Show k =>
HashMap k (Ver, BinaryOp v)
-> ByteString -> ([String], ByteString -> (Id, Maybe (k, v)))
loadWitness HashMap k (Ver, BinaryOp v)
witness ByteString
witnessOld
            when (missing /= []) $ outputErr $ messageMissingTypes dbfile missing
            ids <- Ids.empty
            let raw ByteString
bs = String
"[len " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bs) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [[Char
'0' | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c | Word8
x <- ByteString -> [Word8]
BS8.unpack ByteString
bs, let c :: String
c = Word8 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word8
x String
""]
            let go !a
i = do
                    v <- Chunks -> IO (Either ByteString ByteString)
readChunk Chunks
h
                    case v of
                        Left ByteString
e -> do
                            let slop :: Integer
slop = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
e
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
slop Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
unexpected (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Last " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
slop String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes do not form a whole record\n"
                            IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" chunks, plus " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
slop String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" slop"
                            a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
i
                        Right ByteString
bs | (Id
id, Just (k
k,v
v)) <- ByteString -> (Id, Maybe (k, v))
load ByteString
bs -> do
                            () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ k -> ()
forall a. NFData a => a -> ()
rnf k
k
                            () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ v -> ()
forall a. NFData a => a -> ()
rnf v
v
                            Ids (k, v) -> Id -> (k, v) -> IO ()
forall a. Ids a -> Id -> a -> IO ()
Ids.insert Ids (k, v)
ids Id
id (k
k,v
v)
                            IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                let pretty :: Either a String -> String
pretty (Left a
x) = String
"FAILURE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
                                    pretty (Right String
x) = String
x
                                x2 <- IO String -> IO (Either SomeException String)
forall a. IO a -> IO (Either SomeException a)
try_ (IO String -> IO (Either SomeException String))
-> IO String -> IO (Either SomeException String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
evaluate (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ let s :: String
s = v -> String
forall a. Show a => a -> String
show v
v in String -> ()
forall a. NFData a => a -> ()
rnf String
s () -> String -> String
forall a b. a -> b -> b
`seq` String
s
                                pure $ "Chunk " ++ show i ++ " " ++ raw bs ++ " " ++ show id ++ " = " ++ pretty x2
                            a -> IO a
go (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1
                        Right ByteString
bs -> do
                            IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Chunk " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
raw ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" UNKNOWN WITNESS"
                            a -> IO a
go a
i
            countItems <- go 0
            countDistinct <- Ids.sizeUpperBound ids
            diagnostic $ pure $ "Found at most " ++ show countDistinct ++ " distinct entries out of " ++ show countItems

            when (countItems > countDistinct*2 || not verEq || witnessOld /= witnessNew) $ do
                addTiming "Database compression"
                resetChunksCompact h $ \Builder -> IO ()
out -> do
                    Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
ver
                    Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
witnessNew
                    Ids (k, v) -> (Id -> (k, v) -> IO ()) -> IO ()
forall a. Ids a -> (Id -> a -> IO ()) -> IO ()
Ids.forWithKeyM_ Ids (k, v)
ids ((Id -> (k, v) -> IO ()) -> IO ())
-> (Id -> (k, v) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Id
i (k
k,v
v) -> Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ k -> Id -> v -> Builder
save k
k Id
i v
v
            Just <$> Ids.forCopy ids snd

    ids <- case ids of
        Just Ids v
ids -> Ids v -> IO (Ids v)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ids v
ids
        Maybe (Ids v)
Nothing -> do
            Chunks -> Builder -> IO ()
writeChunk Chunks
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
ver
            Chunks -> Builder -> IO ()
writeChunk Chunks
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx ByteString
witnessNew
            IO (Ids v)
forall a. IO (Ids a)
Ids.empty

    addTiming "With database"
    out <- usingWriteChunks cleanup h
    pure (ids, \k
k Id
i v
v -> Builder -> IO ()
out (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ k -> Id -> v -> Builder
save k
k Id
i v
v)
    where
        unexpected :: String -> IO ()
unexpected String
x = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shakeStorageLog (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            t <- IO UTCTime
getCurrentTime
            appendFile (shakeFiles </> ".shake.storage.log") $ "\n[" ++ show t ++ "]: " ++ trimEnd x ++ "\n"
        outputErr :: [String] -> IO ()
outputErr [String]
x = do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
shakeVerbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
Warn) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
Warn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
x
            String -> IO ()
unexpected (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
x


-- | A list oft witnesses, saved
type Witnesses = BS.ByteString

-- | The version and key, serialised
newtype Witness = Witness BS.ByteString
    deriving (Witness -> Witness -> Bool
(Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool) -> Eq Witness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Witness -> Witness -> Bool
== :: Witness -> Witness -> Bool
$c/= :: Witness -> Witness -> Bool
/= :: Witness -> Witness -> Bool
Eq, Eq Witness
Eq Witness =>
(Int -> Witness -> Int) -> (Witness -> Int) -> Hashable Witness
Int -> Witness -> Int
Witness -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Witness -> Int
hashWithSalt :: Int -> Witness -> Int
$chash :: Witness -> Int
hash :: Witness -> Int
Hashable, Eq Witness
Eq Witness =>
(Witness -> Witness -> Ordering)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Bool)
-> (Witness -> Witness -> Witness)
-> (Witness -> Witness -> Witness)
-> Ord Witness
Witness -> Witness -> Bool
Witness -> Witness -> Ordering
Witness -> Witness -> Witness
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Witness -> Witness -> Ordering
compare :: Witness -> Witness -> Ordering
$c< :: Witness -> Witness -> Bool
< :: Witness -> Witness -> Bool
$c<= :: Witness -> Witness -> Bool
<= :: Witness -> Witness -> Bool
$c> :: Witness -> Witness -> Bool
> :: Witness -> Witness -> Bool
$c>= :: Witness -> Witness -> Bool
>= :: Witness -> Witness -> Bool
$cmax :: Witness -> Witness -> Witness
max :: Witness -> Witness -> Witness
$cmin :: Witness -> Witness -> Witness
min :: Witness -> Witness -> Witness
Ord)

toWitness :: Show k => Ver -> k -> Witness
toWitness :: forall k. Show k => Ver -> k -> Witness
toWitness (Ver Int
v) k
k = ByteString -> Witness
Witness (ByteString -> Witness) -> ByteString -> Witness
forall a b. (a -> b) -> a -> b
$ String -> ByteString
UTF8.fromString (k -> String
forall a. Show a => a -> String
show k
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"" else String
", v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v))

instance BinaryEx [Witness] where
    putEx :: [Witness] -> Builder
putEx [Witness]
xs = [ByteString] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [ByteString
x | Witness ByteString
x <- [Witness]
xs]
    getEx :: ByteString -> [Witness]
getEx = (ByteString -> Witness) -> [ByteString] -> [Witness]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Witness
Witness ([ByteString] -> [Witness])
-> (ByteString -> [ByteString]) -> ByteString -> [Witness]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. BinaryEx a => ByteString -> a
getEx


-- | Given the current witness table, and the serialised one from last time, return
--   (witnesses that got removed, way to deserialise an entry into an Id, and (if the witness remains) the key and value)
loadWitness :: forall k v . Show k => Map.HashMap k (Ver, BinaryOp v) -> Witnesses -> ([String], BS.ByteString -> (Id, Maybe (k, v)))
loadWitness :: forall k v.
Show k =>
HashMap k (Ver, BinaryOp v)
-> ByteString -> ([String], ByteString -> (Id, Maybe (k, v)))
loadWitness HashMap k (Ver, BinaryOp v)
mp ByteString
bs = (,) [String]
missing ((ByteString -> (Id, Maybe (k, v)))
 -> ([String], ByteString -> (Id, Maybe (k, v))))
-> (ByteString -> (Id, Maybe (k, v)))
-> ([String], ByteString -> (Id, Maybe (k, v)))
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe (ByteString -> Maybe (k, v)))
-> (ByteString -> (Id, Maybe (k, v)))
-> ByteString
-> (Id, Maybe (k, v))
forall a b. a -> b -> b
seq Int -> Maybe (ByteString -> Maybe (k, v))
ind ((ByteString -> (Id, Maybe (k, v)))
 -> ByteString -> (Id, Maybe (k, v)))
-> (ByteString -> (Id, Maybe (k, v)))
-> ByteString
-> (Id, Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
            let (Word16
wInd :: Word16, Id
i :: Id, ByteString
bs2) = ByteString -> (Word16, Id, ByteString)
forall a b.
(Storable a, Storable b) =>
ByteString -> (a, b, ByteString)
binarySplit2 ByteString
bs
            in case Int -> Maybe (ByteString -> Maybe (k, v))
ind (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
wInd) of
                    Maybe (ByteString -> Maybe (k, v))
Nothing -> SomeException -> (Id, Maybe (k, v))
forall a. SomeException -> a
throwImpure (SomeException -> (Id, Maybe (k, v)))
-> SomeException -> (Id, Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"Witness index out of bounds, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
wInd
                    Just ByteString -> Maybe (k, v)
f -> (Id
i, ByteString -> Maybe (k, v)
f ByteString
bs2)
    where
        [Witness]
ws :: [Witness] = ByteString -> [Witness]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
bs
        missing :: [String]
missing = [ByteString -> String
UTF8.toString ByteString
w | (Int
i, Witness ByteString
w) <- Int -> [Witness] -> [(Int, Witness)]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 [Witness]
ws, Maybe (k, v) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (k, v) -> Bool) -> Maybe (k, v) -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (ByteString -> Maybe (k, v)) -> ByteString -> Maybe (k, v)
forall a. HasCallStack => Maybe a -> a
fromJust (Int -> Maybe (ByteString -> Maybe (k, v))
ind Int
i) ByteString
BS.empty]

        HashMap Witness (k, BinaryOp v)
mp2 :: Map.HashMap Witness (k, BinaryOp v) = [(Witness, (k, BinaryOp v))] -> HashMap Witness (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k, (k
k, BinaryOp v
bin)) | (k
k,(Ver
ver,BinaryOp v
bin)) <- HashMap k (Ver, BinaryOp v) -> [(k, (Ver, BinaryOp v))]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (Ver, BinaryOp v)
mp]

        Int -> Maybe (ByteString -> Maybe (k, v))
ind :: (Int -> Maybe (BS.ByteString -> Maybe (k, v))) = HashMap Witness (k, BinaryOp v)
-> (Int -> Maybe (ByteString -> Maybe (k, v)))
-> Int
-> Maybe (ByteString -> Maybe (k, v))
forall a b. a -> b -> b
seq HashMap Witness (k, BinaryOp v)
mp2 ((Int -> Maybe (ByteString -> Maybe (k, v)))
 -> Int -> Maybe (ByteString -> Maybe (k, v)))
-> (Int -> Maybe (ByteString -> Maybe (k, v)))
-> Int
-> Maybe (ByteString -> Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ [ByteString -> Maybe (k, v)]
-> Int -> Maybe (ByteString -> Maybe (k, v))
forall a. [a] -> Int -> Maybe a
fastAt ([ByteString -> Maybe (k, v)]
 -> Int -> Maybe (ByteString -> Maybe (k, v)))
-> [ByteString -> Maybe (k, v)]
-> Int
-> Maybe (ByteString -> Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ ((Witness -> ByteString -> Maybe (k, v))
 -> [Witness] -> [ByteString -> Maybe (k, v)])
-> [Witness]
-> (Witness -> ByteString -> Maybe (k, v))
-> [ByteString -> Maybe (k, v)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Witness -> ByteString -> Maybe (k, v))
-> [Witness] -> [ByteString -> Maybe (k, v)]
forall a b. (a -> b) -> [a] -> [b]
map [Witness]
ws ((Witness -> ByteString -> Maybe (k, v))
 -> [ByteString -> Maybe (k, v)])
-> (Witness -> ByteString -> Maybe (k, v))
-> [ByteString -> Maybe (k, v)]
forall a b. (a -> b) -> a -> b
$ \Witness
w ->
            case Witness -> HashMap Witness (k, BinaryOp v) -> Maybe (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Witness
w HashMap Witness (k, BinaryOp v)
mp2 of
                Maybe (k, BinaryOp v)
Nothing -> Maybe (k, v) -> ByteString -> Maybe (k, v)
forall a b. a -> b -> a
const Maybe (k, v)
forall a. Maybe a
Nothing
                Just (k
k, BinaryOp{v -> Builder
ByteString -> v
putOp :: v -> Builder
getOp :: ByteString -> v
getOp :: forall v. BinaryOp v -> ByteString -> v
putOp :: forall v. BinaryOp v -> v -> Builder
..}) -> \ByteString
bs -> (k, v) -> Maybe (k, v)
forall a. a -> Maybe a
Just (k
k, ByteString -> v
getOp ByteString
bs)


saveWitness :: forall k v . (Eq k, Hashable k, Show k) => Map.HashMap k (Ver, BinaryOp v) -> (Witnesses, k -> Id -> v -> Builder)
saveWitness :: forall k v.
(Eq k, Hashable k, Show k) =>
HashMap k (Ver, BinaryOp v)
-> (ByteString, k -> Id -> v -> Builder)
saveWitness HashMap k (Ver, BinaryOp v)
mp
    | HashMap k (Ver, BinaryOp v) -> Int
forall k v. HashMap k v -> Int
Map.size HashMap k (Ver, BinaryOp v)
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16) = SomeException -> (ByteString, k -> Id -> v -> Builder)
forall a. SomeException -> a
throwImpure (SomeException -> (ByteString, k -> Id -> v -> Builder))
-> SomeException -> (ByteString, k -> Id -> v -> Builder)
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"Number of distinct witness types exceeds limit, got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (HashMap k (Ver, BinaryOp v) -> Int
forall k v. HashMap k v -> Int
Map.size HashMap k (Ver, BinaryOp v)
mp)
    | Bool
otherwise = (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Witness] -> Builder
forall a. BinaryEx a => a -> Builder
putEx [Witness]
ws
                  ,HashMap k (Id -> v -> Builder)
mpSave HashMap k (Id -> v -> Builder)
-> (k -> Id -> v -> Builder) -> k -> Id -> v -> Builder
forall a b. a -> b -> b
`seq` \k
k -> (Id -> v -> Builder)
-> Maybe (Id -> v -> Builder) -> Id -> v -> Builder
forall a. a -> Maybe a -> a
fromMaybe (SomeException -> Id -> v -> Builder
forall a. SomeException -> a
throwImpure (SomeException -> Id -> v -> Builder)
-> SomeException -> Id -> v -> Builder
forall a b. (a -> b) -> a -> b
$ HasCallStack => String -> SomeException
String -> SomeException
errorInternal (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ String
"Don't know how to save, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
k) (Maybe (Id -> v -> Builder) -> Id -> v -> Builder)
-> Maybe (Id -> v -> Builder) -> Id -> v -> Builder
forall a b. (a -> b) -> a -> b
$ k -> HashMap k (Id -> v -> Builder) -> Maybe (Id -> v -> Builder)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
k HashMap k (Id -> v -> Builder)
mpSave)
    where
        -- the entries in the witness table (in a stable order, to make it more likely to get a good equality)
        [Witness]
ws :: [Witness] = [Witness] -> [Witness]
forall a. Ord a => [a] -> [a]
sort ([Witness] -> [Witness]) -> [Witness] -> [Witness]
forall a b. (a -> b) -> a -> b
$ ((k, (Ver, BinaryOp v)) -> Witness)
-> [(k, (Ver, BinaryOp v))] -> [Witness]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k,(Ver
ver,BinaryOp v
_)) -> Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k) ([(k, (Ver, BinaryOp v))] -> [Witness])
-> [(k, (Ver, BinaryOp v))] -> [Witness]
forall a b. (a -> b) -> a -> b
$ HashMap k (Ver, BinaryOp v) -> [(k, (Ver, BinaryOp v))]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (Ver, BinaryOp v)
mp

        -- an index for each of the witness entries
        HashMap Witness Word16
wsIndex :: Map.HashMap Witness Word16 = [(Witness, Word16)] -> HashMap Witness Word16
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(Witness, Word16)] -> HashMap Witness Word16)
-> [(Witness, Word16)] -> HashMap Witness Word16
forall a b. (a -> b) -> a -> b
$ [Witness] -> [Word16] -> [(Witness, Word16)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Witness]
ws [Word16
0 :: Word16 ..]

        -- the save functions
        HashMap k (Id -> v -> Builder)
mpSave :: Map.HashMap k (Id -> v -> Builder) = ((k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
 -> HashMap k (Ver, BinaryOp v) -> HashMap k (Id -> v -> Builder))
-> HashMap k (Ver, BinaryOp v)
-> (k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Id -> v -> Builder)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Ver, BinaryOp v) -> HashMap k (Id -> v -> Builder)
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.mapWithKey HashMap k (Ver, BinaryOp v)
mp ((k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
 -> HashMap k (Id -> v -> Builder))
-> (k -> (Ver, BinaryOp v) -> Id -> v -> Builder)
-> HashMap k (Id -> v -> Builder)
forall a b. (a -> b) -> a -> b
$
            \k
k (Ver
ver,BinaryOp{v -> Builder
ByteString -> v
getOp :: forall v. BinaryOp v -> ByteString -> v
putOp :: forall v. BinaryOp v -> v -> Builder
putOp :: v -> Builder
getOp :: ByteString -> v
..}) ->
                let tag :: Builder
tag = Word16 -> Builder
forall a. BinaryEx a => a -> Builder
putEx (Word16 -> Builder) -> Word16 -> Builder
forall a b. (a -> b) -> a -> b
$ HashMap Witness Word16
wsIndex HashMap Witness Word16 -> Witness -> Word16
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
Map.! Ver -> k -> Witness
forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k
                in \(Id Word32
w) v
v -> Builder
tag Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word32 -> Builder
forall a. BinaryEx a => a -> Builder
putEx Word32
w Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> v -> Builder
putOp v
v