{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}
module Distribution.Client.Store (
StoreDirLayout(..),
defaultStoreDirLayout,
getStoreEntries,
doesStoreEntryExist,
newStoreEntry,
NewStoreEntryOutcome(..),
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.DistDirLayout
import Distribution.Client.RebuildMonad
import Distribution.Package (UnitId, mkUnitId)
import Distribution.Compiler (CompilerId)
import Distribution.Simple.Utils
( withTempDirectory, debug, info )
import Distribution.Verbosity
( silent )
import qualified Data.Set as Set
import Control.Exception
import System.FilePath
import System.Directory
#ifdef MIN_VERSION_lukko
import Lukko
#else
import System.IO (openFile, IOMode(ReadWriteMode), hClose)
import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))
#if MIN_VERSION_base(4,11,0)
import GHC.IO.Handle.Lock (hUnlock)
#endif
#endif
doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool
doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool
doesStoreEntryExist StoreDirLayout{CompilerId -> UnitId -> FilePath
storePackageDirectory :: StoreDirLayout -> CompilerId -> UnitId -> FilePath
storePackageDirectory :: CompilerId -> UnitId -> FilePath
storePackageDirectory} CompilerId
compid UnitId
unitid =
FilePath -> IO Bool
doesDirectoryExist (CompilerId -> UnitId -> FilePath
storePackageDirectory CompilerId
compid UnitId
unitid)
getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)
getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)
getStoreEntries StoreDirLayout{CompilerId -> FilePath
storeDirectory :: StoreDirLayout -> CompilerId -> FilePath
storeDirectory :: CompilerId -> FilePath
storeDirectory} CompilerId
compid = do
[FilePath]
paths <- FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored (CompilerId -> FilePath
storeDirectory CompilerId
compid)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [FilePath] -> Set UnitId
mkEntries [FilePath]
paths
where
mkEntries :: [FilePath] -> Set UnitId
mkEntries = forall a. Ord a => a -> Set a -> Set a
Set.delete (FilePath -> UnitId
mkUnitId FilePath
"package.db")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> Set a -> Set a
Set.delete (FilePath -> UnitId
mkUnitId FilePath
"incoming")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map FilePath -> UnitId
mkUnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
valid
valid :: FilePath -> Bool
valid (Char
'.':FilePath
_) = Bool
False
valid FilePath
_ = Bool
True
data NewStoreEntryOutcome = UseNewStoreEntry
| UseExistingStoreEntry
deriving (NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
$c/= :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
== :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
$c== :: NewStoreEntryOutcome -> NewStoreEntryOutcome -> Bool
Eq, Int -> NewStoreEntryOutcome -> ShowS
[NewStoreEntryOutcome] -> ShowS
NewStoreEntryOutcome -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [NewStoreEntryOutcome] -> ShowS
$cshowList :: [NewStoreEntryOutcome] -> ShowS
show :: NewStoreEntryOutcome -> FilePath
$cshow :: NewStoreEntryOutcome -> FilePath
showsPrec :: Int -> NewStoreEntryOutcome -> ShowS
$cshowsPrec :: Int -> NewStoreEntryOutcome -> ShowS
Show)
newStoreEntry :: Verbosity
-> StoreDirLayout
-> CompilerId
-> UnitId
-> (FilePath -> IO (FilePath, [FilePath]))
-> IO ()
-> IO NewStoreEntryOutcome
newStoreEntry :: Verbosity
-> StoreDirLayout
-> CompilerId
-> UnitId
-> (FilePath -> IO (FilePath, [FilePath]))
-> IO ()
-> IO NewStoreEntryOutcome
newStoreEntry Verbosity
verbosity storeDirLayout :: StoreDirLayout
storeDirLayout@StoreDirLayout{CompilerId -> FilePath
CompilerId -> PackageDBStack
CompilerId -> PackageDB
CompilerId -> UnitId -> FilePath
storeIncomingLock :: StoreDirLayout -> CompilerId -> UnitId -> FilePath
storeIncomingDirectory :: StoreDirLayout -> CompilerId -> FilePath
storePackageDBStack :: StoreDirLayout -> CompilerId -> PackageDBStack
storePackageDB :: StoreDirLayout -> CompilerId -> PackageDB
storePackageDBPath :: StoreDirLayout -> CompilerId -> FilePath
storeIncomingLock :: CompilerId -> UnitId -> FilePath
storeIncomingDirectory :: CompilerId -> FilePath
storePackageDBStack :: CompilerId -> PackageDBStack
storePackageDB :: CompilerId -> PackageDB
storePackageDBPath :: CompilerId -> FilePath
storePackageDirectory :: CompilerId -> UnitId -> FilePath
storeDirectory :: CompilerId -> FilePath
storeDirectory :: StoreDirLayout -> CompilerId -> FilePath
storePackageDirectory :: StoreDirLayout -> CompilerId -> UnitId -> FilePath
..}
CompilerId
compid UnitId
unitid
FilePath -> IO (FilePath, [FilePath])
copyFiles IO ()
register =
forall a.
StoreDirLayout -> CompilerId -> (FilePath -> IO a) -> IO a
withTempIncomingDir StoreDirLayout
storeDirLayout CompilerId
compid forall a b. (a -> b) -> a -> b
$ \FilePath
incomingTmpDir -> do
(FilePath
incomingEntryDir, [FilePath]
otherFiles) <- FilePath -> IO (FilePath, [FilePath])
copyFiles FilePath
incomingTmpDir
forall a.
Verbosity -> StoreDirLayout -> CompilerId -> UnitId -> IO a -> IO a
withIncomingUnitIdLock Verbosity
verbosity StoreDirLayout
storeDirLayout CompilerId
compid UnitId
unitid forall a b. (a -> b) -> a -> b
$ do
Bool
exists <- StoreDirLayout -> CompilerId -> UnitId -> IO Bool
doesStoreEntryExist StoreDirLayout
storeDirLayout CompilerId
compid UnitId
unitid
if Bool
exists
then do
Verbosity -> FilePath -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"Concurrent build race: abandoning build in favour of existing "
forall a. [a] -> [a] -> [a]
++ FilePath
"store entry " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compid FilePath -> ShowS
</> forall a. Pretty a => a -> FilePath
prettyShow UnitId
unitid
forall (m :: * -> *) a. Monad m => a -> m a
return NewStoreEntryOutcome
UseExistingStoreEntry
else do
IO ()
register
FilePath -> FilePath -> IO ()
renameDirectory FilePath
incomingEntryDir FilePath
finalEntryDir
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
otherFiles forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
let finalStoreFile :: FilePath
finalStoreFile = CompilerId -> FilePath
storeDirectory CompilerId
compid FilePath -> ShowS
</> FilePath -> ShowS
makeRelative (FilePath
incomingTmpDir FilePath -> ShowS
</> (ShowS
dropDrive (CompilerId -> FilePath
storeDirectory CompilerId
compid))) FilePath
file
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
finalStoreFile)
FilePath -> FilePath -> IO ()
renameFile FilePath
file FilePath
finalStoreFile
Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"Installed store entry " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compid FilePath -> ShowS
</> forall a. Pretty a => a -> FilePath
prettyShow UnitId
unitid
forall (m :: * -> *) a. Monad m => a -> m a
return NewStoreEntryOutcome
UseNewStoreEntry
where
finalEntryDir :: FilePath
finalEntryDir = CompilerId -> UnitId -> FilePath
storePackageDirectory CompilerId
compid UnitId
unitid
withTempIncomingDir :: StoreDirLayout -> CompilerId
-> (FilePath -> IO a) -> IO a
withTempIncomingDir :: forall a.
StoreDirLayout -> CompilerId -> (FilePath -> IO a) -> IO a
withTempIncomingDir StoreDirLayout{CompilerId -> FilePath
storeIncomingDirectory :: CompilerId -> FilePath
storeIncomingDirectory :: StoreDirLayout -> CompilerId -> FilePath
storeIncomingDirectory} CompilerId
compid FilePath -> IO a
action = do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
incomingDir
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
silent FilePath
incomingDir FilePath
"new" FilePath -> IO a
action
where
incomingDir :: FilePath
incomingDir = CompilerId -> FilePath
storeIncomingDirectory CompilerId
compid
withIncomingUnitIdLock :: Verbosity -> StoreDirLayout
-> CompilerId -> UnitId
-> IO a -> IO a
withIncomingUnitIdLock :: forall a.
Verbosity -> StoreDirLayout -> CompilerId -> UnitId -> IO a -> IO a
withIncomingUnitIdLock Verbosity
verbosity StoreDirLayout{CompilerId -> UnitId -> FilePath
storeIncomingLock :: CompilerId -> UnitId -> FilePath
storeIncomingLock :: StoreDirLayout -> CompilerId -> UnitId -> FilePath
storeIncomingLock}
CompilerId
compid UnitId
unitid IO a
action =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FD
takeLock FD -> IO ()
releaseLock (\FD
_hnd -> IO a
action)
where
#ifdef MIN_VERSION_lukko
takeLock :: IO FD
takeLock
| Bool
fileLockingSupported = do
FD
fd <- FilePath -> IO FD
fdOpen (CompilerId -> UnitId -> FilePath
storeIncomingLock CompilerId
compid UnitId
unitid)
Bool
gotLock <- FD -> LockMode -> IO Bool
fdTryLock FD
fd LockMode
ExclusiveLock
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
gotLock forall a b. (a -> b) -> a -> b
$ do
Verbosity -> FilePath -> IO ()
info Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Waiting for file lock on store entry "
forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow CompilerId
compid FilePath -> ShowS
</> forall a. Pretty a => a -> FilePath
prettyShow UnitId
unitid
FD -> LockMode -> IO ()
fdLock FD
fd LockMode
ExclusiveLock
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. HasCallStack => a
undefined
releaseLock :: FD -> IO ()
releaseLock FD
fd
| Bool
fileLockingSupported = do
FD -> IO ()
fdUnlock FD
fd
FD -> IO ()
fdClose FD
fd
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#else
takeLock = do
h <- openFile (storeIncomingLock compid unitid) ReadWriteMode
gotlock <- hTryLock h ExclusiveLock
unless gotlock $ do
info verbosity $ "Waiting for file lock on store entry "
++ prettyShow compid </> prettyShow unitid
hLock h ExclusiveLock
return h
releaseLock h = hUnlock h >> hClose h
#endif