module Darcs.Util.Cache
    ( Cache
    , mkCache
    , mkDirCache
    , mkRepoCache
    , cacheEntries
    , CacheType(..)
    , CacheLoc(..)
    , WritableOrNot(..)
    , HashedDir(..)
    , hashedDir
    , bucketFolder
    , filterRemoteCaches
    , cleanCaches
    , cleanCachesWithHint
    , fetchFileUsingCache
    , speculateFileUsingCache
    , speculateFilesUsingCache
    , writeFileUsingCache
    , peekInCache
    , parseCacheLoc
    , showCacheLoc
    , writable
    , isThisRepo
    , hashedFilePath
    , allHashedDirs
    , reportBadSources
    , closestWritableDirectory
    , dropNonRepos
    ) where

import Control.Concurrent.MVar ( MVar, modifyMVar_, newMVar, readMVar )
import Control.Monad ( filterM, forM_, liftM, mplus, unless, when )
import qualified Data.ByteString as B ( ByteString )
import Data.List ( intercalate, nub, sortBy )
import Data.Maybe ( catMaybes, fromMaybe, listToMaybe )
import System.Directory
    ( createDirectoryIfMissing
    , doesDirectoryExist
    , doesFileExist
    , getDirectoryContents
    , getPermissions
    , removeFile
    , withCurrentDirectory
    )
import qualified System.Directory as SD ( writable )
import System.FilePath.Posix ( dropFileName, joinPath, (</>) )
import System.IO ( hPutStrLn, stderr )
import System.IO.Error ( isAlreadyExistsError )
import System.IO.Unsafe ( unsafePerformIO )
import System.Posix.Files ( createLink, getSymbolicLinkStatus, linkCount )
import Text.Regex.Applicative ( anySym, many, match, string, (<|>) )

import Darcs.Prelude

import Darcs.Util.ByteString ( gzWriteFilePS )
import Darcs.Util.English ( Noun(..), Pronoun(..), englishNum )
import Darcs.Util.Exception ( catchall, handleOnly )
import Darcs.Util.File
    ( Cachable(Cachable)
    , copyFileOrUrl
    , fetchFilePS
    , gzFetchFilePS
    , speculateFileOrUrl
    , withTemp
    )
import Darcs.Util.Global ( darcsdir, defaultRemoteDarcsCmd )
import Darcs.Util.Lock ( gzWriteAtomicFilePS )
import Darcs.Util.Progress ( debugMessage, progressList )
import Darcs.Util.URL ( isHttpUrl, isSshUrl, isValidLocalPath )
import Darcs.Util.ValidHash
    ( ValidHash(..)
    , HashedDir(..)
    , checkHash
    , encodeValidHash
    , okayHash
    , calcValidHash
    )

-- * Caches

hashedDir :: HashedDir -> FilePath
hashedDir :: HashedDir -> String
hashedDir HashedDir
HashedPristineDir = String
"pristine.hashed"
hashedDir HashedDir
HashedPatchesDir = String
"patches"
hashedDir HashedDir
HashedInventoriesDir = String
"inventories"

allHashedDirs :: [HashedDir]
allHashedDirs :: [HashedDir]
allHashedDirs = [ HashedDir
HashedPristineDir
                , HashedDir
HashedPatchesDir
                , HashedDir
HashedInventoriesDir
                ]

data WritableOrNot = Writable
                   | NotWritable
                   deriving ( WritableOrNot -> WritableOrNot -> Bool
(WritableOrNot -> WritableOrNot -> Bool)
-> (WritableOrNot -> WritableOrNot -> Bool) -> Eq WritableOrNot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WritableOrNot -> WritableOrNot -> Bool
== :: WritableOrNot -> WritableOrNot -> Bool
$c/= :: WritableOrNot -> WritableOrNot -> Bool
/= :: WritableOrNot -> WritableOrNot -> Bool
Eq, Int -> WritableOrNot -> ShowS
[WritableOrNot] -> ShowS
WritableOrNot -> String
(Int -> WritableOrNot -> ShowS)
-> (WritableOrNot -> String)
-> ([WritableOrNot] -> ShowS)
-> Show WritableOrNot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WritableOrNot -> ShowS
showsPrec :: Int -> WritableOrNot -> ShowS
$cshow :: WritableOrNot -> String
show :: WritableOrNot -> String
$cshowList :: [WritableOrNot] -> ShowS
showList :: [WritableOrNot] -> ShowS
Show )

data CacheType = Repo
               | Directory
               deriving ( CacheType -> CacheType -> Bool
(CacheType -> CacheType -> Bool)
-> (CacheType -> CacheType -> Bool) -> Eq CacheType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheType -> CacheType -> Bool
== :: CacheType -> CacheType -> Bool
$c/= :: CacheType -> CacheType -> Bool
/= :: CacheType -> CacheType -> Bool
Eq, Int -> CacheType -> ShowS
[CacheType] -> ShowS
CacheType -> String
(Int -> CacheType -> ShowS)
-> (CacheType -> String)
-> ([CacheType] -> ShowS)
-> Show CacheType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CacheType -> ShowS
showsPrec :: Int -> CacheType -> ShowS
$cshow :: CacheType -> String
show :: CacheType -> String
$cshowList :: [CacheType] -> ShowS
showList :: [CacheType] -> ShowS
Show )

data CacheLoc = Cache
    { CacheLoc -> CacheType
cacheType :: !CacheType
    , CacheLoc -> WritableOrNot
cacheWritable :: !WritableOrNot
    , CacheLoc -> String
cacheSource :: !String
    }

-- | Cache is an abstract type for hiding the underlying cache locations
newtype Cache = Ca [CacheLoc]

-- | Smart constructor for 'Cache'.
mkCache :: [CacheLoc] -> Cache
mkCache :: [CacheLoc] -> Cache
mkCache = [CacheLoc] -> Cache
Ca ([CacheLoc] -> Cache)
-> ([CacheLoc] -> [CacheLoc]) -> [CacheLoc] -> Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CacheLoc] -> [CacheLoc]
forall a. Eq a => [a] -> [a]
nub ([CacheLoc] -> [CacheLoc])
-> ([CacheLoc] -> [CacheLoc]) -> [CacheLoc] -> [CacheLoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CacheLoc -> CacheLoc -> Ordering) -> [CacheLoc] -> [CacheLoc]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy CacheLoc -> CacheLoc -> Ordering
compareByLocality

