{-# 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-" forall a. [a] -> [a] -> [a]
++ String
os forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++ String
arch forall a. [a] -> [a] -> [a]
++ String
"-" forall a. [a] -> [a] -> [a]
++  String
s forall a. [a] -> [a] -> [a]
++ String
"\r\n"
    where s :: String
s = forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ 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
    String
msg <- forall e. Show e => e -> IO String
showException SomeException
err
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        (String
"Error when reading Shake database " forall a. [a] -> [a] -> [a]
++ String
dbfile) forall a. a -> [a] -> [a]
:
        forall a b. (a -> b) -> [a] -> [b]
map (String
"  "forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines String
msg) forall a. [a] -> [a] -> [a]
++
        [String
"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:         " forall a. [a] -> [a] -> [a]
++ String
dbfile
    ,String
"  Old version:  " forall a. [a] -> [a] -> [a]
++ String -> String
disp (String -> String
limit forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
old)
    ,String
"  New version:  " 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) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
200 String
x in String
a forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then String
"" else String
"...")
        disp :: String -> String
disp = 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
'?') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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:  " forall a. [a] -> [a] -> [a]
++ String
dbfile] forall a. [a] -> [a] -> [a]
++
    [String
"  Type:  " forall a. [a] -> [a] -> [a]
++ String
x | String
x <- [String]
types] 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 ()
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
shakeExtra :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
..} IO String -> IO ()
diagnostic HashMap k (Ver, BinaryOp v)
_ | String
shakeFiles forall a. Eq a => a -> a -> Bool
== String
"/dev/null" = do
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Using in-memory database"
    Ids v
ids <- forall a. IO (Ids a)
Ids.empty
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ids v
ids, \k
_ Id
_ v
_ -> 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 :: HashMap TypeRep Dynamic
shakeTrace :: String -> String -> Bool -> IO ()
shakeOutput :: Verbosity -> String -> IO ()
shakeProgress :: IO Progress -> IO ()
shakeAllowRedefineRules :: Bool
shakeNeedDirectory :: Bool
shakeSymlink :: Bool
shakeCloud :: [String]
shakeShare :: Maybe String
shakeColor :: Bool
shakeVersionIgnore :: Bool
shakeLiveFiles :: [String]
shakeCreationCheck :: Bool
shakeChange :: Change
shakeRunCommands :: Bool
shakeTimings :: Bool
shakeLineBuffering :: Bool
shakeStorageLog :: Bool
shakeAbbreviations :: [(String, String)]
shakeRebuild :: [(Rebuild, String)]
shakeFlush :: Maybe Seconds
shakeCommandOptions :: [CmdOption]
shakeLintWatch :: [String]
shakeLintIgnore :: [String]
shakeLintInside :: [String]
shakeLint :: Maybe Lint
shakeReport :: [String]
shakeStaunch :: Bool
shakeVerbosity :: Verbosity
shakeVersion :: String
shakeThreads :: Int
shakeFiles :: String
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)
witness = do
    let lockFile :: String
lockFile = String
shakeFiles String -> String -> String
</> String
".shake.lock"
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"Before usingLockFile on " forall a. [a] -> [a] -> [a]
++ String
lockFile
    Cleanup -> String -> IO ()
usingLockFile Cleanup
cleanup String
lockFile
    IO String -> IO ()
diagnostic forall a b. (a -> b) -> a -> b
$ 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
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
restoreChunksBackup String
dbfile) 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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Backup file move to original"

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

    -- check the version information matches
    let ver :: ByteString
ver = String -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ String -> String
databaseVersion String
shakeVersion
    Either ByteString ByteString
oldVer <- Chunks -> Word32 -> IO (Either ByteString ByteString)
readChunkMax Chunks
h forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
ver forall a. Num a => a -> a -> a
+ Int
100000
    let verEq :: Bool
