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
)
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
}
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]
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
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
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
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 :: 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
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
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
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]
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
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
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 )
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
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
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)
| 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 )
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
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
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
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
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)
IO (String, ByteString)
-> IO (String, ByteString) -> IO (String, ByteString)
forall a. IO a -> IO a -> IO a
`catchall` do
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
(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
(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
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 ()
(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 ()
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
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)
(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 ()
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."
]
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)