mkDirCache :: FilePath -> Cache
mkDirCache :: String -> Cache
mkDirCache String
dir = [CacheLoc] -> Cache
mkCache [CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Directory WritableOrNot
Writable String
dir]

mkRepoCache :: FilePath -> Cache
mkRepoCache :: String -> Cache
mkRepoCache String
dir = [CacheLoc] -> Cache
mkCache [CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Repo WritableOrNot
Writable String
dir]

cacheEntries :: Cache -> [CacheLoc]
cacheEntries :: Cache -> [CacheLoc]
cacheEntries (Ca [CacheLoc]
entries) = [CacheLoc]
entries

-- | Note: this non-structural instance ignores the 'cacheWritable' field. This
-- is so that when we 'nub' a list of locations we retain only one (the first)
-- variant.
instance Eq CacheLoc where
    (Cache CacheType
aTy WritableOrNot
_ String
aSrc) == :: CacheLoc -> CacheLoc -> Bool
== (Cache CacheType
bTy WritableOrNot
_ String
bSrc) = CacheType
aTy CacheType -> CacheType -> Bool
forall a. Eq a => a -> a -> Bool
== CacheType
bTy Bool -> Bool -> Bool
&& String
aSrc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
bSrc

showCacheLoc :: CacheLoc -> String
showCacheLoc :: CacheLoc -> String
showCacheLoc (Cache CacheType
Repo WritableOrNot
Writable String
a) = String
"thisrepo:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a
showCacheLoc (Cache CacheType
Repo WritableOrNot
NotWritable String
a) = String
"repo:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a
showCacheLoc (Cache CacheType
Directory WritableOrNot
Writable String
a) = String
"cache:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a
showCacheLoc (Cache CacheType
Directory WritableOrNot
NotWritable String
a) = String
"readonly:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a

instance Show Cache where
    show :: Cache -> String
show (Ca [CacheLoc]
cs) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (CacheLoc -> String) -> [CacheLoc] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map CacheLoc -> String
showCacheLoc [CacheLoc]
cs

parseCacheLoc :: String -> Maybe CacheLoc
parseCacheLoc :: String -> Maybe CacheLoc
parseCacheLoc = RE Char CacheLoc -> String -> Maybe CacheLoc
forall s a. RE s a -> [s] -> Maybe a
match RE Char CacheLoc
reCacheLoc
  where
    reCacheLoc :: RE Char CacheLoc
reCacheLoc =
      CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Repo WritableOrNot
Writable (String -> CacheLoc) -> RE Char String -> RE Char CacheLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
"thisrepo:" RE Char String -> RE Char String -> RE Char String
forall a b. RE Char a -> RE Char b -> RE Char b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
forall {a}. RE a [a]
rest) RE Char CacheLoc -> RE Char CacheLoc -> RE Char CacheLoc
forall a. RE Char a -> RE Char a -> RE Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Repo WritableOrNot
NotWritable (String -> CacheLoc) -> RE Char String -> RE Char CacheLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
"repo:" RE Char String -> RE Char String -> RE Char String
forall a b. RE Char a -> RE Char b -> RE Char b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
forall {a}. RE a [a]
rest) RE Char CacheLoc -> RE Char CacheLoc -> RE Char CacheLoc
forall a. RE Char a -> RE Char a -> RE Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Directory WritableOrNot
Writable (String -> CacheLoc) -> RE Char String -> RE Char CacheLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
"cache:" RE Char String -> RE Char String -> RE Char String
forall a b. RE Char a -> RE Char b -> RE Char b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
forall {a}. RE a [a]
rest) RE Char CacheLoc -> RE Char CacheLoc -> RE Char CacheLoc
forall a. RE Char a -> RE Char a -> RE Char a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Directory WritableOrNot
NotWritable (String -> CacheLoc) -> RE Char String -> RE Char CacheLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> RE Char String
forall a. Eq a => [a] -> RE a [a]
string String
"readonly:" RE Char String -> RE Char String -> RE Char String
forall a b. RE Char a -> RE Char b -> RE Char b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> RE Char String
forall {a}. RE a [a]
rest)
    rest :: RE a [a]
rest = RE a a -> RE a [a]
forall a. RE a a -> RE a [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many RE a a
forall s. RE s s
anySym

-- | Filter caches for remote repos. This affects only entries that are locally
-- valid paths (i.e. not network URLs): they are removed if non-existent, or
-- demoted to NotWritable if they are not actually writable in the file system.
filterRemoteCaches :: Cache -> IO Cache
filterRemoteCaches :: Cache -> IO Cache
filterRemoteCaches (Ca [CacheLoc]
remote) = [CacheLoc] -> Cache
mkCache ([CacheLoc] -> Cache)
-> ([Maybe CacheLoc] -> [CacheLoc]) -> [Maybe CacheLoc] -> Cache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe CacheLoc] -> [CacheLoc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CacheLoc] -> Cache) -> IO [Maybe CacheLoc] -> IO Cache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Maybe CacheLoc]
filtered
  where
    filtered :: IO [Maybe CacheLoc]
filtered = (CacheLoc -> IO (Maybe CacheLoc))
-> [CacheLoc] -> IO [Maybe CacheLoc]
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 (\CacheLoc
x -> CacheLoc -> IO (Maybe CacheLoc)
mbGetRemoteCacheLoc CacheLoc
x IO (Maybe CacheLoc) -> IO (Maybe CacheLoc) -> IO (Maybe CacheLoc)
forall a. IO a -> IO a -> IO a
`catchall` Maybe CacheLoc -> IO (Maybe CacheLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CacheLoc
forall a. Maybe a
Nothing) [CacheLoc]
remote
    mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc)
    mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc)
mbGetRemoteCacheLoc c :: CacheLoc
c@(Cache CacheType
t WritableOrNot
_ String
url)
        | String -> Bool
isValidLocalPath String
url = do
            Bool
ex <- String -> IO Bool
doesDirectoryExist String
url
            if Bool
ex
                then do
                    Permissions
p <- String -> IO Permissions
getPermissions String
url
                    Maybe CacheLoc -> IO (Maybe CacheLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CacheLoc -> IO (Maybe CacheLoc))
