mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

AssociatedFile newtype

Browse source 
To prevent any further mistakes like 301aff34c4

This commit was sponsored by Francois Marier on Patreon.
This commit is contained in:
Joey Hess 2017-03-10 13:12:24 -04:00
parent 2cd7496210
commit c8e1e3dada
No known key found for this signature in database
GPG key ID: C910D9222512E3C7
43 changed files with 179 additions and 138 deletions
Download patch file Download diff file Expand all files Collapse all files

15
Command/AddUrl.hs
View file

@ -171,7 +171,9 @@ downloadRemoteFile r relaxed uri file sz = checkCanAdd file $ do
-- so that the remote knows what url it
-- should use to download it.
setTempUrl urlkey loguri
let downloader = \dest p -> fst <$> Remote.retrieveKeyFile r urlkey (Just file) dest p
let downloader = \dest p -> fst
<$> Remote.retrieveKeyFile r urlkey
(AssociatedFile (Just file)) dest p
ret <- downloadWith downloader urlkey (Remote.uuid r) loguri file
removeTempUrl urlkey
return ret
@ -255,8 +257,8 @@ addUrlFileQuvi relaxed quviurl videourl file = checkCanAdd file $ do
checkDiskSpaceToGet sizedkey Nothing $ do
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
showOutput
ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download webUUID key (Just file) Transfer.forwardRetry $ \p -> do
ok <- Transfer.notifyTransfer Transfer.Download afile $
Transfer.download webUUID key afile Transfer.forwardRetry $ \p -> do
liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloadUrl key p [videourl] tmp
if ok
@ -265,6 +267,8 @@ addUrlFileQuvi relaxed quviurl videourl file = checkCanAdd file $ do
return (Just key)
else return Nothing
)
where
afile = AssociatedFile (Just file)
addUrlChecked :: Bool -> URLString -> UUID -> (Key -> Annex (Bool, Bool)) -> Key -> CommandPerform
addUrlChecked relaxed url u checkexistssize key
@ -328,10 +332,11 @@ downloadWith downloader dummykey u url file =
, return Nothing
)
where
runtransfer tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do
runtransfer tmp = Transfer.notifyTransfer Transfer.Download afile $
Transfer.download u dummykey afile Transfer.forwardRetry $ \p -> do
liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloader tmp p
afile = AssociatedFile (Just file)
{- Adds the url size to the Key. -}
addSizeUrlKey :: Url.UrlInfo -> Key -> Key

4
Command/Copy.hs
View file

@ -53,6 +53,6 @@ start o file key = stopUnless shouldCopy $
| otherwise = return True
want = case Command.Move.fromToOptions (moveOptions o) of
ToRemote dest -> (Remote.uuid <$> getParsed dest) >>=
wantSend False (Just key) (Just file)
wantSend False (Just key) (AssociatedFile (Just file))
FromRemote _ ->
wantGet False (Just key) (Just file)
wantGet False (Just key) (AssociatedFile (Just file))

7
Command/Drop.hs
View file

@ -65,7 +65,7 @@ seek o = allowConcurrentOutput $
start :: DropOptions -> FilePath -> Key -> CommandStart
start o file key = start' o key afile (mkActionItem afile)
where
afile = Just file
afile = AssociatedFile (Just file)
start' :: DropOptions -> Key -> AssociatedFile -> ActionItem -> CommandStart
start' o key afile ai = do
@ -85,7 +85,7 @@ start' o key afile ai = do
| otherwise = return True
startKeys :: DropOptions -> Key -> ActionItem -> CommandStart
startKeys o key = start' o key Nothing
startKeys o key = start' o key (AssociatedFile Nothing)
startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart
startLocal afile ai numcopies key preverified = stopUnless (inAnnex key) $ do
@ -202,7 +202,8 @@ requiredContent = do
{- In auto mode, only runs the action if there are enough
- copies on other semitrusted repositories. -}
checkDropAuto :: Bool -> Maybe Remote -> AssociatedFile -> Key -> (NumCopies -> CommandStart) -> CommandStart
checkDropAuto automode mremote afile key a = go =<< maybe getNumCopies getFileNumCopies afile
checkDropAuto automode mremote (AssociatedFile afile) key a =
go =<< maybe getNumCopies getFileNumCopies afile
where
go numcopies
| automode = do

4
Command/DropUnused.hs
View file