verEq = forall a b. b -> Either a b
Right ByteString
ver forall a. Eq a => a -> a -> Bool
== Either ByteString ByteString
oldVer
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
shakeVersionIgnore Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
verEq Bool -> Bool -> Bool
&& Either ByteString ByteString
oldVer forall a. Eq a => a -> a -> Bool
/= forall a b. a -> Either a b
Left ByteString
BS.empty) forall a b. (a -> b) -> a -> b
$ do
        [String] -> IO ()
outputErr forall a b. (a -> b) -> a -> b
$ String -> ByteString -> ByteString -> [String]
messageDatabaseVersionChange String
dbfile (forall a. Either a a -> a
fromEither Either ByteString ByteString
oldVer) ByteString
ver
        IO ()
corrupt

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

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

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
countItems forall a. Ord a => a -> a -> Bool
> Int
countDistinctforall a. Num a => a -> a -> a
*Int
2 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
verEq Bool -> Bool -> Bool
|| ByteString
witnessOld forall a. Eq a => a -> a -> Bool
/= ByteString
witnessNew) forall a b. (a -> b) -> a -> b
$ do
                String -> IO ()
addTiming String
"Database compression"
                forall a. Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
resetChunksCompact Chunks
h forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
out -> do
                    Builder -> IO ()
out forall a b. (a -> b) -> a -> b
$ forall a. BinaryEx a => a -> Builder
putEx ByteString
ver
                    Builder -> IO ()
out forall a b. (a -> b) -> a -> b
$ forall a. BinaryEx a => a -> Builder
putEx ByteString
witnessNew
                    forall a. Ids a -> (Id -> a -> IO ()) -> IO ()
Ids.forWithKeyM_ Ids (k, v)
ids forall a b. (a -> b) -> a -> b
$ \Id
i (k
k,v
v) -> Builder -> IO ()
out forall a b. (a -> b) -> a -> b
$ k -> Id -> v -> Builder
save k
k Id
i v
v
            forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Ids a -> (a -> b) -> IO (Ids b)
Ids.forCopy Ids (k, v)
ids forall a b. (a, b) -> b
snd

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

    String -> IO ()
addTiming String
"With database"
    Builder -> IO ()
out <- Cleanup -> Chunks -> IO (Builder -> IO ())
usingWriteChunks Cleanup
cleanup Chunks
h
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ids v
ids, \k
k Id
i v
v -> Builder -> IO ()
out 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shakeStorageLog forall a b. (a -> b) -> a -> b
$ do
            UTCTime
t <- IO UTCTime
getCurrentTime
            String -> String -> IO ()
appendFile (String
shakeFiles String -> String -> String
</> String
".shake.storage.log") forall a b. (a -> b) -> a -> b
$ String
"\n[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UTCTime
t forall a. [a] -> [a] -> [a]
++ String
"]: " forall a. [a] -> [a] -> [a]
++ String -> String
trimEnd String
x forall a. [a] -> [a] -> [a]
++ String
"\n"
        outputErr :: [String] -> IO ()
outputErr [String]
x = do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
shakeVerbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
Warn) forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
Warn forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
x
            String -> IO ()
unexpected 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Witness -> Witness -> Bool
$c/= :: Witness -> Witness -> Bool
== :: Witness -> Witness -> Bool
$c== :: Witness -> Witness -> Bool
Eq, Eq Witness
Int -> Witness -> Int
Witness -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Witness -> Int
$chash :: Witness -> Int
hashWithSalt :: Int -> Witness -> Int
$chashWithSalt :: Int -> Witness -> Int
Hashable, Eq 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
min :: Witness -> Witness -> Witness
$cmin :: Witness -> Witness -> Witness
max :: Witness -> Witness -> Witness
$cmax :: Witness -> Witness -> Witness
>= :: Witness -> Witness -> Bool
$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
compare :: Witness -> Witness -> Ordering
$ccompare :: Witness -> Witness -> Ordering
Ord)

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

instance BinaryEx [Witness] where
    putEx :: [Witness] -> Builder
putEx [Witness]
xs = forall a. BinaryEx a => a -> Builder
putEx [ByteString
x | Witness ByteString
x <- [Witness]
xs]
    getEx :: ByteString -> [Witness]
