{-# LANGUAGE RecordWildCards, ScopedTypeVariables, TupleSections #-}

module Development.Shake.Internal.History.Shared(
    Shared, newShared,
    addShared, lookupShared,
    removeShared, listShared,
    sanityShared
    ) where

import Control.Exception
import Development.Shake.Internal.Value
import Development.Shake.Internal.History.Types
import Development.Shake.Internal.History.Symlink
import Development.Shake.Internal.Core.Database
import Development.Shake.Classes
import General.Binary
import General.Extra
import Data.List
import Control.Monad.Extra
import System.Directory.Extra
import System.FilePath
import System.IO.Extra
import Numeric
import Development.Shake.Internal.FileInfo
import General.Wait
import Development.Shake.Internal.FileName
import Data.Monoid
import Control.Monad.IO.Class
import Data.Maybe
import qualified Data.ByteString as BS
import Prelude


data Shared = Shared
    {Shared -> Ver
globalVersion :: !Ver
    ,Shared -> BinaryOp Key
keyOp :: BinaryOp Key
    ,Shared -> FilePath
sharedRoot :: FilePath
    ,Shared -> Bool
useSymlink :: Bool
    }

newShared :: Bool -> BinaryOp Key -> Ver -> FilePath -> IO Shared
newShared :: Bool -> BinaryOp Key -> Ver -> FilePath -> IO Shared
newShared Bool
useSymlink BinaryOp Key
keyOp Ver
globalVersion FilePath
sharedRoot = Shared -> IO Shared
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Shared{Bool
FilePath
BinaryOp Key
Ver
globalVersion :: Ver
keyOp :: BinaryOp Key
sharedRoot :: FilePath
useSymlink :: Bool
useSymlink :: Bool
keyOp :: BinaryOp Key
globalVersion :: Ver
sharedRoot :: FilePath
..}


data Entry = Entry
    {Entry -> Key
entryKey :: Key
    ,Entry -> Ver
entryGlobalVersion :: !Ver
    ,Entry -> Ver
entryBuiltinVersion :: !Ver
    ,Entry -> Ver
entryUserVersion :: !Ver
    ,Entry -> [[(Key, BS_Identity)]]
entryDepends :: [[(Key, BS_Identity)]]
    ,Entry -> BS_Identity
entryResult :: BS_Store
    ,Entry -> [(FilePath, FileHash)]
entryFiles :: [(FilePath, FileHash)]
    } deriving (Int -> Entry -> ShowS
[Entry] -> ShowS
Entry -> FilePath
(Int -> Entry -> ShowS)
-> (Entry -> FilePath) -> ([Entry] -> ShowS) -> Show Entry
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Entry -> ShowS
showsPrec :: Int -> Entry -> ShowS
$cshow :: Entry -> FilePath
show :: Entry -> FilePath
$cshowList :: [Entry] -> ShowS
showList :: [Entry] -> ShowS
Show, Entry -> Entry -> Bool
(Entry -> Entry -> Bool) -> (Entry -> Entry -> Bool) -> Eq Entry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Entry -> Entry -> Bool
== :: Entry -> Entry -> Bool
$c/= :: Entry -> Entry -> Bool
/= :: Entry -> Entry -> Bool
Eq)

putEntry :: BinaryOp Key -> Entry -> Builder
putEntry :: BinaryOp Key -> Entry -> Builder
putEntry BinaryOp Key
binop Entry{[[(Key, BS_Identity)]]
[(FilePath, FileHash)]
BS_Identity
Ver
Key
entryKey :: Entry -> Key
entryGlobalVersion :: Entry -> Ver
entryBuiltinVersion :: Entry -> Ver
entryUserVersion :: Entry -> Ver
entryDepends :: Entry -> [[(Key, BS_Identity)]]
entryResult :: Entry -> BS_Identity
entryFiles :: Entry -> [(FilePath, FileHash)]
entryKey :: Key
entryGlobalVersion :: Ver
entryBuiltinVersion :: Ver
entryUserVersion :: Ver
entryDepends :: [[(Key, BS_Identity)]]
entryResult :: BS_Identity
entryFiles :: [(FilePath, FileHash)]
..} =
    Ver -> Builder
forall a. Storable a => a -> Builder
putExStorable Ver
entryGlobalVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Ver -> Builder
forall a. Storable a => a -> Builder
putExStorable Ver
entryBuiltinVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Ver -> Builder
forall a. Storable a => a -> Builder
putExStorable Ver
entryUserVersion Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder -> Builder
putExN (BinaryOp Key -> Key -> Builder
forall v. BinaryOp v -> v -> Builder
putOp BinaryOp Key
binop Key
entryKey) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder -> Builder
putExN ([Builder] -> Builder
putExList ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ([(Key, BS_Identity)] -> Builder)
-> [[(Key, BS_Identity)]] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map ([Builder] -> Builder
putExList ([Builder] -> Builder)
-> ([(Key, BS_Identity)] -> [Builder])
-> [(Key, BS_Identity)]
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, BS_Identity) -> Builder)
-> [(Key, BS_Identity)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (Key, BS_Identity) -> Builder
forall {a}. BinaryEx a => (Key, a) -> Builder
putDepend) [[(Key, BS_Identity)]]
entryDepends) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Builder -> Builder
putExN ([Builder] -> Builder
putExList ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$ ((FilePath, FileHash) -> Builder)
-> [(FilePath, FileHash)] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FileHash) -> Builder
forall {a} {a}. (Storable a, BinaryEx a) => (a, a) -> Builder
putFile [(FilePath, FileHash)]
entryFiles) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    BS_Identity -> Builder
forall a. BinaryEx a => a -> Builder
putEx BS_Identity
entryResult
    where
        putDepend :: (Key, a) -> Builder