@ -46,9 +46,9 @@ perform :: Maybe Remote -> NumCopies -> Key -> CommandPerform
perform from numcopies key = case from of
Just r -> do
showAction $ "from " ++ Remote.name r
Command.Drop.performRemote key Nothing numcopies r
Command.Drop.performRemote key (AssociatedFile Nothing) numcopies r
Nothing -> ifM (inAnnex key)
( Command.Drop.performLocal key Nothing numcopies []
( Command.Drop.performLocal key (AssociatedFile Nothing) numcopies []
, next (return True)
)

49
Command/Fsck.hs
View file

@ -110,9 +110,10 @@ start from inc file key = do
numcopies <- getFileNumCopies file
case from of
Nothing -> go $ perform key file backend numcopies
Just r -> go $ performRemote key (Just file) backend numcopies r
Just r -> go $ performRemote key afile backend numcopies r
where
go = runFsck inc (mkActionItem (Just file)) key
go = runFsck inc (mkActionItem afile) key
afile = AssociatedFile (Just file)
perform :: Key -> FilePath -> Backend -> NumCopies -> Annex Bool
perform key file backend numcopies = do
@ -123,10 +124,12 @@ perform key file backend numcopies = do
, verifyLocationLog key keystatus file
, verifyAssociatedFiles key keystatus file
, verifyWorkTree key file
, checkKeySize key keystatus (Just file)
, checkBackend backend key keystatus (Just file)
, checkKeyNumCopies key (Just file) numcopies
, checkKeySize key keystatus afile
, checkBackend backend key keystatus afile
, checkKeyNumCopies key afile numcopies
]
where
afile = AssociatedFile (Just file)
{- To fsck a remote, the content is retrieved to a tmp file,
- and checked locally. -}
@ -148,7 +151,7 @@ performRemote key afile backend numcopies remote =
return False
dispatch (Right False) = go False Nothing
go present localcopy = check
[ verifyLocationLogRemote key (maybe (key2file key) id afile) remote present
[ verifyLocationLogRemote key afile remote present
, withLocalCopy localcopy $ checkKeySizeRemote key remote afile
, withLocalCopy localcopy $ checkBackendRemote backend key remote afile
, checkKeyNumCopies key afile numcopies
@ -167,7 +170,7 @@ performRemote key afile backend numcopies remote =
, ifM (Annex.getState Annex.fast)
( return Nothing
, Just . fst <$>
Remote.retrieveKeyFile remote key Nothing tmp dummymeter
Remote.retrieveKeyFile remote key (AssociatedFile Nothing) tmp dummymeter
)
)
, return (Just False)
@ -181,16 +184,16 @@ startKey from inc key ai numcopies =
Just backend -> runFsck inc ai key $
case from of
Nothing -> performKey key backend numcopies
Just r -> performRemote key Nothing backend numcopies r
Just r -> performRemote key (AssociatedFile Nothing) backend numcopies r
performKey :: Key -> Backend -> NumCopies -> Annex Bool
performKey key backend numcopies = do
keystatus <- getKeyStatus key
check
[ verifyLocationLog key keystatus (key2file key)
, checkKeySize key keystatus Nothing
, checkBackend backend key keystatus Nothing
, checkKeyNumCopies key Nothing numcopies
, checkKeySize key keystatus (AssociatedFile Nothing)
, checkBackend backend key keystatus (AssociatedFile Nothing)
, checkKeyNumCopies key (AssociatedFile Nothing) numcopies
]
check :: [Annex Bool] -> Annex Bool
@ -249,10 +252,12 @@ verifyLocationLog key keystatus desc = do
then return True
else verifyLocationLog' key desc present u (logChange key u)
verifyLocationLogRemote :: Key -> String -> Remote -> Bool -> Annex Bool
verifyLocationLogRemote key desc remote present =
verifyLocationLogRemote :: Key -> AssociatedFile -> Remote -> Bool -> Annex Bool
verifyLocationLogRemote key (AssociatedFile afile) remote present =
verifyLocationLog' key desc present (Remote.uuid remote)
(Remote.logStatus remote key)
where
desc = fromMaybe (key2file key) afile
verifyLocationLog' :: Key -> String -> Bool -> UUID -> (LogStatus -> Annex ()) -> Annex Bool
verifyLocationLog' key desc present u updatestatus = do
@ -356,7 +361,7 @@ checkKeySizeRemote key remote afile localcopy =
checkKeySizeOr (badContentRemote remote localcopy) key localcopy afile
checkKeySizeOr :: (Key -> Annex String) -> Key -> FilePath -> AssociatedFile -> Annex Bool
checkKeySizeOr bad key file afile = case keySize key of
checkKeySizeOr bad key file (AssociatedFile afile) = case keySize key of
Nothing -> return True
Just size -> do
size' <- liftIO $ getFileSize file
@ -396,7 +401,9 @@ checkBackend backend key keystatus afile = go =<< isDirect
( nocheck
, checkBackendOr badContent backend key content afile
)
go True = maybe nocheck checkdirect afile
go True = case afile of
AssociatedFile Nothing -> nocheck
AssociatedFile (Just f) -> checkdirect f
checkdirect file = ifM (Direct.goodContent key file)
( checkBackendOr' (badContentDirect file) backend key file afile
(Direct.goodContent key file)
@ -416,7 +423,7 @@ checkBackendOr bad backend key file afile =
-- in order to detect situations where the file is changed while being
-- verified (particularly in direct mode).
checkBackendOr' :: (Key -> Annex String) -> Backend -> Key -> FilePath -> AssociatedFile -> Annex Bool -> Annex Bool
checkBackendOr' bad backend key file afile postcheck =
checkBackendOr' bad backend key file (AssociatedFile afile) postcheck =
case Types.Backend.verifyKeyContent backend of
Nothing -> return True
Just verifier -> do
@ -436,21 +443,23 @@ checkBackendOr' bad backend key file afile postcheck =
checkKeyNumCopies :: Key -> AssociatedFile -> NumCopies -> Annex Bool
checkKeyNumCopies key afile numcopies = do
let file = fromMaybe (key2file key) afile
let (desc, hasafile) = case afile of
AssociatedFile Nothing -> (key2file key, False)
AssociatedFile (Just af) -> (af, True)
locs <- loggedLocations key
(untrustedlocations, otherlocations) <- trustPartition UnTrusted locs
(deadlocations, safelocations) <- trustPartition DeadTrusted otherlocations
let present = NumCopies (length safelocations)
if present < numcopies
then ifM (pure (isNothing afile) <&&> checkDead key)
then ifM (pure (not hasafile) <&&> checkDead key)
( do
showLongNote $ "This key is dead, skipping."
return True
, do
untrusted <- Remote.prettyPrintUUIDs "untrusted" untrustedlocations
dead <- Remote.prettyPrintUUIDs "dead" deadlocations
warning $ missingNote file present numcopies untrusted dead
when (fromNumCopies present == 0 && isNothing afile) $
warning $ missingNote desc present numcopies untrusted dead
when (fromNumCopies present == 0 && not hasafile) $
showLongNote "(Avoid this check by running: git annex dead --key )"
return False
)

7
Command/Get.hs
View file

@ -51,14 +51,15 @@ seek o = allowConcurrentOutput $ do
start :: GetOptions -> Maybe Remote -> FilePath -> Key -> CommandStart
start o from file key = start' expensivecheck from key afile (mkActionItem afile)
where
afile = Just file
afile = AssociatedFile (Just file)
expensivecheck
| autoMode o = numCopiesCheck file key (<) <||> wantGet False (Just key) (Just file)
| autoMode o = numCopiesCheck file key (<)
<||> wantGet False (Just key) afile
| otherwise = return True
startKeys :: Maybe Remote -> Key -> ActionItem -> CommandStart
startKeys from key ai = checkFailedTransferDirection ai Download $
start' (return True) from key Nothing ai
start' (return True) from key (AssociatedFile Nothing) ai
start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart
start' expensivecheck from key afile ai = stopUnless (not <$> inAnnex key) $

9
Command/Info.hs
View file

@ -39,6 +39,7 @@ import Logs.Transfer
import Types.Key
import Types.TrustLevel
import Types.FileMatcher
import Types.ActionItem
import qualified Limit
import Messages.JSON (DualDisp(..), ObjectMap(..))
import Annex.BloomFilter
@ -420,7 +421,9 @@ transfer_list = stat desc $ nojson $ lift $ do
desc = "transfers in progress"
line uuidmap t i = unwords
[ formatDirection (transferDirection t) ++ "ing"
, fromMaybe (key2file $ transferKey t) (associatedFile i)
, actionItemDesc
(ActionItemAssociatedFile (associatedFile i))
(transferKey t)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap
@ -428,9 +431,11 @@ transfer_list = stat desc $ nojson $ lift $ do
jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $
[ ("transfer", toJSON (formatDirection (transferDirection t)))
, ("key", toJSON (key2file (transferKey t)))
, ("file", toJSON (associatedFile i))
, ("file", toJSON afile)
, ("remote", toJSON (fromUUID (transferUUID t)))
]
where
AssociatedFile afile = associatedFile i
disk_size :: Stat
disk_size = simpleStat "available local disk space" $

4
Command/MetaData.hs
View file

@ -86,7 +86,7 @@ seek o = case batchOption o of
start :: POSIXTime -> MetaDataOptions -> FilePath -> Key -> CommandStart
start now o file k = startKeys now o k (mkActionItem afile)
where
afile = Just file
afile = AssociatedFile (Just file)
startKeys :: POSIXTime -> MetaDataOptions -> Key -> ActionItem -> CommandStart
startKeys now o k ai = case getSet o of
@ -155,7 +155,7 @@ startBatch (i, (MetaData m)) = case i of
Left f -> do
mk <- lookupFile f
case mk of
Just k -> go k (mkActionItem (Just f))
Just k -> go k (mkActionItem (AssociatedFile (Just f)))
Nothing -> giveup $ "not an annexed file: " ++ f
Right k -> go k (mkActionItem k)
where

5
Command/Migrate.hs
View file

@ -73,7 +73,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey
go (Just (newkey, knowngoodcontent))
| knowngoodcontent = finish newkey
| otherwise = stopUnless checkcontent $ finish newkey
checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked $ Just file
checkcontent = Command.Fsck.checkBackend oldbackend oldkey Command.Fsck.KeyLocked afile
finish newkey = ifM (Command.ReKey.linkKey file oldkey newkey)
( do
copyMetaData oldkey newkey
@ -86,7 +86,7 @@ perform file oldkey oldbackend newbackend = go =<< genkey
next $ Command.ReKey.cleanup file oldkey newkey
, error "failed"
)
genkey = case maybe Nothing (\fm -> fm oldkey newbackend (Just file)) (fastMigrate oldbackend) of
genkey = case maybe Nothing (\fm -> fm oldkey newbackend afile) (fastMigrate oldbackend) of
Just newkey -> return $ Just (newkey, True)
Nothing -> do
content <- calcRepo $ gitAnnexLocation oldkey
@ -99,3 +99,4 @@ perform file oldkey oldbackend newbackend = go =<< genkey
return $ case v of
Just (newkey, _) -> Just (newkey, False)
_ -> Nothing
afile = AssociatedFile (Just file)

10
Command/Mirror.hs
View file

@ -43,16 +43,16 @@ instance DeferredParseClass MirrorOptions where
seek :: MirrorOptions -> CommandSeek
seek o = allowConcurrentOutput $
withKeyOptions (keyOptions o) False
(startKey o Nothing)
(startKey o (AssociatedFile Nothing))
(withFilesInGit $ whenAnnexed $ start o)
(mirrorFiles o)
start :: MirrorOptions -> FilePath -> Key -> CommandStart
start o file k = startKey o afile k (mkActionItem afile)
where
afile = Just file
afile = AssociatedFile (Just file)
startKey :: MirrorOptions -> Maybe FilePath -> Key -> ActionItem -> CommandStart
startKey :: MirrorOptions -> AssociatedFile -> Key -> ActionItem -> CommandStart
startKey o afile key ai = case fromToOptions o of
ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key)
( Command.Move.toStart False afile key ai =<< getParsed r
@ -72,4 +72,6 @@ startKey o afile key ai = case fromToOptions o of
, stop
)
where
getnumcopies = maybe getNumCopies getFileNumCopies afile
getnumcopies = case afile of
AssociatedFile Nothing -> getNumCopies
AssociatedFile (Just af) -> getFileNumCopies af

4
Command/Move.hs
View file

@ -53,10 +53,10 @@ seek o = allowConcurrentOutput $
start :: MoveOptions -> Bool -> FilePath -> Key -> CommandStart
start o move f k = start' o move afile k (mkActionItem afile)
where
afile = Just f
afile = AssociatedFile (Just f)
startKey :: MoveOptions -> Bool -> Key -> ActionItem -> CommandStart
startKey o move = start' o move Nothing
startKey o move = start' o move (AssociatedFile Nothing)
start' :: MoveOptions -> Bool -> AssociatedFile -> Key -> ActionItem -> CommandStart
start' o move afile key ai =

2
Command/SendKey.hs
View file

@ -46,7 +46,7 @@ start key = do
fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
fieldTransfer direction key a = do
liftIO $ debugM "fieldTransfer" "transfer start"
afile <- Fields.getField Fields.associatedFile
afile <- AssociatedFile <$> Fields.getField Fields.associatedFile
ok <- maybe (a $ const noop)
-- Using noRetry here because we're the sender.
(\u -> runner (Transfer direction (toUUID u) key) afile noRetry a)

4
Command/Sync.hs
View file

@ -519,8 +519,8 @@ seekSyncContent o rs = do
liftIO $ not <$> isEmptyMVar mvar
where
seekworktree mvar l bloomfeeder = seekHelper LsFiles.inRepo l >>=
mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (Just f)) noop)
seekkeys mvar bloom k _ = go (Left bloom) mvar Nothing k
mapM_ (\f -> ifAnnexed f (go (Right bloomfeeder) mvar (AssociatedFile (Just f))) noop)
seekkeys mvar bloom k _ = go (Left bloom) mvar (AssociatedFile Nothing) k
go ebloom mvar af k = commandAction $ do
whenM (syncFile ebloom rs af k) $
void $ liftIO $ tryPutMVar mvar ()

