module Darcs.Repository.Cache
    ( cacheHash
    , okayHash
    , Cache
    , mkCache
    , cacheEntries
    , CacheType(..)
    , CacheLoc(..)
    , WritableOrNot(..)
    , HashedDir(..)
    , hashedDir
    , bucketFolder
    , unionCaches
    , unionRemoteCaches
    , cleanCaches
    , cleanCachesWithHint
    , fetchFileUsingCache
    , speculateFileUsingCache
    , speculateFilesUsingCache
    , writeFileUsingCache
    , peekInCache
    , repo2cache
    , writable
    , isThisRepo
    , hashedFilePath
    , allHashedDirs
    , reportBadSources
    , closestWritableDirectory
    , dropNonRepos
    ) where

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

import Darcs.Prelude

import Darcs.Util.ByteString ( gzWriteFilePS )
import Darcs.Util.Global ( darcsdir, defaultRemoteDarcsCmd )
import Darcs.Util.External ( gzFetchFilePS, fetchFilePS
                           , speculateFileOrUrl, copyFileOrUrl
                           , Cachable( Cachable ) )
import Darcs.Repository.Flags ( Compression(..) )
import Darcs.Util.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS,
                         withTemp )
import Darcs.Util.SignalHandler ( catchNonSignal )
import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Hash ( sha256sum )
import Darcs.Util.English ( englishNum, Noun(..), Pronoun(..) )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Progress ( progressList, debugMessage )
import qualified Darcs.Util.Download as Download ( ConnectionError )

data HashedDir = HashedPristineDir
               | HashedPatchesDir
               | HashedInventoriesDir

hashedDir :: HashedDir -> String
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
/= :: WritableOrNot -> WritableOrNot -> Bool
$c/= :: WritableOrNot -> WritableOrNot -> Bool
== :: WritableOrNot -> WritableOrNot -> Bool
$c== :: 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
showList :: [WritableOrNot] -> ShowS
$cshowList :: [WritableOrNot] -> ShowS
show :: WritableOrNot -> String
$cshow :: WritableOrNot -> String
showsPrec :: Int -> WritableOrNot -> ShowS
$cshowsPrec :: Int -> 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
/= :: CacheType -> CacheType -> Bool
$c/= :: CacheType -> CacheType -> Bool
== :: CacheType -> CacheType -> Bool
$c== :: 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
showList :: [CacheType] -> ShowS
$cshowList :: [CacheType] -> ShowS
show :: CacheType -> String
$cshow :: CacheType -> String
showsPrec :: Int -> CacheType -> ShowS
$cshowsPrec :: Int -> 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]

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 -> Ordering) -> [CacheLoc] -> [CacheLoc]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy CacheLoc -> CacheLoc -> Ordering
compareByLocality ([CacheLoc] -> [CacheLoc])
-> ([CacheLoc] -> [CacheLoc]) -> [CacheLoc] -> [CacheLoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CacheLoc] -> [CacheLoc]
forall a. Eq a => [a] -> [a]
nub

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

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

instance Show CacheLoc where
    show :: CacheLoc -> String