getEx = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Witness
Witness forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a b. (a -> b) -> a -> b
$ seq :: forall a b. a -> b -> b
seq Int -> Maybe (ByteString -> Maybe (k, v))
ind forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
            let (Word16
wInd :: Word16, Id
i :: Id, ByteString
bs2) = forall a b.
(Storable a, Storable b) =>
ByteString -> (a, b, ByteString)
binarySplit2 ByteString
bs
            in case Int -> Maybe (ByteString -> Maybe (k, v))
ind (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
wInd) of
                    Maybe (ByteString -> Maybe (k, v))
Nothing -> forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal forall a b. (a -> b) -> a -> b
$ String
"Witness index out of bounds, " forall a. [a] -> [a] -> [a]
++ 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] = forall a. BinaryEx a => ByteString -> a
getEx ByteString
bs
        missing :: [String]
missing = [ByteString -> String
UTF8.toString ByteString
w | (Int
i, Witness ByteString
w) <- forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 [Witness]
ws, forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall a. Partial => 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) = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k, (k
k, BinaryOp v
bin)) | (k
k,(Ver
ver,BinaryOp v
bin)) <- 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))) = seq :: forall a b. a -> b -> b
seq HashMap Witness (k, BinaryOp v)
mp2 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Int -> Maybe a
fastAt forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Witness]
ws forall a b. (a -> b) -> a -> b
$ \Witness
w ->
            case 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 -> forall a b. a -> b -> a
const forall a. Maybe a
Nothing
                Just (k
k, BinaryOp{v -> Builder
ByteString -> v
getOp :: forall v. BinaryOp v -> ByteString -> v
putOp :: forall v. BinaryOp v -> v -> Builder
getOp :: ByteString -> v
putOp :: v -> Builder
..}) -> \ByteString
bs -> 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
    | forall k v. HashMap k v -> Int
Map.size HashMap k (Ver, BinaryOp v)
mp forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word16) = forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal forall a b. (a -> b) -> a -> b
$ String
"Number of distinct witness types exceeds limit, got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall k v. HashMap k v -> Int
Map.size HashMap k (Ver, BinaryOp v)
mp)
    | Bool
otherwise = (Builder -> ByteString
runBuilder forall a b. (a -> b) -> a -> b
$ forall a. BinaryEx a => a -> Builder
putEx [Witness]
ws
                  ,HashMap k (Id -> v -> Builder)
mpSave seq :: forall a b. a -> b -> b
`seq` \k
k -> forall a. a -> Maybe a -> a
fromMaybe (forall a. SomeException -> a
throwImpure forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
errorInternal forall a b. (a -> b) -> a -> b
$ String
"Don't know how to save, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show k
k) forall a b. (a -> b) -> a -> b
$ 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] = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(k
k,(Ver
ver,BinaryOp v
_)) -> forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k) forall a b. (a -> b) -> a -> b
$ 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 = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ 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) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.mapWithKey HashMap k (Ver, BinaryOp v)
mp forall a b. (a -> b) -> a -> b
$
            \k
k (Ver
ver,BinaryOp{v -> Builder
ByteString -> v
getOp :: ByteString -> v
putOp :: v -> Builder
getOp :: forall v. BinaryOp v -> ByteString -> v
putOp :: forall v. BinaryOp v -> v -> Builder
..}) ->
                let tag :: Builder
tag = forall a. BinaryEx a => a -> Builder
putEx forall a b. (a -> b) -> a -> b
$ HashMap Witness Word16
wsIndex forall k v. (Eq k, Hashable k, Partial) => HashMap k v -> k -> v
Map.! forall k. Show k => Ver -> k -> Witness
toWitness Ver
ver k
k
                in \(Id Word32
w) v
v -> Builder
tag forall a. Semigroup a => a -> a -> a
<> forall a. BinaryEx a => a -> Builder
putEx Word32
w forall a. Semigroup a => a -> a -> a
<> v -> Builder
putOp v
v