11
Command/TestRemote.hs
View file

@ -155,8 +155,9 @@ test st r k =
Nothing -> return True
Just verifier -> verifier k (key2file k)
get = getViaTmp (RemoteVerify r) k $ \dest ->
Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
store = Remote.storeKey r k Nothing nullMeterUpdate
Remote.retrieveKeyFile r k (AssociatedFile Nothing)
dest nullMeterUpdate
store = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
remove = Remote.removeKey r k
testUnavailable :: Annex.AnnexState -> Remote -> Key -> [TestTree]
@ -164,15 +165,15 @@ testUnavailable st r k =
[ check (== Right False) "removeKey" $
Remote.removeKey r k
, check (== Right False) "storeKey" $
Remote.storeKey r k Nothing nullMeterUpdate
Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate
, check (`notElem` [Right True, Right False]) "checkPresent" $
Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $
getViaTmp (RemoteVerify r) k $ \dest ->
Remote.retrieveKeyFile r k Nothing dest nullMeterUpdate
Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate
, check (== Right False) "retrieveKeyFileCheap" $
getViaTmp (RemoteVerify r) k $ \dest -> unVerified $
Remote.retrieveKeyFileCheap r k Nothing dest
Remote.retrieveKeyFileCheap r k (AssociatedFile Nothing) dest
]
where
check checkval desc a = testCase desc $ do