-> Maybe CacheLoc -> IO (Maybe CacheLoc)
forall a b. (a -> b) -> a -> b
$ CacheLoc -> Maybe CacheLoc
forall a. a -> Maybe a
Just (CacheLoc -> Maybe CacheLoc) -> CacheLoc -> Maybe CacheLoc
forall a b. (a -> b) -> a -> b
$ if CacheLoc -> Bool
writable CacheLoc
c Bool -> Bool -> Bool
&& Permissions -> Bool
SD.writable Permissions
p
                                        then CacheLoc
c
                                        else CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
t WritableOrNot
NotWritable String
url
                else Maybe CacheLoc -> IO (Maybe CacheLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CacheLoc
forall a. Maybe a
Nothing
        | Bool
otherwise = Maybe CacheLoc -> IO (Maybe CacheLoc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CacheLoc -> IO (Maybe CacheLoc))
-> Maybe CacheLoc -> IO (Maybe CacheLoc)
forall a b. (a -> b) -> a -> b
$ CacheLoc -> Maybe CacheLoc
forall a. a -> Maybe a
Just CacheLoc
c

-- | Compares two caches, a remote cache is greater than a local one.
-- The order of the comparison is given by: local < http < ssh
compareByLocality :: CacheLoc -> CacheLoc -> Ordering
compareByLocality :: CacheLoc -> CacheLoc -> Ordering
compareByLocality (Cache CacheType
_ WritableOrNot
w String
x) (Cache CacheType
_ WritableOrNot
z String
y)
    | String -> Bool
isValidLocalPath String
x Bool -> Bool -> Bool
&& String -> Bool
isRemote String
y  = Ordering
LT
    | String -> Bool
isRemote String
x Bool -> Bool -> Bool
&& String -> Bool
isValidLocalPath String
y = Ordering
GT
    | String -> Bool
isHttpUrl String
x Bool -> Bool -> Bool
&& String -> Bool
isSshUrl String
y = Ordering
LT
    | String -> Bool
isSshUrl String
x Bool -> Bool -> Bool
&& String -> Bool
isHttpUrl String
y = Ordering
GT
    | String -> Bool
isValidLocalPath String
x Bool -> Bool -> Bool
&& WritableOrNot -> Bool
isWritable WritableOrNot
w
        Bool -> Bool -> Bool
&& String -> Bool
isValidLocalPath String
y Bool -> Bool -> Bool
&& WritableOrNot -> Bool
isNotWritable WritableOrNot
z = Ordering
LT
    | Bool
otherwise = Ordering
EQ
  where
    isRemote :: String -> Bool
isRemote String
r = String -> Bool
isHttpUrl String
r Bool -> Bool -> Bool
|| String -> Bool
isSshUrl String
r
    isWritable :: WritableOrNot -> Bool
isWritable = WritableOrNot -> WritableOrNot -> Bool
forall a. Eq a => a -> a -> Bool
(==) WritableOrNot
Writable
    isNotWritable :: WritableOrNot -> Bool
isNotWritable = WritableOrNot -> WritableOrNot -> Bool
forall a. Eq a => a -> a -> Bool
(==) WritableOrNot
NotWritable

-- |@fetchFileUsingCache cache dir hash@ receives a list of caches @cache@, the
-- directory for which that file belongs @dir@ and the @hash@ of the file to
-- fetch.  It tries to fetch the file from one of the sources, trying them in
-- order one by one.  If the file cannot be fetched from any of the sources,
-- this operation fails. Otherwise we return the path where we found the file
-- and its content.
fetchFileUsingCache :: ValidHash h => Cache -> h
                    -> IO (FilePath, B.ByteString)
fetchFileUsingCache :: forall h. ValidHash h => Cache -> h -> IO (String, ByteString)
fetchFileUsingCache = FromWhere -> Cache -> h -> IO (String, ByteString)
forall h.
ValidHash h =>
FromWhere -> Cache -> h -> IO (String, ByteString)
fetchFileUsingCachePrivate FromWhere
Anywhere

writable :: CacheLoc -> Bool
writable :: CacheLoc -> Bool
writable (Cache CacheType
_ WritableOrNot
NotWritable String
_) = Bool
False
writable (Cache CacheType
_ WritableOrNot
Writable String
_) = Bool
True

-- | This keeps only 'Repo' 'NotWritable' entries.
dropNonRepos :: Cache -> Cache
dropNonRepos :: Cache -> Cache
dropNonRepos (Ca [CacheLoc]
cache) = [CacheLoc] -> Cache
Ca ([CacheLoc] -> Cache) -> [CacheLoc] -> Cache
forall a b. (a -> b) -> a -> b
$ (CacheLoc -> Bool) -> [CacheLoc] -> [CacheLoc]
forall a. (a -> Bool) -> [a] -> [a]
filter CacheLoc -> Bool
notRepo [CacheLoc]
cache where
  notRepo :: CacheLoc -> Bool
notRepo CacheLoc
xs = case CacheLoc
xs of
    Cache CacheType
Directory WritableOrNot
_ String
_ -> Bool
False
    -- we don't want to write thisrepo: entries to the disk
    Cache CacheType
Repo WritableOrNot
Writable String
_ -> Bool
False
    CacheLoc
_ -> Bool
True

closestWritableDirectory :: Cache -> Maybe String
closestWritableDirectory :: Cache -> Maybe String
closestWritableDirectory (Ca [CacheLoc]
cs) =
  [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String)
-> ((CacheLoc -> Maybe String) -> [String])
-> (CacheLoc -> Maybe String)
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String])
-> ((CacheLoc -> Maybe String) -> [Maybe String])
-> (CacheLoc -> Maybe String)
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.((CacheLoc -> Maybe String) -> [CacheLoc] -> [Maybe String])
-> [CacheLoc] -> (CacheLoc -> Maybe String) -> [Maybe String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CacheLoc -> Maybe String) -> [CacheLoc] -> [Maybe String]
forall a b. (a -> b) -> [a] -> [b]
map [CacheLoc]
cs ((CacheLoc -> Maybe String) -> Maybe String)
-> (CacheLoc -> Maybe String) -> Maybe String
forall a b. (a -> b) -> a -> b
$ \case
    Cache CacheType