putDepend (Key
a,a
b) = Builder -> Builder
putExN (BinaryOp Key -> Key -> Builder
forall v. BinaryOp v -> v -> Builder
putOp BinaryOp Key
binop Key
a) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. BinaryEx a => a -> Builder
putEx a
b
        putFile :: (a, a) -> Builder
putFile (a
a,a
b) = a -> Builder
forall a. Storable a => a -> Builder
putExStorable a
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. BinaryEx a => a -> Builder
putEx a
a

getEntry :: BinaryOp Key -> BS.ByteString -> Entry
getEntry :: BinaryOp Key -> BS_Identity -> Entry
getEntry BinaryOp Key
binop BS_Identity
x
    | (Ver
x1, Ver
x2, Ver
x3, BS_Identity
x) <- BS_Identity -> (Ver, Ver, Ver, BS_Identity)
forall a b c.
(Storable a, Storable b, Storable c) =>
BS_Identity -> (a, b, c, BS_Identity)
binarySplit3 BS_Identity
x
    , (BS_Identity
x4, BS_Identity
x) <- BS_Identity -> (BS_Identity, BS_Identity)
getExN BS_Identity
x
    , (BS_Identity
x5, BS_Identity
x) <- BS_Identity -> (BS_Identity, BS_Identity)
getExN BS_Identity
x
    , (BS_Identity
x6, BS_Identity
x7) <- BS_Identity -> (BS_Identity, BS_Identity)
getExN BS_Identity
x
    = Entry
        {entryGlobalVersion :: Ver
entryGlobalVersion = Ver
x1
        ,entryBuiltinVersion :: Ver
entryBuiltinVersion = Ver
x2
        ,entryUserVersion :: Ver
entryUserVersion = Ver
x3
        ,entryKey :: Key
entryKey = BinaryOp Key -> BS_Identity -> Key
forall v. BinaryOp v -> BS_Identity -> v
getOp BinaryOp Key
binop BS_Identity
x4
        ,entryDepends :: [[(Key, BS_Identity)]]
entryDepends = (BS_Identity -> [(Key, BS_Identity)])
-> [BS_Identity] -> [[(Key, BS_Identity)]]
forall a b. (a -> b) -> [a] -> [b]
map ((BS_Identity -> (Key, BS_Identity))
-> [BS_Identity] -> [(Key, BS_Identity)]
forall a b. (a -> b) -> [a] -> [b]
map BS_Identity -> (Key, BS_Identity)
forall {b}. BinaryEx b => BS_Identity -> (Key, b)
getDepend ([BS_Identity] -> [(Key, BS_Identity)])
-> (BS_Identity -> [BS_Identity])
-> BS_Identity
-> [(Key, BS_Identity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BS_Identity -> [BS_Identity]
getExList) ([BS_Identity] -> [[(Key, BS_Identity)]])
-> [BS_Identity] -> [[(Key, BS_Identity)]]
forall a b. (a -> b) -> a -> b
$ BS_Identity -> [BS_Identity]
getExList BS_Identity
x5
        ,entryFiles :: [(FilePath, FileHash)]
entryFiles = (BS_Identity -> (FilePath, FileHash))
-> [BS_Identity] -> [(FilePath, FileHash)]
forall a b. (a -> b) -> [a] -> [b]
map BS_Identity -> (FilePath, FileHash)
forall {b} {a}. (Storable b, BinaryEx a) => BS_Identity -> (a, b)
getFile ([BS_Identity] -> [(FilePath, FileHash)])
-> [BS_Identity] -> [(FilePath, FileHash)]
forall a b. (a -> b) -> a -> b
$ BS_Identity -> [BS_Identity]
getExList BS_Identity
x6
        ,entryResult :: BS_Identity
entryResult = BS_Identity -> BS_Identity
forall a. BinaryEx a => BS_Identity -> a
getEx BS_Identity
x7
        }
    where
        getDepend :: BS_Identity -> (Key, b)
getDepend BS_Identity
x | (BS_Identity
a, BS_Identity
b) <- BS_Identity -> (BS_Identity, BS_Identity)
getExN BS_Identity
x = (BinaryOp Key -> BS_Identity -> Key
forall v. BinaryOp v -> BS_Identity -> v
getOp BinaryOp Key
binop BS_Identity
a, BS_Identity -> b
forall a. BinaryEx a => BS_Identity -> a
getEx BS_Identity
b)
        getFile :: BS_Identity -> (a, b)
getFile BS_Identity
x | (b
b, BS_Identity
a) <- BS_Identity -> (b, BS_Identity)
forall a. Storable a => BS_Identity -> (a, BS_Identity)
binarySplit BS_Identity
x = (BS_Identity -> a
forall a. BinaryEx a => BS_Identity -> a
getEx BS_Identity
a, b
b)

hexed :: a -> FilePath
hexed a
x = Int -> ShowS
forall a. Integral a => a -> ShowS
showHex (Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Hashable a => a -> Int
hash a
x) FilePath
""

-- | The path under which everything relating to a Key lives
sharedFileDir :: Shared -> Key -> FilePath
sharedFileDir :: Shared -> Key -> FilePath
sharedFileDir Shared
shared Key
key = Shared -> FilePath
sharedRoot Shared
shared FilePath -> ShowS
</> FilePath
".shake.cache" FilePath -> ShowS
</> Key -> FilePath
forall {a}. Hashable a => a -> FilePath
hexed Key
key

-- | The list of files containing Entry values, given a result of 'sharedFileDir'
sharedFileKeys :: FilePath -> IO [FilePath]
sharedFileKeys :: FilePath -> IO [FilePath]
sharedFileKeys FilePath
dir = do
    b <- FilePath -> IO Bool
doesDirectoryExist_ (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FilePath
"_key"
    if not b then pure [] else listFiles $ dir </> "_key"

loadSharedEntry :: Shared -> Key -> Ver -> Ver -> IO [IO (Maybe Entry)]
loadSharedEntry :: Shared -> Key -> Ver -> Ver -> IO [IO (Maybe Entry)]
loadSharedEntry shared :: Shared
shared@Shared{Bool
FilePath
BinaryOp Key
Ver
globalVersion :: Shared -> Ver
keyOp :: Shared -> BinaryOp Key
sharedRoot :: Shared -> FilePath
useSymlink :: Shared -> Bool
globalVersion :: Ver
keyOp :: BinaryOp Key
sharedRoot :: FilePath
useSymlink :: Bool
..} Key
key Ver
builtinVersion Ver
userVersion =
    (FilePath -> IO (Maybe Entry)) -> [FilePath] -> [IO (Maybe Entry)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> IO (Maybe Entry)
f ([FilePath] -> [IO (Maybe Entry)])
-> IO [FilePath] -> IO [IO (Maybe Entry)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
sharedFileKeys (Shared -> Key -> FilePath
sharedFileDir Shared
shared Key
key)
    where
        f :: FilePath -> IO (Maybe Entry)
f FilePath
file = do
            e@Entry{..} <- BinaryOp Key -> BS_Identity -> Entry
getEntry BinaryOp Key
keyOp (BS_Identity -> Entry) -> IO BS_Identity -> IO Entry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO BS_Identity
BS.readFile FilePath
file
            let valid = Key
entryKey Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Key
key Bool -> Bool -> Bool
&& Ver
entryGlobalVersion Ver -> Ver -> Bool
forall a. Eq a => a -> a -> Bool
== Ver
globalVersion Bool -> Bool -> Bool
&& Ver
entryBuiltinVersion Ver -> Ver -> Bool
forall a. Eq a => a -> a -> Bool
== Ver
builtinVersion Bool -> Bool -> Bool
&& Ver
entryUserVersion Ver -> Ver -> Bool
forall a. Eq a => a -> a -> Bool
== Ver
userVersion
            pure $ if valid then Just e else Nothing


-- | Given a way to get the identity, see if you can find a stored cloud version
lookupShared :: Shared -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ()))
lookupShared :: Shared
-> (Key -> Wait Locked (Maybe BS_Identity))
-> Key
-> Ver
-> Ver
-> Wait Locked (Maybe (BS_Identity, [[Key]], IO ()))
lookupShared Shared
shared Key -> Wait Locked (Maybe BS_Identity)
ask Key
key Ver
builtinVersion Ver
userVersion = do
    ents <- IO [IO (Maybe Entry)] -> Wait Locked [IO (Maybe Entry)]
forall a. IO a -> Wait Locked a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [IO (Maybe Entry)] -> Wait Locked [IO (Maybe Entry)])
-> IO [IO (Maybe Entry)] -> Wait Locked [IO (Maybe Entry)]
forall a b. (a -> b) -> a -> b
$ Shared -> Key -> Ver -> Ver -> IO [IO (Maybe Entry)]
loadSharedEntry Shared
shared Key
key Ver
builtinVersion Ver
userVersion
    flip firstJustWaitUnordered ents $ \IO (Maybe Entry)
act -> do
        me <- IO (Maybe Entry) -> Wait Locked (Maybe Entry)
forall a. IO a -> Wait Locked a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe Entry)
act
        case me of
            Maybe Entry
Nothing -> Maybe (BS_Identity, [[Key]], IO ())
-> Wait Locked (Maybe (BS_Identity, [[Key]], IO ()))
forall a. a -> Wait Locked a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (BS_Identity, [[Key]], IO ())
forall a. Maybe a
Nothing
            Just Entry{[[(Key, BS_Identity)]]
[(FilePath, FileHash)]
BS_Identity
Ver
Key
entryKey :: Entry -> Key
entryGlobalVersion :: Entry -> Ver
entryBuiltinVersion :: Entry -> Ver
entryUserVersion :: Entry -> Ver
entryDepends :: Entry -> [[(Key, BS_Identity)]]
entryResult :: Entry -> BS_Identity
entryFiles :: Entry -> [(FilePath, FileHash)]
entryKey :: Key
entryGlobalVersion :: Ver
entryBuiltinVersion :: Ver
entryUserVersion :: Ver
entryDepends :: [[(Key, BS_Identity)]]
entryResult :: BS_Identity
entryFiles :: [(FilePath, FileHash)]
..} -> do
                -- use Nothing to indicate success, Just () to bail out early on mismatch
                let result :: Maybe a -> Maybe (BS_Identity, [[Key]], IO ())
result Maybe a
x = if Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
x then Maybe (BS_Identity, [[Key]], IO ())
forall a. Maybe a
Nothing else (BS_Identity, [[Key]], IO ())
-> Maybe (BS_Identity, [[Key]], IO ())
forall a. a -> Maybe a
Just ((BS_Identity, [[Key]], IO ())
 -> Maybe (BS_Identity, [[Key]], IO ()))
-> (BS_Identity, [[Key]], IO ())
-> Maybe (BS_Identity, [[Key]], IO ())
forall a b. (a -> b) -> a -> b
$ (BS_Identity
entryResult, ([(Key, BS_Identity)] -> [Key])
-> [[(Key, BS_Identity)]] -> [[Key]]
forall a b. (a -> b) -> [a] -> [b]
map (((Key, BS_Identity) -> Key) -> [(Key, BS_Identity)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, BS_Identity) -> Key
forall a b. (a, b) -> a
fst) [[(Key, BS_Identity)]]
entryDepends, ) (IO () -> (BS_Identity, [[Key]], IO ()))
-> IO () -> (BS_Identity, [[Key]], IO ())
forall a b. (a -> b) -> a -> b
$ do
                        let dir :: FilePath
dir = Shared -> Key -> FilePath
sharedFileDir Shared
shared Key
entryKey
                        [(FilePath, FileHash)] -> ((FilePath, FileHash) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(FilePath, FileHash)]
entryFiles (((FilePath, FileHash) -> IO ()) -> IO ())
-> ((FilePath, FileHash) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
file, FileHash
hash) ->
                            Bool -> FilePath -> FilePath -> IO ()
copyFileLink (Shared -> Bool
useSymlink Shared
shared) (FilePath
dir FilePath -> ShowS
</> FileHash -> FilePath
forall a. Show a => a -> FilePath
show FileHash
hash) FilePath
file
                Maybe () -> Maybe (BS_Identity, [[Key]], IO ())
forall {a}. Maybe a -> Maybe (BS_Identity, [[Key]], IO ())
result (Maybe () -> Maybe (BS_Identity, [[Key]], IO ()))
-> Wait Locked (Maybe ())
-> Wait Locked (Maybe (BS_Identity, [[Key]], IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Wait Locked (Maybe ()) -> Wait Locked (Maybe ()))
-> [Wait Locked (Maybe ())] -> Wait Locked (Maybe ())
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m (Maybe b)
firstJustM Wait Locked (Maybe ()) -> Wait Locked (Maybe ())
forall a. a -> a
id
                    [ (Wait Locked (Maybe ()) -> Wait Locked (Maybe ()))
-> [Wait Locked (Maybe ())] -> Wait Locked (Maybe ())
forall (m :: * -> *) a b.
MonadIO m =>
(a -> Wait m (Maybe b)) -> [a] -> Wait m (Maybe b)
firstJustWaitUnordered Wait Locked (Maybe ()) -> Wait Locked (Maybe ())
forall a. a -> a
id
                        [ Maybe BS_Identity -> Maybe ()
test (Maybe BS_Identity -> Maybe ())
-> Wait Locked (Maybe BS_Identity) -> Wait Locked (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key -> Wait Locked (Maybe BS_Identity)
ask Key
k | (Key
k, BS_Identity
i1) <- [(Key, BS_Identity)]
kis
                        , let test :: Maybe BS_Identity -> Maybe ()
test = Maybe ()
-> (BS_Identity -> Maybe ()) -> Maybe BS_Identity -> Maybe ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Maybe ()
forall a. a -> Maybe a
Just ()) (\BS_Identity
i2 -> if BS_Identity
i1 BS_Identity -> BS_Identity -> Bool
forall a. Eq a => a -> a -> Bool
== BS_Identity
i2 then Maybe ()
forall a. Maybe a
Nothing else () -> Maybe ()
forall a. a -> Maybe a
Just ())]
                    | [(Key, BS_Identity)]
kis <- [[(Key, BS_Identity)]]
entryDepends]


saveSharedEntry :: Shared -> Entry -> IO ()
saveSharedEntry :: Shared -> Entry -> IO ()
saveSharedEntry Shared
shared Entry
entry = do
    let dir :: FilePath
dir = Shared -> Key -> FilePath
sharedFileDir Shared
shared (Entry -> Key
entryKey Entry
entry)
    FilePath -> IO ()
createDirectoryRecursive FilePath
dir
    [(FilePath, FileHash)] -> ((FilePath, FileHash) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Entry -> [(FilePath, FileHash)]
entryFiles Entry
entry) (((FilePath, FileHash) -> IO ()) -> IO ())
-> ((FilePath, FileHash) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
file, FileHash
hash) ->
        IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist_ (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
dir FilePath -> ShowS
</> FileHash -> FilePath
forall a. Show a => a -> FilePath
show FileHash
hash) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Bool -> FilePath -> FilePath -> IO ()
copyFileLink (Shared -> Bool
useSymlink Shared
shared) FilePath
file (FilePath
dir FilePath -> ShowS
</> FileHash -> FilePath
forall a. Show a => a -> FilePath
show FileHash
hash)
    -- Write key after files to make sure cache is always useable
    let v :: BS_Identity
v = Builder -> BS_Identity
runBuilder (Builder -> BS_Identity) -> Builder -> BS_Identity
forall a b. (a -> b) -> a -> b
$ BinaryOp Key -> Entry -> Builder
putEntry (Shared -> BinaryOp Key
keyOp Shared
shared) Entry
entry
    let dirName :: FilePath
dirName = FilePath
dir FilePath -> ShowS
</> FilePath
"_key"
    FilePath -> IO ()
createDirectoryRecursive FilePath
dirName
    -- #757, make sure we write this file atomically
    (tempFile, cleanUp) <- FilePath -> IO (FilePath, IO ())
newTempFileWithin FilePath
dir
    (BS.writeFile tempFile v >> renameFile tempFile (dirName </> hexed v)) `onException` cleanUp


addShared :: Shared -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()
addShared :: Shared
-> Key
-> Ver
-> Ver
-> [[(Key, BS_Identity)]]
-> BS_Identity
-> [FilePath]
-> IO ()
addShared Shared
shared Key
entryKey Ver
entryBuiltinVersion Ver
entryUserVersion [[(Key, BS_Identity)]]
entryDepends BS_Identity
entryResult [FilePath]
files = do
    files <- (FilePath -> IO (FilePath, FileHash))
-> [FilePath] -> IO [(FilePath, FileHash)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\FilePath
x -> (FilePath
x,) (FileHash -> (FilePath, FileHash))
-> IO FileHash -> IO (FilePath, FileHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileName -> IO FileHash
getFileHash (FilePath -> FileName
fileNameFromString FilePath
x)) [FilePath]
files
    saveSharedEntry shared Entry{entryFiles = files, entryGlobalVersion = globalVersion shared, ..}

removeShared :: Shared -> (Key -> Bool) -> IO ()
removeShared :: Shared -> (Key -> Bool) -> IO ()
removeShared Shared{Bool
FilePath
BinaryOp Key
Ver
globalVersion :: Shared -> Ver
keyOp :: Shared -> BinaryOp Key
sharedRoot :: Shared -> FilePath
useSymlink :: Shared -> Bool
globalVersion :: Ver
keyOp :: BinaryOp Key
sharedRoot :: FilePath
useSymlink :: Bool
..} Key -> Bool
test = do
    dirs <- FilePath -> IO [FilePath]
listDirectories (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
sharedRoot FilePath -> ShowS
</> FilePath
".shake.cache"
    deleted <- forM dirs $ \FilePath
dir -> do
        files <- FilePath -> IO [FilePath]
sharedFileKeys FilePath
dir
        -- if any key matches, clean them all out
        b <- flip anyM files $ \FilePath
file -> (SomeException -> IO Bool) -> IO Bool -> IO Bool
forall a. (SomeException -> IO a) -> IO a -> IO a
handleSynchronous (\SomeException
e -> FilePath -> IO ()
putStrLn (FilePath
"Warning: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
            Bool -> IO Bool
forall a. a -> IO a
evaluate (Bool -> IO Bool)
-> (BS_Identity -> Bool) -> BS_Identity -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Bool
test (Key -> Bool) -> (BS_Identity -> Key) -> BS_Identity -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> Key
entryKey (Entry -> Key) -> (BS_Identity -> Entry) -> BS_Identity -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BinaryOp Key -> BS_Identity -> Entry
getEntry BinaryOp Key
keyOp (BS_Identity -> IO Bool) -> IO BS_Identity -> IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO BS_Identity
BS.readFile FilePath
file
        when b $ removePathForcibly dir
        pure b
    liftIO $ putStrLn $ "Deleted " ++ show (length (filter id deleted)) ++ " entries"

listShared :: Shared -> IO ()
listShared :: Shared -> IO ()
listShared Shared{Bool
FilePath
BinaryOp Key
Ver
globalVersion :: Shared -> Ver
keyOp :: Shared -> BinaryOp Key
sharedRoot :: Shared -> FilePath
useSymlink :: Shared -> Bool
globalVersion :: Ver
keyOp :: BinaryOp Key
sharedRoot :: FilePath
useSymlink :: Bool
..} = do
    dirs <- FilePath -> IO [FilePath]
listDirectories (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
sharedRoot FilePath -> ShowS
</> FilePath
".shake.cache"
    forM_ dirs $ \FilePath
dir -> do
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Directory: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dir
        keys <- FilePath -> IO [FilePath]
sharedFileKeys FilePath
dir
        forM_ keys $ \FilePath
key ->
            (SomeException -> IO ()) -> IO () -> IO ()
forall a. (SomeException -> IO a) -> IO a -> IO a
handleSynchronous (\SomeException
e -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Warning: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Entry{..} <- BinaryOp Key -> BS_Identity -> Entry
getEntry BinaryOp Key
keyOp (BS_Identity -> Entry) -> IO BS_Identity -> IO Entry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO BS_Identity
BS.readFile FilePath
key
                putStrLn $ "  Key: " ++ show entryKey
                forM_ entryFiles $ \(FilePath
file,FileHash
_) ->
                    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"    File: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
file

sanityShared :: Shared -> IO ()
sanityShared :: Shared -> IO ()
sanityShared Shared{Bool
FilePath
BinaryOp Key
Ver
globalVersion :: Shared -> Ver
keyOp :: Shared -> BinaryOp Key
sharedRoot :: Shared -> FilePath
useSymlink :: Shared -> Bool
globalVersion :: Ver
keyOp :: BinaryOp Key
sharedRoot :: FilePath
useSymlink :: Bool
..} = do
    dirs <- FilePath -> IO [FilePath]
listDirectories (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
sharedRoot FilePath -> ShowS
</> FilePath
".shake.cache"
    forM_ dirs $ \FilePath
dir -> do
        FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Directory: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
dir
        keys <- FilePath -> IO [FilePath]
sharedFileKeys FilePath
dir
        forM_ keys $ \FilePath
key ->
            (SomeException -> IO ()) -> IO () -> IO ()
forall a. (SomeException -> IO a) -> IO a -> IO a
handleSynchronous (\SomeException
e -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Warning: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Entry{..} <- BinaryOp Key -> BS_Identity -> Entry
getEntry BinaryOp Key
keyOp (BS_Identity -> Entry) -> IO BS_Identity -> IO Entry
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO BS_Identity
BS.readFile FilePath
key
                putStrLn $ "  Key: " ++ show entryKey
                putStrLn $ "  Key file: " ++ key
                forM_ entryFiles $ \(FilePath
file,FileHash
hash) ->
                    FilePath -> FilePath -> FileHash -> IO ()
checkFile FilePath
file FilePath
dir FileHash
hash
    where
      checkFile :: FilePath -> FilePath -> FileHash -> IO ()
checkFile FilePath
filename FilePath
dir FileHash
keyHash = do
          let cachefile :: FilePath
cachefile = FilePath
dir FilePath -> ShowS
</> FileHash -> FilePath
forall a. Show a => a -> FilePath
show FileHash
keyHash
          FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"    File: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
filename
          FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"    Cache file: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
cachefile
          IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesFileExist_ FilePath
cachefile)
              (FilePath -> IO ()
putStrLn FilePath
"      Error: cache file does not exist") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              IO Bool -> IO () -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((FileHash -> FileHash -> Bool
forall a. Eq a => a -> a -> Bool
/= FileHash
keyHash) (FileHash -> Bool) -> IO FileHash -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileName -> IO FileHash
getFileHash (FilePath -> FileName
fileNameFromString FilePath
cachefile))
                  (FilePath -> IO ()
putStrLn FilePath
"      Error: cache file hash does not match stored hash")
                  (FilePath -> IO ()
putStrLn FilePath
"      OK")