show (Cache CacheType
Repo WritableOrNot
Writable String
a) = String
"thisrepo:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a
    show (Cache CacheType
Repo WritableOrNot
NotWritable String
a) = String
"repo:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a
    show (Cache CacheType
Directory WritableOrNot
Writable String
a) = String
"cache:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a
    show (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
unlines ([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
forall a. Show a => a -> String
show [CacheLoc]
cs

unionCaches :: Cache -> Cache -> Cache
unionCaches :: Cache -> Cache -> Cache
unionCaches (Ca [CacheLoc]
a) (Ca [CacheLoc]
b) = [CacheLoc] -> Cache
Ca ([CacheLoc] -> [CacheLoc]
forall a. Eq a => [a] -> [a]
nub ([CacheLoc]
a [CacheLoc] -> [CacheLoc] -> [CacheLoc]
forall a. [a] -> [a] -> [a]
++ [CacheLoc]
b))

-- | unionRemoteCaches merges caches. It tries to do better than just blindly
--   copying remote cache entries:
--
--   * If remote repository is accessed through network, do not copy any cache
--     entries from it. Taking local entries does not make sense and using
--     network entries can lead to darcs hang when it tries to get to
--     unaccessible host.
--
--   * If remote repository is local, copy all network cache entries. For local
--     cache entries if the cache directory exists and is writable it is added
--     as writable cache, if it exists but is not writable it is added as
--     read-only cache.
--
--   This approach should save us from bogus cache entries. One case it does
--   not work very well is when you fetch from partial repository over network.
--   Hopefully this is not a common case.
unionRemoteCaches :: Cache -> Cache -> String -> IO Cache
unionRemoteCaches :: Cache -> Cache -> String -> IO Cache
unionRemoteCaches Cache
local (Ca [CacheLoc]
remote) String
repourl
    | String -> Bool
isValidLocalPath String
repourl =  do
        [CacheLoc]
f <- IO [CacheLoc]
filtered
        Cache -> IO Cache
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache -> IO Cache) -> Cache -> IO Cache
forall a b. (a -> b) -> a -> b
$ Cache
local Cache -> Cache -> Cache
`unionCaches` [CacheLoc] -> Cache
Ca [CacheLoc]
f
    | Bool
otherwise = Cache -> IO Cache
forall (m :: * -> *) a. Monad m => a -> m a
return Cache
local
  where
    filtered :: IO [CacheLoc]
filtered = [Maybe CacheLoc] -> [CacheLoc]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CacheLoc] -> [CacheLoc])
-> IO [Maybe CacheLoc] -> IO [CacheLoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap`
        (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)
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 (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 (Cache CacheType
Repo WritableOrNot
Writable String
_) = Maybe CacheLoc -> IO (Maybe CacheLoc)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CacheLoc
forall a. Maybe a
Nothing
    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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe CacheLoc
forall a. Maybe a
Nothing
        | Bool
otherwise = Maybe CacheLoc -> IO (Maybe CacheLoc)
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

repo2cache :: String -> Cache
repo2cache :: String -> Cache
repo2cache String
r = [CacheLoc] -> Cache
Ca [CacheType -> WritableOrNot -> String -> CacheLoc
Cache CacheType
Repo WritableOrNot
NotWritable String
r]

-- | 'cacheHash' computes the cache hash (i.e. filename) of a packed string.
cacheHash :: B.ByteString -> String
cacheHash :: ByteString -> String
cacheHash ByteString
ps = if Int
sizeStrLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10
                   then String
shaOfPs
                   else Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sizeStrLen) Char
'0' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sizeStr
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'-' Char -> ShowS
forall a. a -> [a] -> [a]
: String
shaOfPs
  where
    sizeStr :: String
sizeStr = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
ps
    sizeStrLen :: Int
sizeStrLen = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sizeStr
    shaOfPs :: String
shaOfPs = ByteString -> String
sha256sum ByteString
ps

okayHash :: String -> Bool
okayHash :: String -> Bool
okayHash String
s = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
64, Int
75]

checkHash :: String -> B.ByteString -> Bool
checkHash :: String -> ByteString -> Bool
checkHash String
h ByteString
s
    | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64 = ByteString -> String
sha256sum ByteString
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
h
    | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
75 =
        ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Int
forall a. Read a => String -> a
read (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
10 String
h) Bool -> Bool -> Bool
&& ByteString -> String
sha256sum ByteString
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
11 String
h
    | Bool
otherwise = Bool
False

-- |@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.
fetchFileUsingCache :: Cache -> HashedDir -> String
                    -> IO (String, B.ByteString)
fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, ByteString)
fetchFileUsingCache = FromWhere
-> Cache -> HashedDir -> String -> 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 :: String -> String
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

-- | @hashedFilePath cachelocation subdir hash@ returns the physical filename
-- of hash @hash@ in the @subdir@ section of @cachelocation@.
hashedFilePath :: CacheLoc -> HashedDir -> String -> String
hashedFilePath :: CacheLoc -> HashedDir -> ShowS
hashedFilePath (Cache CacheType
Directory WritableOrNot
_ 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
Repo WritableOrNot
_ String
r) HashedDir
s String
f =
    [String] -> String
joinPath [String
r, String
darcsdir, HashedDir -> String
hashedDir HashedDir
s, String
f]

-- | @hashedFilePathReadOnly cachelocation subdir hash@ returns the physical filename
-- of hash @hash@ in the @subdir@ section of @cachelocation@.
-- If directory, assume it is non-bucketed cache (old cache location).
hashedFilePathReadOnly :: CacheLoc -> HashedDir -> String -> String
hashedFilePathReadOnly :: CacheLoc -> HashedDir -> ShowS
hashedFilePathReadOnly (Cache CacheType
Directory WritableOrNot
_ String
d) HashedDir
s String
f =
    String
d String -> ShowS
</> HashedDir -> String
hashedDir HashedDir
s String -> ShowS
</> String
f
hashedFilePathReadOnly (Cache CacheType
Repo WritableOrNot
_ String
r) HashedDir
s String
f =
    String
r String -> ShowS
</> String
darcsdir String -> ShowS
</> HashedDir -> String
hashedDir HashedDir
s String -> ShowS
</> String
f

-- | @peekInCache cache subdir hash@ tells whether @cache@ and contains an
-- object with hash @hash@ in a writable position.  Florent: why do we want it
-- to be in a writable position?
peekInCache :: Cache -> HashedDir -> String -> IO Bool
peekInCache :: Cache -> HashedDir -> String -> IO Bool
peekInCache (Ca [CacheLoc]
cache) HashedDir
subdir String
f = [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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where
    cacheHasIt :: [CacheLoc] -> IO Bool
cacheHasIt [] = Bool -> IO Bool
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 String
f
            if Bool
ex then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else [CacheLoc] -> IO Bool
cacheHasIt [CacheLoc]
cs

-- | @speculateFileUsingCache cache subdirectory name@ takes note that the file
-- @name@ is likely to be useful soon: pipelined downloads will add it to the
-- (low-priority) queue, for the rest it is a noop.
speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()
speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()
speculateFileUsingCache Cache
c HashedDir
sd String
h = do
    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
h
    OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()
copyFileUsingCache OrOnlySpeculate
OnlySpeculate Cache
c HashedDir
sd String
h

-- | Note that the files are likely to be useful soon: pipelined downloads will
-- add them to the (low-priority) queue, for the rest it is a noop.
speculateFilesUsingCache :: Cache -> HashedDir -> [String] -> IO ()
speculateFilesUsingCache :: Cache -> HashedDir -> [String] -> IO ()
speculateFilesUsingCache Cache
_ HashedDir
_ [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
speculateFilesUsingCache Cache
cache HashedDir
sd [String]
hs = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Thinking about speculating on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
hs
    [String]
hs' <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool) -> (String -> IO Bool) -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache -> HashedDir -> String -> IO Bool
peekInCache Cache
cache HashedDir
sd) [String]
hs
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
hs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        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] -> String
unwords [String]
hs'
        OrOnlySpeculate -> Cache -> HashedDir -> [String] -> IO ()
copyFilesUsingCache OrOnlySpeculate
OnlySpeculate Cache
cache HashedDir
sd [String]
hs'

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
/= :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
$c/= :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
== :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
$c== :: OrOnlySpeculate -> OrOnlySpeculate -> Bool
Eq )

-- | We hace a list of locations (@cache@) ordered from "closest/fastest"
-- (typically, the destination repo) to "farthest/slowest" (typically,
-- the source repo).
-- @copyFileUsingCache@ first checks whether given file @f@ is present
-- in some writeable location, if yes, do nothing. If no, it copies it
-- to the last writeable location, which would be the global cache
-- by default, or the destination repo if `--no-cache` is passed.
-- Function does nothing if there is no writeable location at all.
-- If the copy should occur between two locations of the same filesystem,
-- a hard link is actually made.
-- TODO document @oos@: what happens when we only speculate?
copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> 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
"I'm doing copyFileUsingCache on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HashedDir -> String
hashedDir HashedDir
subdir String -> ShowS
</> String
f
    Just String
stickItHere <- [CacheLoc] -> IO (Maybe String)
cacheLoc [CacheLoc]
cache
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True
        (ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
reverse String
stickItHere)
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Will effectively do copyFileUsingCache to: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
stickItHere
    [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cache IO [CacheLoc] -> ([CacheLoc] -> IO ()) -> IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- return last writeable cache/repo location for file.
    -- usually returns the global cache unless `--no-cache` is passed.
    cacheLoc :: [CacheLoc] -> IO (Maybe String)
cacheLoc [] = Maybe String -> IO (Maybe String)
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 (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ 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 (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 (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
    sfuc :: String -> [CacheLoc] -> IO ()
sfuc String
_ [] = () -> IO ()
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
hashedFilePathReadOnly CacheLoc
c HashedDir
subdir String
f in
            if OrOnlySpeculate
oos OrOnlySpeculate -> OrOnlySpeculate -> Bool
forall a. Eq a => a -> a -> Bool
== OrOnlySpeculate
OnlySpeculate
                then String -> String -> IO ()
speculateFileOrUrl String
cacheFile String
out
                     IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal`
                     \SomeException
e -> String -> CacheLoc -> IO ()
checkCacheReachability (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) CacheLoc
c
                else 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 () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal`
                     (\SomeException
e -> do String -> CacheLoc -> IO ()
checkCacheReachability (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) 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

copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String]
                    -> IO ()
copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String] -> IO ()
copyFilesUsingCache OrOnlySpeculate
oos Cache
cache HashedDir
subdir [String]
hs =
    [String] -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
hs ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()
copyFileUsingCache OrOnlySpeculate
oos Cache
cache HashedDir
subdir

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
/= :: FromWhere -> FromWhere -> Bool
$c/= :: FromWhere -> FromWhere -> Bool
== :: FromWhere -> FromWhere -> Bool
$c== :: 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 :: String -> CacheLoc -> IO ()
checkCacheReachability :: String -> CacheLoc -> IO ()
checkCacheReachability String
e 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
$ do
            let err :: String
err = case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'(') String
e of
                          (Char
_ : String
xs) -> (String, String) -> String
forall a b. (a, b) -> a
fst ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
')') String
xs)
                          String
_ -> String
e
            case ReadS ConnectionError
forall a. Read a => ReadS a
reads String
err :: [(Download.ConnectionError, String)] of
                [(ConnectionError
_, String
_)] -> String -> IO ()
addBadSource String
source
                [(ConnectionError, String)]
_ -> 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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal` IO Bool -> SomeException -> IO Bool
forall a b. a -> b -> a
const (Bool -> IO Bool
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 :: FromWhere -> Cache -> HashedDir -> String
                           -> IO (String, B.ByteString)
fetchFileUsingCachePrivate :: FromWhere
-> Cache -> HashedDir -> String -> IO (String, ByteString)
fetchFileUsingCachePrivate FromWhere
fromWhere (Ca [CacheLoc]
cache) HashedDir
subdir String
f = 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
f
    [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cache IO [CacheLoc]
-> ([CacheLoc] -> IO (String, ByteString))
-> IO (String, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CacheLoc] -> IO (String, ByteString)
ffuc
    IO (String, ByteString)
-> IO (String, ByteString) -> IO (String, ByteString)
forall a. IO a -> IO a -> IO a
`catchall` String -> IO (String, ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Couldn't fetch " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f 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\n"
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ Cache -> String
forall a. Show a => a -> String
show ([CacheLoc] -> Cache
Ca [CacheLoc]
cache))
  where
    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 (CacheLoc -> HashedDir -> ShowS
hashedFilePathReadOnly CacheLoc
c HashedDir
subdir String
f)) = do
            let cacheFile :: String
cacheFile = CacheLoc -> HashedDir -> ShowS
hashedFilePathReadOnly CacheLoc
c HashedDir
subdir String
f
            -- 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
$ String -> ByteString -> Bool
checkHash String
f 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 (String -> ByteString -> Bool
checkHash String
f 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x')
                else (String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x) -- FIXME: create links in caches
            IO (String, ByteString)
-> (SomeException -> IO (String, ByteString))
-> IO (String, ByteString)
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal` \SomeException
e -> do
                -- something bad happened, check if cache became unaccessible and try other ones
                String -> CacheLoc -> IO ()
checkCacheReachability (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) CacheLoc
c
                [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cs IO [CacheLoc]
-> ([CacheLoc] -> IO (String, ByteString))
-> IO (String, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CacheLoc] -> IO (String, ByteString)
ffuc
        | CacheLoc -> Bool
writable CacheLoc
c = let cacheFile :: String
cacheFile = CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
f in 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 -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"gzFetchFilePS done."
            ByteString
x <- if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Bool
checkHash String
f 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 (String -> ByteString -> Bool
checkHash String
f 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ByteString
x2
                     else ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x1
            (CacheLoc -> IO ()) -> [CacheLoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> CacheLoc -> IO ()
tryLinking String
cacheFile) [CacheLoc]
cs
            (String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheFile, ByteString
x)
            IO (String, ByteString)
-> (SomeException -> IO (String, ByteString))
-> IO (String, ByteString)
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchNonSignal` \SomeException
e -> do
                String -> IO ()
debugMessage String
"Caught exception, now attempt creating cache."
                CacheLoc -> HashedDir -> IO ()
createCache CacheLoc
c HashedDir
subdir IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                String -> CacheLoc -> IO ()
checkCacheReachability (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) CacheLoc
c
                (String
fname, ByteString
x) <- [CacheLoc] -> IO [CacheLoc]
filterBadSources [CacheLoc]
cs IO [CacheLoc]
-> ([CacheLoc] -> IO (String, ByteString))
-> IO (String, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [CacheLoc] -> IO (String, ByteString)
ffuc  -- fetch file from remaining locations
                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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String, ByteString) -> IO (String, ByteString)
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 -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"successfully wrote file"
                       IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    -- above block can fail if cache is not writeable
                    (String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
fname, ByteString
x)
        | Bool
otherwise = [CacheLoc] -> IO (String, ByteString)
ffuc [CacheLoc]
cs

    ffuc [] = String -> IO (String, ByteString)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (String, ByteString))
-> String -> IO (String, ByteString)
forall a b. (a -> b) -> a -> b
$ String
"No sources from which to fetch file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f
                          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++ Cache -> String
forall a. Show a => a -> String
show ([CacheLoc] -> Cache
Ca [CacheLoc]
cache)

    tryLinking :: String -> CacheLoc -> IO ()
tryLinking String
ff c :: CacheLoc
c@(Cache CacheType
Directory WritableOrNot
Writable String
d) = do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
False (String
d String -> ShowS
</> HashedDir -> String
hashedDir HashedDir
subdir)
        String -> String -> IO ()
createLink String
ff (CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
f)
        IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall`
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    tryLinking String
_ CacheLoc
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

-- | @write compression filename content@ writes @content@ to the file
-- @filename@ according to the policy given by @compression@.
write :: Compression -> String -> B.ByteString -> IO ()
write :: Compression -> String -> ByteString -> IO ()
write Compression
NoCompression = String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
writeAtomicFilePS
write Compression
GzipCompression = String -> ByteString -> IO ()
forall p. FilePathLike p => p -> ByteString -> IO ()
gzWriteAtomicFilePS

-- | @writeFileUsingCache cache compression subdir contents@ write the string
-- @contents@ to the directory subdir, except if it is already in the cache, in
-- which case it is a noop.  Warning (?) this means that in case of a hash
-- collision, writing using writeFileUsingCache is a noop. The returned value
-- is the filename that was given to the string.
writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString
                    -> IO String
writeFileUsingCache :: Cache -> Compression -> HashedDir -> ByteString -> IO String
writeFileUsingCache (Ca [CacheLoc]
cache) Compression
compr HashedDir
subdir ByteString
ps = do
    (String, ByteString)
_ <- FromWhere
-> Cache -> HashedDir -> String -> IO (String, ByteString)
fetchFileUsingCachePrivate FromWhere
LocalOnly ([CacheLoc] -> Cache
Ca [CacheLoc]
cache) HashedDir
subdir String
hash
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
hash
    IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall`
    [CacheLoc] -> IO String
wfuc [CacheLoc]
cache
    IO String -> IO String -> IO String
forall a. IO a -> IO a -> IO a
`catchall`
    String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Couldn't write " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hash 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
    hash :: String
hash = ByteString -> String
cacheHash ByteString
ps
    wfuc :: [CacheLoc] -> IO String
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 String
wfuc [CacheLoc]
cs
        | Bool
otherwise = do
            CacheLoc -> HashedDir -> IO ()
createCache CacheLoc
c HashedDir
subdir
            -- FIXME: create links in caches
            Compression -> String -> ByteString -> IO ()
write Compression
compr (CacheLoc -> HashedDir -> ShowS
hashedFilePath CacheLoc
c HashedDir
subdir String
hash) ByteString
ps
            String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
hash
    wfuc [] = String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String) -> String -> IO String
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
hash)

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 p a. FilePathLike p => p -> 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 (m :: * -> *) a. Monad m => a -> m a
return ()
    cleanCache CacheLoc
_ = () -> IO ()
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 (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 (t :: * -> *) a. Foldable t => t a -> Int
length [String]
sources
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> 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 (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> 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 (m :: * -> *) a. Monad m => a -> m a
return (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reachableSources)

modifyMVarPure :: MVar a -> (a -> a) -> IO ()
modifyMVarPure :: 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 (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)