1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
{- git-annex numcopies configuration and checking
-
- Copyright 2014-2015 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-}
module Annex.NumCopies (
module Types.NumCopies,
module Logs.NumCopies,
getFileNumCopies,
getGlobalFileNumCopies,
getNumCopies,
deprecatedNumCopies,
defaultNumCopies,
numCopiesCheck,
numCopiesCheck',
verifyEnoughCopiesToDrop,
verifiableCopies,
UnVerifiedCopy(..),
) where
import Annex.Common
import qualified Annex
import Types.NumCopies
import Logs.NumCopies
import Logs.Trust
import Annex.CheckAttr
import qualified Remote
import qualified Types.Remote as Remote
import Annex.Content
import Annex.UUID
import Control.Exception
import qualified Control.Monad.Catch as M
import Data.Typeable
defaultNumCopies :: NumCopies
defaultNumCopies = NumCopies 1
fromSources :: [Annex (Maybe NumCopies)] -> Annex NumCopies
fromSources = fromMaybe defaultNumCopies <$$> getM id
{- The git config annex.numcopies is deprecated. -}
deprecatedNumCopies :: Annex (Maybe NumCopies)
deprecatedNumCopies = annexNumCopies <$> Annex.getGitConfig
{- Value forced on the command line by --numcopies. -}
getForcedNumCopies :: Annex (Maybe NumCopies)
getForcedNumCopies = Annex.getState Annex.forcenumcopies
{- Numcopies value from any of the non-.gitattributes configuration
- sources. -}
getNumCopies :: Annex NumCopies
getNumCopies = fromSources
[ getForcedNumCopies
, getGlobalNumCopies
, deprecatedNumCopies
]
{- Numcopies value for a file, from any configuration source, including the
- deprecated git config. -}
getFileNumCopies :: FilePath -> Annex NumCopies
getFileNumCopies f = fromSources
[ getForcedNumCopies
, getFileNumCopies' f
, deprecatedNumCopies
]
{- This is the globally visible numcopies value for a file. So it does
- not include local configuration in the git config or command line
- options. -}
getGlobalFileNumCopies :: FilePath -> Annex NumCopies
getGlobalFileNumCopies f = fromSources
[ getFileNumCopies' f
]
getFileNumCopies' :: FilePath -> Annex (Maybe NumCopies)
getFileNumCopies' file = maybe getGlobalNumCopies (return . Just) =<< getattr
where
getattr = (NumCopies <$$> readish)
<$> checkAttr "annex.numcopies" file
{- Checks if numcopies are satisfied for a file by running a comparison
- between the number of (not untrusted) copies that are
- belived to exist, and the configured value.
-
- This is good enough for everything except dropping the file, which
- requires active verification of the copies.
-}
numCopiesCheck :: FilePath -> Key -> (Int -> Int -> v) -> Annex v
numCopiesCheck file key vs = do
have <- trustExclude UnTrusted =<< Remote.keyLocations key
numCopiesCheck' file vs have
numCopiesCheck' :: FilePath -> (Int -> Int -> v) -> [UUID] -> Annex v
numCopiesCheck' file vs have = do
NumCopies needed <- getFileNumCopies file
return $ length have `vs` needed
data UnVerifiedCopy = UnVerifiedRemote Remote | UnVerifiedHere
deriving (Ord, Eq)
{- Verifies that enough copies of a key exist amoung the listed remotes,
- to safely drop it, running an action with a proof if so, and
- printing an informative message if not.
-}
verifyEnoughCopiesToDrop
:: String -- message to print when there are no known locations
-> Key
-> Maybe ContentRemovalLock
-> NumCopies
-> [UUID] -- repos to skip considering (generally untrusted remotes)
-> [VerifiedCopy] -- copies already verified to exist
-> [UnVerifiedCopy] -- places to check to see if they have copies
-> (SafeDropProof -> Annex a) -- action to perform the drop
-> Annex a -- action to perform when unable to drop
-> Annex a
verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction =
helper [] [] preverified (nub tocheck)
where
helper bad missing have [] =
liftIO (mkSafeDropProof need have removallock) >>= \case
Right proof -> dropaction proof
Left stillhave -> do
notEnoughCopies key need stillhave (skip++missing) bad nolocmsg
nodropaction
helper bad missing have (c:cs)
| isSafeDrop need have removallock =
liftIO (mkSafeDropProof need have removallock) >>= \case
Right proof -> dropaction proof
Left stillhave -> helper bad missing stillhave (c:cs)
| otherwise = case c of
UnVerifiedHere -> lockContentShared key contverified
UnVerifiedRemote r -> checkremote r contverified $
Remote.hasKey r key >>= \case
Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs
Left _ -> helper (r:bad) missing have cs
Right False -> helper bad (Remote.uuid r:missing) have cs
where
contverified vc = helper bad missing (vc : have) cs
checkremote r cont fallback = case Remote.lockContent r of
Just lockcontent -> do
-- The remote's lockContent will throw an exception
-- when it is unable to lock, in which case the
-- fallback should be run.
--
-- On the other hand, the continuation could itself
-- throw an exception (ie, the eventual drop action
-- fails), and in this case we don't want to run the
-- fallback since part of the drop action may have
-- already been performed.
--
-- Differentiate between these two sorts
-- of exceptions by using DropException.
let a = lockcontent key $ \v ->
cont v `catchNonAsync` (throw . DropException)
a `M.catches`
[ M.Handler (\ (e :: AsyncException) -> throwM e)
#if MIN_VERSION_base(4,7,0)
, M.Handler (\ (e :: SomeAsyncException) -> throwM e)
#endif
, M.Handler (\ (DropException e') -> throwM e')
, M.Handler (\ (_e :: SomeException) -> fallback)
]
Nothing -> fallback
data DropException = DropException SomeException
deriving (Typeable, Show)
instance Exception DropException
notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex ()
notEnoughCopies key need have skip bad nolocmsg = do
showNote "unsafe"
if length have < fromNumCopies need
then showLongNote $
"Could only verify the existence of " ++
show (length have) ++ " out of " ++ show (fromNumCopies need) ++
" necessary copies"
else do
showLongNote "Unable to lock down 1 copy of file that is required to safely drop it."
showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)"
Remote.showTriedRemotes bad
Remote.showLocations True key (map toUUID have++skip) nolocmsg
{- Finds locations of a key that can be used to get VerifiedCopies,
- in order to allow dropping the key.
-
- Provide a list of UUIDs that the key is being dropped from.
- The returned lists will exclude any of those UUIDs.
-
- The return lists also exclude any repositories that are untrusted,
- since those should not be used for verification.
-
- The UnVerifiedCopy list is cost ordered.
- The VerifiedCopy list contains repositories that are trusted to
- contain the key.
-}
verifiableCopies :: Key -> [UUID] -> Annex ([UnVerifiedCopy], [VerifiedCopy])
verifiableCopies key exclude = do
locs <- Remote.keyLocations key
(remotes, trusteduuids) <- Remote.remoteLocations locs
=<< trustGet Trusted
untrusteduuids <- trustGet UnTrusted
let exclude' = exclude ++ untrusteduuids
let remotes' = Remote.remotesWithoutUUID remotes (exclude' ++ trusteduuids)
let verified = map (mkVerifiedCopy TrustedCopy) $
filter (`notElem` exclude') trusteduuids
u <- getUUID
let herec = if u `elem` locs && u `notElem` exclude'
then [UnVerifiedHere]
else []
return (herec ++ map UnVerifiedRemote remotes', verified)
|