4
Command/TransferInfo.hs
View file

@ -41,7 +41,7 @@ start (k:[]) = do
case file2key k of
Nothing -> error "bad key"
(Just key) -> whenM (inAnnex key) $ do
file <- Fields.getField Fields.associatedFile
afile <- AssociatedFile <$> Fields.getField Fields.associatedFile
u <- maybe (error "missing remoteuuid") toUUID
<$> Fields.getField Fields.remoteUUID
let t = Transfer
@ -49,7 +49,7 @@ start (k:[]) = do
, transferUUID = u
, transferKey = key
}
tinfo <- liftIO $ startTransferInfo file
tinfo <- liftIO $ startTransferInfo afile
(update, tfile, _) <- mkProgressUpdater t tinfo
liftIO $ mapM_ void
[ tryIO $ forever $ do

4
Command/TransferKey.hs
View file

@ -30,10 +30,10 @@ optParser :: CmdParamsDesc -> Parser TransferKeyOptions
optParser desc = TransferKeyOptions
<$> cmdParams desc
<*> parseFromToOptions
<*> optional (strOption
<*> (AssociatedFile <$> optional (strOption
( long "file" <> metavar paramFile
<> help "the associated file"
))
)))
instance DeferredParseClass TransferKeyOptions where
finishParse v = TransferKeyOptions

8
Command/TransferKeys.hs
View file

@ -116,10 +116,10 @@ instance TCSerialized Direction where
deserialize _ = Nothing
instance TCSerialized AssociatedFile where
serialize (Just f) = f
serialize Nothing = ""
deserialize "" = Just Nothing
deserialize f = Just $ Just f
serialize (AssociatedFile (Just f)) = f
serialize (AssociatedFile Nothing) = ""
deserialize "" = Just (AssociatedFile Nothing)
deserialize f = Just (AssociatedFile (Just f))
instance TCSerialized RemoteName where
serialize n = n

2
Command/Whereis.hs
View file

@ -49,7 +49,7 @@ seek o = do
start :: M.Map UUID Remote -> FilePath -> Key -> CommandStart
start remotemap file key = startKeys remotemap key (mkActionItem afile)
where
afile = Just file
afile = AssociatedFile (Just file)
startKeys :: M.Map UUID Remote -> Key -> ActionItem -> CommandStart
startKeys remotemap key ai = do