{-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-
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.Internal.Core.Storage(
    withStorage
    ) where

import General.Chunks
import General.Binary
import General.Intern
import Development.Shake.Internal.Options
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 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 Data.Functor
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 x :: String
x = "SHAKE-DATABASE-13-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\r\n"
    where s :: String
s = String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [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


-- | Storage of heterogeneous things. In the particular case of Shake,
--   k ~ TypeRep, 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.
withStorage
    :: (Show k, Eq k, Hashable k, NFData k, Show v, NFData v)
    => ShakeOptions                      -- ^ Storage options
    -> (IO String -> IO ())              -- ^ Logging function
    -> Map.HashMap k (BinaryOp v)           -- ^ Witnesses
    -> (Ids.Ids v -> (k -> Id -> v -> IO ()) -> IO a)  -- ^ Execute
    -> IO a
withStorage :: ShakeOptions
-> (IO String -> IO ())
-> HashMap k (BinaryOp v)
-> (Ids v -> (k -> Id -> v -> IO ()) -> IO a)
-> IO a
withStorage ShakeOptions{..} diagnostic :: IO String -> IO ()
diagnostic witness :: HashMap k (BinaryOp v)
witness act :: Ids v -> (k -> Id -> v -> IO ()) -> IO a
act = (IO String -> IO ()) -> String -> IO a -> IO a
forall a. (IO String -> IO ()) -> String -> IO a -> IO a
withLockFileDiagnostic IO String -> IO ()
diagnostic (String
shakeFiles String -> String -> String
</> ".shake.lock") (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    let dbfile :: String
dbfile = String
shakeFiles 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 "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 (m :: * -> *) a. Monad m => a -> m a
return "Backup file move to original"

    String -> IO ()
addTiming "Database read"
    String -> Maybe Double -> (Chunks -> IO a) -> IO a
forall a. String -> Maybe Double -> (Chunks -> IO a) -> IO a
withChunks String
dbfile Maybe Double
shakeFlush ((Chunks -> IO a) -> IO a) -> (Chunks -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \h :: Chunks
h -> do

        let corrupt :: IO ()
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
<.> "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
$ "Backup of corrupted file stored at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"

        -- check the version information matches
        let ver :: ByteString
ver = String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
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 (Word32 -> IO (Either ByteString ByteString))
-> Word32 -> IO (Either ByteString ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
ver Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 100000
        let verEq :: Bool
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
        Bool -> IO () -> IO ()
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 Either ByteString ByteString
-> Either ByteString ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
BS.empty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            let limit :: String -> String
limit x :: String
x = let (a :: String
a,b :: String
b) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 200 String
x in String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
b then "" else "...")
            let disp :: String -> String
disp = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Char
x -> if Char -> Bool
isPrint Char
x Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
x then Char
x else '?') (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` "\r\n")
            String -> IO ()
outputErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                ["Error when reading Shake database - invalid version stamp detected:"
                ,"  File:      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
                ,"  Expected:  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
disp (ByteString -> String
BS.unpack ByteString
ver)
                ,"  Found:     " 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 -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Either ByteString ByteString -> ByteString
forall a. Either a a -> a
fromEither Either ByteString ByteString
oldVer)
                ,"All rules will be rebuilt"]
            IO ()
corrupt

        let (witnessNew :: ByteString
witnessNew, save :: k -> Id -> v -> Builder
save) = HashMap k (BinaryOp v) -> (ByteString, k -> Id -> v -> Builder)
forall k v.
(Eq k, Hashable k, Show k) =>
HashMap k (BinaryOp v) -> (ByteString, k -> Id -> v -> Builder)
putWitness HashMap k (BinaryOp v)
witness
        (k -> Id -> v -> Builder) -> IO (k -> Id -> v -> Builder)
forall a. a -> IO a
evaluate k -> Id -> v -> Builder
save
        Either ByteString ByteString
witnessOld <- Chunks -> IO (Either ByteString ByteString)
readChunk Chunks
h
        Maybe (Ids v)
ids <- case Either ByteString ByteString
witnessOld of
            Left _ -> do
                Maybe String -> Chunks -> IO ()
resetChunksCorrupt Maybe String
forall a. Maybe a
Nothing Chunks
h
                Maybe (Ids v) -> IO (Maybe (Ids v))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ids v)
forall a. Maybe a
Nothing
            Right witnessOld :: 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) (\err :: SomeException
err -> do
                String
msg <- SomeException -> IO String
forall e. Show e => e -> IO String
showException SomeException
err
                String -> IO ()
outputErr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                    ("Error when reading Shake database " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
                    (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> [String]
lines String
msg) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                    ["All files will be rebuilt"]
                IO ()
corrupt
                Maybe (Ids v) -> IO (Maybe (Ids v))
forall (m :: * -> *) a. Monad m => a -> m a
return 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

                let load :: ByteString -> (k, Id, v)
load = ByteString -> HashMap k (BinaryOp v) -> ByteString -> (k, Id, v)
forall k v.
Show k =>
ByteString -> HashMap k (BinaryOp v) -> ByteString -> (k, Id, v)
getWitness ByteString
witnessOld HashMap k (BinaryOp v)
witness
                (ByteString -> (k, Id, v)) -> IO (ByteString -> (k, Id, v))
forall a. a -> IO a
evaluate ByteString -> (k, Id, v)
load
                Ids (k, v)
ids <- IO (Ids (k, v))
forall a. IO (Ids a)
Ids.empty
                let go :: t -> IO t
go !t
i = do
                        Either ByteString ByteString
v <- Chunks -> IO (Either ByteString ByteString)
readChunk Chunks
h
                        case Either ByteString ByteString
v of
                            Left e :: 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
> 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
$ "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]
++ " 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 (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Read " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " 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]
++ " slop"
                                t -> IO t
forall (m :: * -> *) a. Monad m => a -> m a
return t
i
                            Right bs :: ByteString
bs -> do
                                let (k :: k
k,id :: Id
id,v :: v
v) = ByteString -> (k, Id, v)
load ByteString
bs
                                () -> 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 raw :: p -> String
raw x :: p
x = "[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
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                                [['0' | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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, Show a) => a -> String -> String
showHex Word8
x ""]
                                    let pretty :: Either a String -> String
pretty (Left x :: a
x) = "FAILURE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x
                                        pretty (Right x :: String
x) = String
x
                                    Either SomeException String
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
                                    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Chunk " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall a. Show a => a -> String
show t
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall p. p -> String
raw ByteString
bs String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
forall a. Show a => a -> String
show Id
id String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Either SomeException String -> String
forall a. Show a => Either a String -> String
pretty Either SomeException String
x2
                                t -> IO t
go (t -> IO t) -> t -> IO t
forall a b. (a -> b) -> a -> b
$ t
it -> t -> t
forall a. Num a => a -> a -> a
+1
                Int
countItems <- Int -> IO Int
forall t. (Show t, Num t) => t -> IO t
go 0
                Int
countDistinct <- Ids (k, v) -> IO Int
forall a. Ids a -> IO Int
Ids.sizeUpperBound Ids (k, v)
ids
                IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Found at most " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
countDistinct String -> String -> String
forall a. [a] -> [a] -> [a]
++ " distinct entries out of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
countItems

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

        Ids v
ids <- case Maybe (Ids v)
ids of
            Just ids :: Ids v
ids -> Ids v -> IO (Ids v)
forall (m :: * -> *) a. Monad m => a -> m a
return Ids v
ids
            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

        String -> IO ()
addTiming "With database"
        Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
forall a. Chunks -> ((Builder -> IO ()) -> IO a) -> IO a
writeChunks Chunks
h (((Builder -> IO ()) -> IO a) -> IO a)
-> ((Builder -> IO ()) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \out :: Builder -> IO ()
out ->
            Ids v -> (k -> Id -> v -> IO ()) -> IO a
act Ids v
ids ((k -> Id -> v -> IO ()) -> IO a)
-> (k -> Id -> v -> IO ()) -> IO a
forall a b. (a -> b) -> a -> b
$ \k :: k
k i :: Id
i v :: 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 x :: 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
            UTCTime
t <- IO UTCTime
getCurrentTime
            String -> String -> IO ()
appendFile (String
shakeFiles String -> String -> String
</> ".shake.storage.log") (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "\n[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ "]: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
trimEnd String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n"
        outputErr :: String -> IO ()
outputErr x :: 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
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
shakeOutput Verbosity
Quiet String
x
            String -> IO ()
unexpected String
x


keyName :: Show k => k -> BS.ByteString
keyName :: k -> ByteString
keyName = String -> ByteString
UTF8.fromString (String -> ByteString) -> (k -> String) -> k -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> String
forall a. Show a => a -> String
show


getWitness :: Show k => BS.ByteString -> Map.HashMap k (BinaryOp v) -> (BS.ByteString -> (k, Id, v))
getWitness :: ByteString -> HashMap k (BinaryOp v) -> ByteString -> (k, Id, v)
getWitness bs :: ByteString
bs mp :: HashMap k (BinaryOp v)
mp
    | [ByteString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
ws Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit Bool -> Bool -> Bool
|| HashMap k (BinaryOp v) -> Int
forall k v. HashMap k v -> Int
Map.size HashMap k (BinaryOp v)
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit = String -> ByteString -> (k, Id, v)
forall a. HasCallStack => String -> a
error "Number of distinct witness types exceeds limit"
    | Bool
otherwise = Int -> Maybe (ByteString -> (k, Id, v))
ind (Int -> Maybe (ByteString -> (k, Id, v)))
-> (ByteString -> (k, Id, v)) -> ByteString -> (k, Id, v)
forall a b. a -> b -> b
`seq` HashMap ByteString (k, BinaryOp v)
mp2 HashMap ByteString (k, BinaryOp v)
-> (ByteString -> (k, Id, v)) -> ByteString -> (k, Id, v)
forall a b. a -> b -> b
`seq` \bs :: ByteString
bs ->
            let (Word16
k :: Word16,bs2 :: ByteString
bs2) = ByteString -> (Word16, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
binarySplit ByteString
bs
            in case Int -> Maybe (ByteString -> (k, Id, v))
ind (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
k) of
                    Nothing -> String -> (k, Id, v)
forall a. HasCallStack => String -> a
error (String -> (k, Id, v)) -> String -> (k, Id, v)
forall a b. (a -> b) -> a -> b
$ "Witness type out of bounds, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
k
                    Just f :: ByteString -> (k, Id, v)
f -> ByteString -> (k, Id, v)
f ByteString
bs2
    where
        limit :: Int
limit = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
forall a. Bounded a => a
maxBound :: Word16)
        [ByteString]
ws :: [BS.ByteString] = ByteString -> [ByteString]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
bs
        mp2 :: HashMap ByteString (k, BinaryOp v)
mp2 = [(ByteString, (k, BinaryOp v))]
-> HashMap ByteString (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [(k -> ByteString
forall k. Show k => k -> ByteString
keyName k
k, (k
k, BinaryOp v
v)) | (k :: k
k,v :: BinaryOp v
v) <- HashMap k (BinaryOp v) -> [(k, BinaryOp v)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (BinaryOp v)
mp]
        ind :: Int -> Maybe (ByteString -> (k, Id, v))
ind = [ByteString -> (k, Id, v)]
-> Int -> Maybe (ByteString -> (k, Id, v))
forall a. [a] -> Int -> Maybe a
fastAt [ case ByteString
-> HashMap ByteString (k, BinaryOp v) -> Maybe (k, BinaryOp v)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup ByteString
w HashMap ByteString (k, BinaryOp v)
mp2 of
                            Nothing -> String -> ByteString -> (k, Id, v)
forall a. HasCallStack => String -> a
error (String -> ByteString -> (k, Id, v))
-> String -> ByteString -> (k, Id, v)
forall a b. (a -> b) -> a -> b
$ "Witness type has disappeared, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
UTF8.toString ByteString
w
                            Just (k :: k
k, BinaryOp{..}) -> \bs :: ByteString
bs ->
                                let (i :: Id
i, bs2 :: ByteString
bs2) = ByteString -> (Id, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
binarySplit ByteString
bs
                                    v :: v
v = ByteString -> v
getOp ByteString
bs2
                                in (k
k, Id
i, v
v)
                     | ByteString
w <- [ByteString]
ws]


putWitness :: (Eq k, Hashable k, Show k) => Map.HashMap k (BinaryOp v) -> (BS.ByteString, k -> Id -> v -> Builder)
putWitness :: HashMap k (BinaryOp v) -> (ByteString, k -> Id -> v -> Builder)
putWitness mp :: HashMap k (BinaryOp v)
mp = (Builder -> ByteString
runBuilder (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Builder
forall a. BinaryEx a => a -> Builder
putEx ([ByteString]
ws :: [BS.ByteString]), HashMap k (Id -> v -> Builder)
mp2 HashMap k (Id -> v -> Builder)
-> (k -> Id -> v -> Builder) -> k -> Id -> v -> Builder
forall a b. a -> b -> b
`seq` \k :: k
k -> (Id -> v -> Builder)
-> Maybe (Id -> v -> Builder) -> Id -> v -> Builder
forall a. a -> Maybe a -> a
fromMaybe (String -> Id -> v -> Builder
forall a. HasCallStack => String -> a
error (String -> Id -> v -> Builder) -> String -> Id -> v -> Builder
forall a b. (a -> b) -> a -> b
$ "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)
mp2)
    where
        ws :: [ByteString]
ws = [ByteString] -> [ByteString]
forall a. Ord a => [a] -> [a]
sort ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (k -> ByteString) -> [k] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map k -> ByteString
forall k. Show k => k -> ByteString
keyName ([k] -> [ByteString]) -> [k] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ HashMap k (BinaryOp v) -> [k]
forall k v. HashMap k v -> [k]
Map.keys HashMap k (BinaryOp v)
mp
        wsMp :: HashMap ByteString Word16
wsMp = [(ByteString, Word16)] -> HashMap ByteString Word16
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList ([(ByteString, Word16)] -> HashMap ByteString Word16)
-> [(ByteString, Word16)] -> HashMap ByteString Word16
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [Word16] -> [(ByteString, Word16)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
ws [0 :: Word16 ..]
        mp2 :: HashMap k (Id -> v -> Builder)
mp2 = (k -> BinaryOp v -> Id -> v -> Builder)
-> HashMap k (BinaryOp v) -> HashMap k (Id -> v -> Builder)
forall k v1 v2. (k -> v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.mapWithKey (\k :: k
k BinaryOp{..} -> 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 ByteString Word16
wsMp HashMap ByteString Word16 -> ByteString -> Word16
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
Map.! k -> ByteString
forall k. Show k => k -> ByteString
keyName k
k in \(Id w :: Word32
w) v :: 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) HashMap k (BinaryOp v)
mp


withLockFileDiagnostic :: (IO String -> IO ()) -> FilePath -> IO a -> IO a
withLockFileDiagnostic :: (IO String -> IO ()) -> String -> IO a -> IO a
withLockFileDiagnostic diagnostic :: IO String -> IO ()
diagnostic file :: String
file act :: IO a
act = do
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Before withLockFile on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file
    a
res <- String -> IO a -> IO a
forall a. String -> IO a -> IO a
withLockFile String
file (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
        IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "Inside withLockFile"
        IO a
act
    IO String -> IO ()
diagnostic (IO String -> IO ()) -> IO String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return "After withLockFile"
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res