Directory WritableOrNot
Writable String
x -> String -> Maybe String
forall a. a -> Maybe a
Just String
x
    CacheLoc
_ -> Maybe String
forall a. Maybe a
Nothing

isThisRepo :: CacheLoc -> Bool
isThisRepo :: CacheLoc -> Bool
isThisRepo (Cache CacheType
Repo WritableOrNot
Writable String
_) = Bool
True
isThisRepo CacheLoc
_ = Bool
False

bucketFolder :: FilePath -> FilePath
bucketFolder :: ShowS
bucketFolder String
f = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2 (ShowS
cleanHash String
f)
    where
        cleanHash :: ShowS
cleanHash String
fileName = case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') String
fileName of
            []  -> String
fileName
            String
s   -> Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
s

-- | The full filepath of a simple file name inside a given 'CacheLoc'
-- under 'HashedDir'.
hashedFilePath :: CacheLoc -> HashedDir -> FilePath -> FilePath
hashedFilePath :: CacheLoc -> HashedDir -> ShowS
hashedFilePath (Cache CacheType
Directory WritableOrNot
Writable String
d) HashedDir
s String
f =
    [String] -> String
joinPath [String
d, HashedDir -> String
hashedDir HashedDir
s, ShowS
bucketFolder String
f, String
f]
hashedFilePath (Cache CacheType
Directory WritableOrNot
NotWritable String
d) HashedDir
s String
f =
    [String] -> String
joinPath [String
d, HashedDir -> String
hashedDir HashedDir
s, String
f]
hashedFilePath (Cache CacheType
Repo WritableOrNot
_ String
r) HashedDir
s String
f =
    [String] -> String
joinPath [String
r, String
darcsdir, HashedDir -> String
hashedDir HashedDir
s, String
f]

-- | Return whether the 'Cache' contains a file with the given hash in a
-- writable position.
peekInCache :: ValidHash h => Cache -> h -> IO Bool
peekInCache :: forall h. ValidHash h => Cache -> h -> IO Bool
peekInCache (Ca [CacheLoc]
cache) h
sh = [CacheLoc] -> IO Bool
cacheHasIt [CacheLoc]
cache IO Bool -> IO Bool -> IO Bool
forall a. IO a -> IO a -> IO a
`catchall` Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    subdir :: HashedDir
subdir = h -> HashedDir
forall h. ValidHash h => h -> HashedDir
dirofValidHash h
sh
    cacheHasIt :: [CacheLoc] -> IO Bool
cacheHasIt [] = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    cacheHasIt (CacheLoc
c : [CacheLoc]
cs)
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CacheLoc -> Bool
writable CacheLoc
c = [CacheLoc] -> IO Bool
cacheHasIt [CacheLoc]
cs
        | Bool
otherwise = do
            Bool
ex <- String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir (h -> String
forall h. ValidHash h => h -> String
encodeValidHash h
sh)
            if Bool
ex then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else [CacheLoc] -> IO Bool
cacheHasIt [CacheLoc]
cs

-- | Add pipelined downloads to the (low-priority) queue, for the rest it is a noop.
speculateFileUsingCache :: ValidHash h => Cache -> h -> IO ()
speculateFileUsingCache :: forall h. ValidHash h => Cache -> h -> IO ()
speculateFileUsingCache Cache
c h
hash = do
    let filename :: String
filename = h -> String
forall h. ValidHash h => h -> String
encodeValidHash h
hash
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filename
    OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()
copyFileUsingCache OrOnlySpeculate
OnlySpeculate Cache
c (h -> HashedDir
forall h. ValidHash h => h -> HashedDir
dirofValidHash h
hash) String
filename

-- | Do 'speculateFilesUsingCache' for files not already in a writable cache
-- position.
speculateFilesUsingCache :: ValidHash h => Cache -> [h] -> IO ()
speculateFilesUsingCache :: forall h. ValidHash h => Cache -> [h] -> IO ()
speculateFilesUsingCache Cache
_ [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
speculateFilesUsingCache Cache
cache [h]
hs = do
    [h]
hs' <- (h -> IO Bool) -> [h] -> IO [h]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool) -> (h -> IO Bool) -> h -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache -> h -> IO Bool
forall h. ValidHash h => Cache -> h -> IO Bool
peekInCache Cache
cache) [h]
hs
    [h] -> (h -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [h]
hs' ((h -> IO ()) -> IO ()) -> (h -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Cache -> h -> IO ()
forall h. ValidHash h => Cache -> h -> IO ()
speculateFileUsingCache Cache
cache

data OrOnlySpeculate = ActuallyCopy
                     | OnlySpeculate
                     deriving ( OrOnlySpeculate -> OrOnlySpeculate -> Bool
(OrOnlySpeculate -> OrOnlySpeculate -> Bool)
-> (OrOnlySpeculate -> OrOnlySpeculate -> Bool)
-> Eq OrOnlySpeculate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
== :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
$c/= :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
/= :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
Eq, Int -> OrOnlySpeculate -> ShowS
[OrOnlySpeculate] -> ShowS
OrOnlySpeculate -> String
(Int -> OrOnlySpeculate -> ShowS)
-> (OrOnlySpeculate -> String)
-> ([OrOnlySpeculate] -> ShowS)
-> Show OrOnlySpeculate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OrOnlySpeculate -> ShowS
showsPrec :: Int -> OrOnlySpeculate -> ShowS
$cshow :: OrOnlySpeculate -> String
show :: OrOnlySpeculate -> String
$cshowList :: [OrOnlySpeculate] -> ShowS
showList :: [OrOnlySpeculate] -> ShowS
Show )

-- | If the first parameter of type 'OrOnlySpeculate' is 'ActuallyCopy', try to
-- ensure that a file with the given name (hash) exists in a writable location
-- (which means in particular that it is stored in the local file system). If
-- it is 'OnlySpeculate', then merely schedule download of that file into such
-- a location (the actual download will be executed asynchronously).
--
-- If the file is already present in some writeable location, or if there is no
-- writable location at all, this procedure does nothing.
--
-- If the copy should occur between two locations of the same filesystem, a
-- hard link is made.
--
-- If the first parameter is 'ActuallyCopy', use 'copyFileOrUrl' and try to
-- find the file in any non-writable location. Otherwise ('OnlySpeculate'), use
-- 'speculateFileOrUrl' and try only the first non-writable location (which
-- makes sense since 'speculateFileOrUrl' is asynchronous and thus can't fail
-- in any interesting way).
copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> FilePath -> IO ()
copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()
copyFileUsingCache OrOnlySpeculate
oos (Ca [CacheLoc]
cache) HashedDir
subdir String
f = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"copyFileUsingCache:", OrOnlySpeculate -> String
forall a. Show a => a -> String
show OrOnlySpeculate
oos, HashedDir -> String
hashedDir HashedDir
subdir, String
f]
    Just String
stickItHere <- [CacheLoc] -> IO (Maybe String)
cacheLoc [CacheLoc]
cache
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
dropFileName String
stickItHere)
    [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cache IO [CacheLoc] -> ([CacheLoc] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [CacheLoc] -> IO ()
sfuc String
stickItHere
    IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall`
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- Return last writeable cache/repo location for file 'f'.
    -- Usually returns the global cache unless `--no-cache` is passed.
    -- Throws exception if file already exists in a writable location.
    cacheLoc :: [CacheLoc] -> IO (Maybe String)
cacheLoc [] = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
    cacheLoc (CacheLoc
c : [CacheLoc]
cs)
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CacheLoc -> Bool
writable CacheLoc
c = [CacheLoc] -> IO (Maybe String)
cacheLoc [CacheLoc]
cs
        | Bool
otherwise = do
            let attemptPath :: String
attemptPath = CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
f
            Bool
ex <- String -> IO Bool
doesFileExist String
attemptPath
            if Bool
ex
                then String -> IO (Maybe String)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"File already present in writable location."
                else do
                    Maybe String
othercache <- [CacheLoc] -> IO (Maybe String)
cacheLoc [CacheLoc]
cs
                    Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe String
othercache Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> Maybe String
forall a. a -> Maybe a
Just String
attemptPath
    -- Do the actual copy, or hard link, or put file in download queue. This
    -- tries to find the file in all non-writable locations, in order, unless
    -- we have OnlySpeculate.
    sfuc :: String -> [CacheLoc] -> IO ()
sfuc String
_ [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    sfuc String
out (CacheLoc
c : [CacheLoc]
cs)
        | Bool -> Bool
not (CacheLoc -> Bool
writable CacheLoc
c) =
            let cacheFile :: String
cacheFile = CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
f in
            case OrOnlySpeculate
oos of
                OrOnlySpeculate
OnlySpeculate ->
                     String -> String -> IO ()
speculateFileOrUrl String
cacheFile String
out
                     IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall`
                     CacheLoc -> IO ()
checkCacheReachability CacheLoc
c
                OrOnlySpeculate
ActuallyCopy ->
                     do String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                          String
"Copying from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
cacheFile String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
out
                        String -> String -> String -> Cachable -> IO ()
copyFileOrUrl String
defaultRemoteDarcsCmd String
cacheFile String
out Cachable
Cachable
                     IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall`
                     (do CacheLoc -> IO ()
checkCacheReachability CacheLoc
c
                         String -> [CacheLoc] -> IO ()
sfuc String
out [CacheLoc]
cs) -- try another read-only location
        | Bool
otherwise = String -> [CacheLoc] -> IO ()
sfuc String
out [CacheLoc]
cs

data FromWhere = LocalOnly
               | Anywhere
               deriving ( FromWhere -> FromWhere -> Bool
(FromWhere -> FromWhere -> Bool)
-> (FromWhere -> FromWhere -> Bool) -> Eq FromWhere
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FromWhere -> FromWhere -> Bool
== :: FromWhere -> FromWhere -> Bool
$c/= :: FromWhere -> FromWhere -> Bool
/= :: FromWhere -> FromWhere -> Bool
Eq )

-- | Checks if a given cache entry is reachable or not.  It receives an error
-- caught during execution and the cache entry.  If the caches is not reachable
-- it is blacklisted and not longer tried for the rest of the session. If it is
-- reachable it is whitelisted and future errors with such cache get ignore.
-- To determine reachability:
--  * For a local cache, if the given source doesn't exist anymore, it is
--    blacklisted.
--  * For remote sources if the error is timeout, it is blacklisted, if not,
--    it checks if _darcs/hashed_inventory  exist, if it does, the entry is
--    whitelisted, if it doesn't, it is blacklisted.
checkCacheReachability :: CacheLoc -> IO ()
checkCacheReachability :: CacheLoc -> IO ()
checkCacheReachability CacheLoc
cache
    | String -> Bool
isValidLocalPath String
source = IO () -> IO ()
doUnreachableCheck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Bool -> IO ()
checkFileReachability (String -> IO Bool
doesDirectoryExist String
source)
    | String -> Bool
isHttpUrl String
source = IO () -> IO ()
doUnreachableCheck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Bool -> IO ()
checkFileReachability (CacheLoc -> IO Bool
checkHashedInventoryReachability CacheLoc
cache)
    | String -> Bool
isSshUrl String
source = IO () -> IO ()
doUnreachableCheck (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO Bool -> IO ()
checkFileReachability (CacheLoc -> IO Bool
checkHashedInventoryReachability CacheLoc
cache)
    | Bool
otherwise = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"unknown transport protocol for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
source
  where
    source :: String
source = CacheLoc -> String
cacheSource CacheLoc
cache

    doUnreachableCheck :: IO () -> IO ()
doUnreachableCheck IO ()
unreachableAction = do
        String -> Bool
reachable <- IO (String -> Bool)
isReachableSource
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
reachable String
source) IO ()
unreachableAction

    checkFileReachability :: IO Bool -> IO ()
checkFileReachability IO Bool
doCheck = do
        Bool
reachable <- IO Bool
doCheck
        if Bool
reachable
            then String -> IO ()
addReachableSource String
source
            else String -> IO ()
addBadSource String
source

-- | Returns a list of reachables cache entries, removing blacklisted entries.
filterBadSources :: [CacheLoc] -> IO [CacheLoc]
filterBadSources :: [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cache = do
    String -> Bool
badSource <- IO (String -> Bool)
isBadSource
    [CacheLoc] -> IO [CacheLoc]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CacheLoc] -> IO [CacheLoc]) -> [CacheLoc] -> IO [CacheLoc]
forall a b. (a -> b) -> a -> b
$ (CacheLoc -> Bool) -> [CacheLoc] -> [CacheLoc]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CacheLoc -> Bool) -> CacheLoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
badSource (String -> Bool) -> (CacheLoc -> String) -> CacheLoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheLoc -> String
cacheSource) [CacheLoc]
cache

-- | Checks if the _darcs/hashed_inventory exist and is reachable
checkHashedInventoryReachability :: CacheLoc -> IO Bool
checkHashedInventoryReachability :: CacheLoc -> IO Bool
checkHashedInventoryReachability CacheLoc
cache = (String -> IO Bool) -> IO Bool
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO Bool) -> IO Bool) -> (String -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
tempout -> do
    let f :: String
f = CacheLoc -> String
cacheSource CacheLoc
cache String -> ShowS
</> String
darcsdir String -> ShowS
</> String
"hashed_inventory"
    String -> String -> String -> Cachable -> IO ()
copyFileOrUrl String
defaultRemoteDarcsCmd String
f String
tempout Cachable
Cachable
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    IO Bool -> IO Bool -> IO Bool
forall a. IO a -> IO a -> IO a
`catchall` Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Get contents of some hashed file taking advantage of the cache system.
-- We have a list of locations (@cache@) ordered from "closest/fastest"
-- (typically, the destination repo) to "farthest/slowest" (typically,
-- the source repo).
-- First, if possible it copies the file from remote location to local.
-- Then, it reads it contents, and links the file across all writeable
-- locations including the destination repository.
fetchFileUsingCachePrivate :: ValidHash h => FromWhere -> Cache -> h
                           -> IO (FilePath, B.ByteString)
fetchFileUsingCachePrivate :: forall h.
ValidHash h =>
FromWhere -> Cache -> h -> IO (String, ByteString)
fetchFileUsingCachePrivate FromWhere
fromWhere (Ca [CacheLoc]
cache) h
hash = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FromWhere
fromWhere FromWhere -> FromWhere -> Bool
forall a. Eq a => a -> a -> Bool
== FromWhere
Anywhere) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()
copyFileUsingCache OrOnlySpeculate
ActuallyCopy ([CacheLoc] -> Cache
Ca [CacheLoc]
cache) HashedDir
subdir String
filename
    [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cache IO [CacheLoc]
-> ([CacheLoc] -> IO (String, ByteString))
-> IO (String, ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CacheLoc] -> IO (String, ByteString)
ffuc
  where
    filename :: String
filename = h -> String
forall h. ValidHash h => h -> String
encodeValidHash h
hash
    subdir :: HashedDir
subdir = h -> HashedDir
forall h. ValidHash h => h -> HashedDir
dirofValidHash h
hash
    ffuc :: [CacheLoc] -> IO (String, ByteString)
ffuc (CacheLoc
c : [CacheLoc]
cs)
        | Bool -> Bool
not (CacheLoc -> Bool
writable CacheLoc
c) Bool -> Bool -> Bool
&&
            (FromWhere
Anywhere FromWhere -> FromWhere -> Bool
forall a. Eq a => a -> a -> Bool
== FromWhere
fromWhere Bool -> Bool -> Bool
|| String -> Bool
isValidLocalPath String
cacheFile) = do
            -- Looks like `copyFileUsingCache` could not copy the file we
            -- wanted. This can happen if `--no-cache` is NOT passed and the
            -- global cache is not accessible.
            String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              String
"In fetchFileUsingCachePrivate I'm directly grabbing file contents from "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cacheFile
            ByteString
x <- String -> Cachable -> IO ByteString
gzFetchFilePS String
cacheFile Cachable
Cachable
            if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ h -> ByteString -> Bool
forall h. ValidHash h => h -> ByteString -> Bool
checkHash h
hash ByteString
x
                then do
                    ByteString
x' <- String -> Cachable -> IO ByteString
fetchFilePS String
cacheFile Cachable
Cachable
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (h -> ByteString -> Bool
forall h. ValidHash h => h -> ByteString -> Bool
checkHash h
hash ByteString
x') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Hash failure in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cacheFile
                        String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Hash failure in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cacheFile
                    (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x')
                else (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x) -- FIXME: create links in caches
            IO (String, ByteString)
-> IO (String, ByteString) -> IO (String, ByteString)
forall a. IO a -> IO a -> IO a
`catchall` do
                -- something bad happened, check if cache became unaccessible
                -- and try other ones
                CacheLoc -> IO ()
checkCacheReachability CacheLoc
c
                [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cs IO [CacheLoc]
-> ([CacheLoc] -> IO (String, ByteString))
-> IO (String, ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CacheLoc] -> IO (String, ByteString)
ffuc
        | CacheLoc -> Bool
writable CacheLoc
c = do
            String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"About to gzFetchFilePS from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
cacheFile
            ByteString
x1 <- String -> Cachable -> IO ByteString
gzFetchFilePS String
cacheFile Cachable
Cachable
            String -> IO ()
debugMessage String
"gzFetchFilePS done."
            ByteString
x <- if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ h -> ByteString -> Bool
forall h. ValidHash h => h -> ByteString -> Bool
checkHash h
hash ByteString
x1
                     then do
                        ByteString
x2 <- String -> Cachable -> IO ByteString
fetchFilePS String
cacheFile Cachable
Cachable
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (h -> ByteString -> Bool
forall h. ValidHash h => h -> ByteString -> Bool
checkHash h
hash ByteString
x2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Hash failure in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cacheFile
                            String -> IO ()
removeFile String
cacheFile
                            String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Hash failure in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cacheFile
                        ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x2
                     else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x1
            -- Linking is optional here; the catchall prevents darcs from
            -- failing if repo and cache are on different file systems.
            (CacheLoc -> IO ()) -> [CacheLoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> HashedDir -> CacheLoc -> IO ()
tryLinking String
cacheFile String
filename HashedDir
subdir) [CacheLoc]
cs IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x)
            IO (String, ByteString)
-> IO (String, ByteString) -> IO (String, ByteString)
forall a. IO a -> IO a -> IO a
`catchall` do
                String -> IO ()
debugMessage String
"Caught exception, now attempt creating cache."
                CacheLoc -> HashedDir -> String -> IO ()
createCache CacheLoc
c HashedDir
subdir String
filename IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                CacheLoc -> IO ()
checkCacheReachability CacheLoc
c
                -- fetch file from remaining locations
                (String
fname, ByteString
x) <- [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cs IO [CacheLoc]
-> ([CacheLoc] -> IO (String, ByteString))
-> IO (String, ByteString)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CacheLoc] -> IO (String, ByteString)
ffuc
                String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                  String
"Attempt creating link from: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
fname String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
cacheFile
                (String -> String -> IO ()
createLink String
fname String
cacheFile IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
debugMessage String
"successfully created link"
                                            IO () -> IO (String, ByteString) -> IO (String, ByteString)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x))
                  IO (String, ByteString)
-> IO (String, ByteString) -> IO (String, ByteString)
forall a. IO a -> IO a -> IO a
`catchall` do
                    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Attempt writing file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
cacheFile
                    -- the following block is usually when files get actually written
                    -- inside of _darcs or global cache.
                    do Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
dropFileName String
cacheFile)
                       String -> ByteString -> IO ()
gzWriteFilePS String
cacheFile ByteString
x
                       String -> IO ()
debugMessage String
"successfully wrote file"
                       IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    -- above block can fail if cache is not writeable
                    (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
fname, ByteString
x)
        | Bool
otherwise = [CacheLoc] -> IO (String, ByteString)
ffuc [CacheLoc]
cs
        where
          cacheFile :: String
cacheFile = CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
filename

    ffuc [] = String -> IO (String, ByteString)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Couldn't fetch " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filename String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nin subdir "
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ HashedDir -> String
hashedDir HashedDir
subdir String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" from sources:\n"
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Cache -> String
forall a. Show a => a -> String
show ([CacheLoc] -> Cache
Ca [CacheLoc]
cache)
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ if HashedDir
subdir HashedDir -> HashedDir -> Bool
forall a. Eq a => a -> a -> Bool
== HashedDir
HashedPristineDir
                             then String
"\nRun `darcs repair` to fix this problem."
                             else String
"")

tryLinking :: FilePath -> FilePath -> HashedDir -> CacheLoc -> IO ()
tryLinking :: String -> String -> HashedDir -> CacheLoc -> IO ()
tryLinking String
source String
filename HashedDir
subdir CacheLoc
c =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CacheLoc -> Bool
writable CacheLoc
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    CacheLoc -> HashedDir -> String -> IO ()
createCache CacheLoc
c HashedDir
subdir String
filename
    let target :: String
target = CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
filename
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Linking " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
source String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
target
    (IOError -> Bool) -> IO () -> IO () -> IO ()
forall e a. Exception e => (e -> Bool) -> IO a -> IO a -> IO a
handleOnly IOError -> Bool
isAlreadyExistsError (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
createLink String
source String
target

createCache :: CacheLoc -> HashedDir -> FilePath -> IO ()
createCache :: CacheLoc -> HashedDir -> String -> IO ()
createCache (Cache CacheType
Directory WritableOrNot
_ String
d) HashedDir
subdir String
filename =
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
d String -> ShowS
</> HashedDir -> String
hashedDir HashedDir
subdir String -> ShowS
</> ShowS
bucketFolder String
filename)
createCache CacheLoc
_ HashedDir
_ String
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Write file content, except if it is already in the cache, in
-- which case merely create a hard link to that file. The returned value
-- is the size and hash of the content.
writeFileUsingCache
  :: ValidHash h => Cache -> B.ByteString -> IO h
writeFileUsingCache :: forall h. ValidHash h => Cache -> ByteString -> IO h
writeFileUsingCache (Ca [CacheLoc]
cache) ByteString
content = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"writeFileUsingCache "String -> ShowS
forall a. [a] -> [a] -> [a]
++String
filename
    (String
fn, ByteString
_) <- FromWhere -> Cache -> h -> IO (String, ByteString)
forall h.
ValidHash h =>
FromWhere -> Cache -> h -> IO (String, ByteString)
fetchFileUsingCachePrivate FromWhere
LocalOnly ([CacheLoc] -> Cache
Ca [CacheLoc]
cache) h
hash
    (CacheLoc -> IO ()) -> [CacheLoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> HashedDir -> CacheLoc -> IO ()
tryLinking String
fn String
filename HashedDir
subdir) [CacheLoc]
cache
    h -> IO h
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return h
hash
    IO h -> IO h -> IO h
forall a. IO a -> IO a -> IO a
`catchall`
    [CacheLoc] -> IO h
wfuc [CacheLoc]
cache
    IO h -> IO h -> IO h
forall a. IO a -> IO a -> IO a
`catchall`
    String -> IO h
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Couldn't write " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filename String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nin subdir "
               String -> ShowS
forall a. [a] -> [a] -> [a]
++ HashedDir -> String
hashedDir HashedDir
subdir String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to sources:\n\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++ Cache -> String
forall a. Show a => a -> String
show ([CacheLoc] -> Cache
Ca [CacheLoc]
cache))
  where
    subdir :: HashedDir
subdir = h -> HashedDir
forall h. ValidHash h => h -> HashedDir
dirofValidHash h
hash
    hash :: h
hash = ByteString -> h
forall h. ValidHash h => ByteString -> h
calcValidHash ByteString
content
    filename :: String
filename = h -> String
forall h. ValidHash h => h -> String
encodeValidHash h
hash
    wfuc :: [CacheLoc] -> IO h
wfuc (CacheLoc
c : [CacheLoc]
cs)
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CacheLoc -> Bool
writable CacheLoc
c = [CacheLoc] -> IO h
wfuc [CacheLoc]
cs
        | Bool
otherwise = do
            CacheLoc -> HashedDir -> String -> IO ()
createCache CacheLoc
c HashedDir
subdir String
filename
            let cacheFile :: String
cacheFile = CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
filename
            String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS String
cacheFile ByteString
content
            -- create links in all other writable locations
            String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"writeFileUsingCache remaining sources:\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++Cache -> String
forall a. Show a => a -> String
show ([CacheLoc] -> Cache
Ca [CacheLoc]
cs)
            -- Linking is optional here; the catchall prevents darcs from
            -- failing if repo and cache are on different file systems.
            (CacheLoc -> IO ()) -> [CacheLoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> String -> HashedDir -> CacheLoc -> IO ()
tryLinking String
cacheFile String
filename HashedDir
subdir) [CacheLoc]
cs IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            h -> IO h
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return h
hash
    wfuc [] = String -> IO h
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO h) -> String -> IO h
forall a b. (a -> b) -> a -> b
$ String
"No location to write file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (HashedDir -> String
hashedDir HashedDir
subdir String -> ShowS
</> String
filename)

cleanCaches :: Cache -> HashedDir -> IO ()
cleanCaches :: Cache -> HashedDir -> IO ()
cleanCaches Cache
c HashedDir
d = Cache -> HashedDir -> Maybe [String] -> IO ()
cleanCachesWithHint' Cache
c HashedDir
d Maybe [String]
forall a. Maybe a
Nothing

cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()
cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()
cleanCachesWithHint Cache
c HashedDir
d [String]
h = Cache -> HashedDir -> Maybe [String] -> IO ()
cleanCachesWithHint' Cache
c HashedDir
d ([String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
h)

cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()
cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()
cleanCachesWithHint' (Ca [CacheLoc]
cs) HashedDir
subdir Maybe [String]
hint = (CacheLoc -> IO ()) -> [CacheLoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CacheLoc -> IO ()
cleanCache [CacheLoc]
cs
  where
    cleanCache :: CacheLoc -> IO ()
cleanCache (Cache CacheType
Directory WritableOrNot
Writable String
d) =
        String -> IO () -> IO ()
forall a. String -> IO a -> IO a
withCurrentDirectory (String
d String -> ShowS
</> HashedDir -> String
hashedDir HashedDir
subdir) (do
            [String]
fs' <- String -> IO [String]
getDirectoryContents String
"."
            let fs :: [String]
fs = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
okayHash ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [String]
fs' Maybe [String]
hint
                cleanMsg :: String
cleanMsg = String
"Cleaning cache " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d String -> ShowS
</> HashedDir -> String
hashedDir HashedDir
subdir
            (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
clean ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. String -> [a] -> [a]
progressList String
cleanMsg [String]
fs)
        IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall`
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    cleanCache CacheLoc
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    clean :: String -> IO ()
clean String
f = do
        LinkCount
lc <- FileStatus -> LinkCount
linkCount (FileStatus -> LinkCount) -> IO FileStatus -> IO LinkCount
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> IO FileStatus
getSymbolicLinkStatus String
f
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LinkCount
lc LinkCount -> LinkCount -> Bool
forall a. Ord a => a -> a -> Bool
< LinkCount
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
f
        IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall`
        () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Prints an error message with a list of bad caches.
reportBadSources :: IO ()
reportBadSources :: IO ()
reportBadSources = do
    [String]
sources <- IO [String]
getBadSourcesList
    let size :: Int
size = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
sources
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
sources) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"\nBy the way, I could not reach the following "
               , Int -> Noun -> ShowS
forall n. Countable n => Int -> n -> ShowS
englishNum Int
size (String -> Noun
Noun String
"location") String
":"
               , String
"\n"
               , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++) [String]
sources)
               , String
"\nUnless you plan to restore access to "
               , Int -> Pronoun -> ShowS
forall n. Countable n => Int -> n -> ShowS
englishNum Int
size Pronoun
It String
", you should delete "
               , String
"the corresponding "
               , Int -> Noun -> ShowS
forall n. Countable n => Int -> n -> ShowS
englishNum Int
size (String -> Noun
Noun String
"entry") String
" from _darcs/prefs/sources."
               ]

-- * Global Variables

badSourcesList :: MVar [String]
badSourcesList :: MVar [String]
badSourcesList = IO (MVar [String]) -> MVar [String]
forall a. IO a -> a
unsafePerformIO (IO (MVar [String]) -> MVar [String])
-> IO (MVar [String]) -> MVar [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO (MVar [String])
forall a. a -> IO (MVar a)
newMVar []
{-# NOINLINE badSourcesList #-}

addBadSource :: String -> IO ()
addBadSource :: String -> IO ()
addBadSource String
cache = MVar [String] -> ([String] -> [String]) -> IO ()
forall a. MVar a -> (a -> a) -> IO ()
modifyMVarPure MVar [String]
badSourcesList (String
cacheString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)

getBadSourcesList :: IO [String]
getBadSourcesList :: IO [String]
getBadSourcesList = MVar [String] -> IO [String]
forall a. MVar a -> IO a
readMVar MVar [String]
badSourcesList

isBadSource :: IO (String -> Bool)
isBadSource :: IO (String -> Bool)
isBadSource = do
    [String]
badSources <- IO [String]
getBadSourcesList
    (String -> Bool) -> IO (String -> Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
badSources)

reachableSourcesList :: MVar [String]
reachableSourcesList :: MVar [String]
reachableSourcesList = IO (MVar [String]) -> MVar [String]
forall a. IO a -> a
unsafePerformIO (IO (MVar [String]) -> MVar [String])
-> IO (MVar [String]) -> MVar [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO (MVar [String])
forall a. a -> IO (MVar a)
newMVar []
{-# NOINLINE reachableSourcesList #-}

addReachableSource :: String -> IO ()
addReachableSource :: String -> IO ()
addReachableSource String
src = MVar [String] -> ([String] -> [String]) -> IO ()
forall a. MVar a -> (a -> a) -> IO ()
modifyMVarPure MVar [String]
reachableSourcesList (String
srcString -> [String] -> [String]
forall a. a -> [a] -> [a]
:)

getReachableSources :: IO [String]
getReachableSources :: IO [String]
getReachableSources = MVar [String] -> IO [String]
forall a. MVar a -> IO a
readMVar MVar [String]
reachableSourcesList

isReachableSource :: IO (String -> Bool)
isReachableSource :: IO (String -> Bool)
isReachableSource =  do
    [String]
reachableSources <- IO [String]
getReachableSources
    (String -> Bool) -> IO (String -> Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reachableSources)

modifyMVarPure :: MVar a -> (a -> a) -> IO ()
modifyMVarPure :: forall a. MVar a -> (a -> a) -> IO ()
modifyMVarPure MVar a
mvar a -> a
f = MVar a -> (a -> IO a) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar a
mvar (a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> (a -> a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)