aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2017-03-10 13:12:24 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2017-03-10 13:35:31 -0400
commit8cb9381befed4174624edfc80e09185c9340b4f6 (patch)
treee5d2041ff38502b1f8a5ef9caa6515cccfcea555
parente230fd58b5f5d5d16f87e1bd5c0f2e553f2ae5a2 (diff)
AssociatedFile newtype
To prevent any further mistakes like 1a497cefb47557f0b4788c606f9071be422b2511 This commit was sponsored by Francois Marier on Patreon.
-rw-r--r--Annex/Drop.hs12
-rw-r--r--Annex/FileMatcher.hs4
-rw-r--r--Annex/Notification.hs16
-rw-r--r--Annex/Transfer.hs10
-rw-r--r--Assistant/DeleteRemote.hs2
-rw-r--r--Assistant/Threads/Committer.hs7
-rw-r--r--Assistant/Threads/Cronner.hs2
-rw-r--r--Assistant/Threads/SanityChecker.hs4
-rw-r--r--Assistant/Threads/TransferScanner.hs9
-rw-r--r--Assistant/TransferSlots.hs9
-rw-r--r--Assistant/Upgrade.hs2
-rw-r--r--Backend/Hash.hs4
-rw-r--r--Command/AddUrl.hs15
-rw-r--r--Command/Copy.hs4
-rw-r--r--Command/Drop.hs7
-rw-r--r--Command/DropUnused.hs4
-rw-r--r--Command/Fsck.hs49
-rw-r--r--Command/Get.hs7
-rw-r--r--Command/Info.hs9
-rw-r--r--Command/MetaData.hs4
-rw-r--r--Command/Migrate.hs5
-rw-r--r--Command/Mirror.hs10
-rw-r--r--Command/Move.hs4
-rw-r--r--Command/SendKey.hs2
-rw-r--r--Command/Sync.hs4
-rw-r--r--Command/TestRemote.hs11
-rw-r--r--Command/TransferInfo.hs4
-rw-r--r--Command/TransferKey.hs4
-rw-r--r--Command/TransferKeys.hs8
-rw-r--r--Command/Whereis.hs2
-rw-r--r--Key.hs2
-rw-r--r--Limit/Wanted.hs10
-rw-r--r--Logs/Transfer.hs17
-rw-r--r--P2P/Protocol.hs9
-rw-r--r--Remote/GCrypt.hs9
-rw-r--r--Remote/Git.hs3
-rw-r--r--Remote/Helper/Ssh.hs2
-rw-r--r--Types.hs2
-rw-r--r--Types/ActionItem.hs12
-rw-r--r--Types/Key.hs3
-rw-r--r--Types/Transfer.hs6
41 files changed, 175 insertions, 134 deletions
diff --git a/Annex/Drop.hs b/Annex/Drop.hs
index cd0168a9f..1723bce0d 100644
--- a/Annex/Drop.hs
+++ b/Annex/Drop.hs
@@ -55,8 +55,8 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key
)
let fs = case afile of
- Just f -> nub (f : l)
- Nothing -> l
+ AssociatedFile (Just f) -> nub (f : l)
+ AssociatedFile Nothing -> l
n <- getcopies fs
void $ if fromhere && checkcopies n Nothing
then go fs rs n >>= dropl fs
@@ -93,9 +93,9 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
checkdrop fs n u a
| null fs = check $ -- no associated files; unused content
- wantDrop True u (Just key) Nothing
+ wantDrop True u (Just key) (AssociatedFile Nothing)
| otherwise = check $
- allM (wantDrop True u (Just key) . Just) fs
+ allM (wantDrop True u (Just key) . AssociatedFile . Just) fs
where
check c = ifM c
( dodrop n u a
@@ -107,7 +107,9 @@ handleDropsFrom locs rs reason fromhere key afile preverified runner = do
( do
liftIO $ debugM "drop" $ unwords
[ "dropped"
- , fromMaybe (key2file key) afile
+ , case afile of
+ AssociatedFile Nothing -> key2file key
+ AssociatedFile (Just af) -> af
, "(from " ++ maybe "here" show u ++ ")"
, "(copies now " ++ show (fromNumCopies have - 1) ++ ")"
, ": " ++ reason
diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs
index 7a418cc48..1e07a9da2 100644
--- a/Annex/FileMatcher.hs
+++ b/Annex/FileMatcher.hs
@@ -44,13 +44,13 @@ type GetFileMatcher = FilePath -> Annex (FileMatcher Annex)
checkFileMatcher :: GetFileMatcher -> FilePath -> Annex Bool
checkFileMatcher getmatcher file = do
matcher <- getmatcher file
- checkMatcher matcher Nothing (Just file) S.empty True
+ checkMatcher matcher Nothing (AssociatedFile (Just file)) S.empty True
checkMatcher :: FileMatcher Annex -> Maybe Key -> AssociatedFile -> AssumeNotPresent -> Bool -> Annex Bool
checkMatcher matcher mkey afile notpresent d
| isEmpty matcher = return d
| otherwise = case (mkey, afile) of
- (_, Just file) -> go =<< fileMatchInfo file
+ (_, AssociatedFile (Just file)) -> go =<< fileMatchInfo file
(Just key, _) -> go (MatchingKey key)
_ -> return d
where
diff --git a/Annex/Notification.hs b/Annex/Notification.hs
index e61b362ad..0501c0db7 100644
--- a/Annex/Notification.hs
+++ b/Annex/Notification.hs
@@ -28,10 +28,10 @@ noNotification = NotifyWitness
{- Wrap around an action that performs a transfer, which may run multiple
- attempts. Displays notification when supported and when the user asked
- for it. -}
-notifyTransfer :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool
-notifyTransfer _ Nothing a = a NotifyWitness
+notifyTransfer :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> Annex Bool
+notifyTransfer _ (AssociatedFile Nothing) a = a NotifyWitness
#ifdef WITH_DBUS_NOTIFICATIONS
-notifyTransfer direction (Just f) a = do
+notifyTransfer direction (AssociatedFile (Just f)) a = do
wanted <- Annex.getState Annex.desktopnotify
if (notifyStart wanted || notifyFinish wanted)
then do
@@ -47,19 +47,19 @@ notifyTransfer direction (Just f) a = do
return ok
else a NotifyWitness
#else
-notifyTransfer _ (Just _) a = a NotifyWitness
+notifyTransfer _ (AssociatedFile (Just _)) a = a NotifyWitness
#endif
-notifyDrop :: Maybe FilePath -> Bool -> Annex ()
-notifyDrop Nothing _ = noop
+notifyDrop :: AssociatedFile -> Bool -> Annex ()
+notifyDrop (AssociatedFile Nothing) _ = noop
#ifdef WITH_DBUS_NOTIFICATIONS
-notifyDrop (Just f) ok = do
+notifyDrop (AssociatedFile (Just f)) ok = do
wanted <- Annex.getState Annex.desktopnotify
when (notifyFinish wanted) $ liftIO $ do
client <- DBus.Client.connectSession
void $ Notify.notify client (droppedNote ok f)
#else
-notifyDrop (Just _) _ = noop
+notifyDrop (AssociatedFile (Just _)) _ = noop
#endif
#ifdef WITH_DBUS_NOTIFICATIONS
diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 0b794b379..87480b2f1 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -77,7 +77,7 @@ guardHaveUUID u a
- An upload can be run from a read-only filesystem, and in this case
- no transfer information or lock file is used.
-}
-runTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
runTransfer = runTransfer' False
{- Like runTransfer, but ignores any existing transfer lock file for the
@@ -85,12 +85,12 @@ runTransfer = runTransfer' False
-
- Note that this may result in confusing progress meter display in the
- webapp, if multiple processes are writing to the transfer info file. -}
-alwaysRunTransfer :: Observable v => Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
alwaysRunTransfer = runTransfer' True
-runTransfer' :: Observable v => Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t file shouldretry transferaction = checkSecureHashes t $ do
- info <- liftIO $ startTransferInfo file
+runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
+runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t $ do
+ info <- liftIO $ startTransferInfo afile
(meter, tfile, metervar) <- mkProgressUpdater t info
mode <- annexFileMode
(lck, inprogress) <- prep tfile mode info
diff --git a/Assistant/DeleteRemote.hs b/Assistant/DeleteRemote.hs
index c69011e79..6c88c61f5 100644
--- a/Assistant/DeleteRemote.hs
+++ b/Assistant/DeleteRemote.hs
@@ -64,7 +64,7 @@ removableRemote urlrenderer uuid = do
where
queueremaining r k =
queueTransferWhenSmall "remaining object in unwanted remote"
- Nothing (Transfer Download uuid k) r
+ (AssociatedFile Nothing) (Transfer Download uuid k) r
{- Scanning for keys can take a long time; do not tie up
- the Annex monad while doing it, so other threads continue to
- run. -}
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index dbd030b33..d0acb8c60 100644
--- a/Assistant/Threads/Committer.hs
+++ b/Assistant/Threads/Committer.hs
@@ -503,9 +503,10 @@ checkChangeContent change@(Change { changeInfo = i }) =
Just k -> whenM (scanComplete <$> getDaemonStatus) $ do
present <- liftAnnex $ inAnnex k
void $ if present
- then queueTransfers "new file created" Next k (Just f) Upload
- else queueTransfers "new or renamed file wanted" Next k (Just f) Download
- handleDrops "file renamed" present k (Just f) []
+ then queueTransfers "new file created" Next k af Upload
+ else queueTransfers "new or renamed file wanted" Next k af Download
+ handleDrops "file renamed" present k af []
where
f = changeFile change
+ af = AssociatedFile (Just f)
checkChangeContent _ = noop
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index 0b505b8f2..145a76e7b 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/Assistant/Threads/Cronner.hs
@@ -190,7 +190,7 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
void $ repairWhenNecessary urlrenderer u Nothing fsckresults
mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
where
- reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
+ reget k = queueTransfers "fsck found bad file; redownloading" Next k (AssociatedFile Nothing) Download
runActivity' urlrenderer (ScheduledRemoteFsck u s d) = dispatch =<< liftAnnex (remoteFromUUID u)
where
dispatch Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 0c79ef605..816969511 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/Assistant/Threads/SanityChecker.hs
@@ -190,8 +190,8 @@ dailyCheck urlrenderer = do
unused <- liftAnnex unusedKeys'
void $ liftAnnex $ setUnusedKeys unused
forM_ unused $ \k -> do
- unlessM (queueTransfers "unused" Later k Nothing Upload) $
- handleDrops "unused" True k Nothing []
+ unlessM (queueTransfers "unused" Later k (AssociatedFile Nothing) Upload) $
+ handleDrops "unused" True k (AssociatedFile Nothing) []
return True
where
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 5436c2ca1..4b6a90cd9 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/Assistant/Threads/TransferScanner.hs
@@ -154,8 +154,9 @@ expensiveScan urlrenderer rs = batch <~> do
enqueue f (r, t) =
queueTransferWhenSmall "expensive scan found missing object"
- (Just f) t r
+ (AssociatedFile (Just f)) t r
findtransfers f unwanted key = do
+ let af = AssociatedFile (Just f)
{- The syncable remotes may have changed since this
- scan began. -}
syncrs <- syncDataRemotes <$> getDaemonStatus
@@ -163,14 +164,14 @@ expensiveScan urlrenderer rs = batch <~> do
present <- liftAnnex $ inAnnex key
liftAnnex $ handleDropsFrom locs syncrs
"expensive scan found too many copies of object"
- present key (Just f) [] callCommandAction
+ present key af [] callCommandAction
liftAnnex $ do
let slocs = S.fromList locs
let use a = return $ mapMaybe (a key slocs) syncrs
ts <- if present
- then filterM (wantSend True (Just key) (Just f) . Remote.uuid . fst)
+ then filterM (wantSend True (Just key) af . Remote.uuid . fst)
=<< use (genTransfer Upload False)
- else ifM (wantGet True (Just key) (Just f))
+ else ifM (wantGet True (Just key) af)
( use (genTransfer Download True) , return [] )
let unwanted' = S.difference unwanted slocs
return (unwanted', ts)
diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs
index 25342f2b3..c80cf880a 100644
--- a/Assistant/TransferSlots.hs
+++ b/Assistant/TransferSlots.hs
@@ -153,10 +153,11 @@ genTransfer t info = case transferRemote info of
-}
go remote transferrer = ifM (liftIO $ performTransfer transferrer t info)
( do
- maybe noop
- (void . addAlert . makeAlertFiller True
- . transferFileAlert direction True)
- (associatedFile info)
+ case associatedFile info of
+ AssociatedFile Nothing -> noop
+ AssociatedFile (Just af) -> void $
+ addAlert $ makeAlertFiller True $
+ transferFileAlert direction True af
unless isdownload $
handleDrops
("object uploaded to " ++ show remote)
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs
index a2f6f9e0a..67a4d9fc2 100644
--- a/Assistant/Upgrade.hs
+++ b/Assistant/Upgrade.hs
@@ -85,7 +85,7 @@ startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO ol
hook <- asIO1 $ distributionDownloadComplete d dest cleanup
modifyDaemonStatus_ $ \s -> s
{ transferHook = M.insert k hook (transferHook s) }
- maybe noop (queueTransfer "upgrade" Next (Just f) t)
+ maybe noop (queueTransfer "upgrade" Next (AssociatedFile (Just f)) t)
=<< liftAnnex (remoteFromUUID webUUID)
startTransfer t
k = distributionKey d
diff --git a/Backend/Hash.hs b/Backend/Hash.hs
index 9b0e9190a..a5abc8447 100644
--- a/Backend/Hash.hs
+++ b/Backend/Hash.hs
@@ -148,8 +148,8 @@ trivialMigrate oldkey newbackend afile
}
{- Fast migration from hash to hashE backend. -}
| migratable && hasExt oldvariety = case afile of
- Nothing -> Nothing
- Just file -> Just $ oldkey
+ AssociatedFile Nothing -> Nothing
+ AssociatedFile (Just file) -> Just $ oldkey
{ keyName = keyHash oldkey ++ selectExtension file
, keyVariety = newvariety
}
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index a89a25e83..866bfc463 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -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
diff --git a/Command/Copy.hs b/Command/Copy.hs
index 56278bde2..9b41b17d7 100644
--- a/Command/Copy.hs
+++ b/Command/Copy.hs
@@ -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))
diff --git a/Command/Drop.hs b/Command/Drop.hs
index 129dce035..52b89b82c 100644
--- a/Command/Drop.hs
+++ b/Command/Drop.hs
@@ -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
diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs
index edc11ea45..840a8a472 100644
--- a/Command/DropUnused.hs
+++ b/Command/DropUnused.hs
@@ -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)
)
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 231f93ce7..c291493b1 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -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
)
diff --git a/Command/Get.hs b/Command/Get.hs
index abf95e48a..fc6ff7374 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -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) $
diff --git a/Command/Info.hs b/Command/Info.hs
index aaee08fe1..0867bf8ea 100644
--- a/Command/Info.hs
+++ b/Command/Info.hs
@@ -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" $
diff --git a/Command/MetaData.hs b/Command/MetaData.hs
index ebb9d0f17..617b291a1 100644
--- a/Command/MetaData.hs
+++ b/Command/MetaData.hs
@@ -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
diff --git a/Command/Migrate.hs b/Command/Migrate.hs
index 0ae6f7d80..8dfee9814 100644
--- a/Command/Migrate.hs
+++ b/Command/Migrate.hs
@@ -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)
diff --git a/Command/Mirror.hs b/Command/Mirror.hs
index d08555e79..7d33d80e9 100644
--- a/Command/Mirror.hs
+++ b/Command/Mirror.hs
@@ -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
diff --git a/Command/Move.hs b/Command/Move.hs
index d74eea900..ca4febe76 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -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 =
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index 302810374..670f0e437 100644
--- a/Command/SendKey.hs
+++ b/Command/SendKey.hs
@@ -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)
diff --git a/Command/Sync.hs b/Command/Sync.hs
index 0d5d46b2f..d4d45e2e4 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -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 ()
diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs
index c8a993666..8a21fdf35 100644
--- a/Command/TestRemote.hs
+++ b/Command/TestRemote.hs
@@ -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
diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs
index 1db633484..3f352a82e 100644
--- a/Command/TransferInfo.hs
+++ b/Command/TransferInfo.hs
@@ -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
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index 42a6a9e0d..aa6acbd55 100644
--- a/Command/TransferKey.hs
+++ b/Command/TransferKey.hs
@@ -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
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index d875f496d..855ca4670 100644
--- a/Command/TransferKeys.hs
+++ b/Command/TransferKeys.hs
@@ -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
diff --git a/Command/Whereis.hs b/Command/Whereis.hs
index bcc11aaf7..a08b94422 100644
--- a/Command/Whereis.hs
+++ b/Command/Whereis.hs
@@ -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
diff --git a/Key.hs b/Key.hs
index d1669bf05..8672c827c 100644
--- a/Key.hs
+++ b/Key.hs
@@ -9,7 +9,7 @@
module Key (
Key(..),
- AssociatedFile,
+ AssociatedFile(..),
stubKey,
key2file,
file2key,
diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs
index c11e24b7d..a41398c10 100644
--- a/Limit/Wanted.hs
+++ b/Limit/Wanted.hs
@@ -13,12 +13,14 @@ import Limit
import Types.FileMatcher
addWantGet :: Annex ()
-addWantGet = addLimit $ Right $ const $ checkWant $ wantGet False Nothing
+addWantGet = addLimit $ Right $ const $ checkWant $
+ wantGet False Nothing
addWantDrop :: Annex ()
-addWantDrop = addLimit $ Right $ const $ checkWant $ wantDrop False Nothing Nothing
+addWantDrop = addLimit $ Right $ const $ checkWant $
+ wantDrop False Nothing Nothing
-checkWant :: (Maybe FilePath -> Annex Bool) -> MatchInfo -> Annex Bool
-checkWant a (MatchingFile fi) = a (Just $ matchFile fi)
+checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool
+checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi))
checkWant _ (MatchingKey _) = return False
checkWant _ (MatchingInfo {}) = return False
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index ce2a7d299..aef233b77 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -10,6 +10,7 @@
module Logs.Transfer where
import Types.Transfer
+import Types.ActionItem
import Annex.Common
import Annex.Perms
import qualified Git
@@ -27,7 +28,9 @@ describeTransfer :: Transfer -> TransferInfo -> String
describeTransfer t info = unwords
[ show $ transferDirection t
, show $ transferUUID t
- , fromMaybe (key2file $ transferKey t) (associatedFile info)
+ , actionItemDesc
+ (ActionItemAssociatedFile (associatedFile info))
+ (transferKey t)
, show $ bytesComplete info
]
@@ -67,8 +70,8 @@ mkProgressUpdater t info = do
Just sz -> sz `div` 100
Nothing -> 100 * 1024 -- arbitrarily, 100 kb
-startTransferInfo :: Maybe FilePath -> IO TransferInfo
-startTransferInfo file = TransferInfo
+startTransferInfo :: AssociatedFile -> IO TransferInfo
+startTransferInfo afile = TransferInfo
<$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
#ifndef mingw32_HOST_OS
<*> pure Nothing -- pid not stored in file, so omitted for speed
@@ -78,7 +81,7 @@ startTransferInfo file = TransferInfo
<*> pure Nothing -- tid ditto
<*> pure Nothing -- not 0; transfer may be resuming
<*> pure Nothing
- <*> pure file
+ <*> pure afile
<*> pure False
{- If a transfer is still running, returns its TransferInfo.
@@ -228,7 +231,9 @@ writeTransferInfo info = unlines
#ifdef mingw32_HOST_OS
, maybe "" show (transferPid info)
#endif
- , fromMaybe "" $ associatedFile info -- comes last; arbitrary content
+ -- comes last; arbitrary content
+ , let AssociatedFile afile = associatedFile info
+ in fromMaybe "" afile
]
readTransferInfoFile :: Maybe PID -> FilePath -> IO (Maybe TransferInfo)
@@ -246,7 +251,7 @@ readTransferInfo mpid s = TransferInfo
<*> pure Nothing
<*> pure Nothing
<*> bytes
- <*> pure (if null filename then Nothing else Just filename)
+ <*> pure (AssociatedFile (if null filename then Nothing else Just filename))
<*> pure False
where
#ifdef mingw32_HOST_OS
diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs
index 135409e26..e74979170 100644
--- a/P2P/Protocol.hs
+++ b/P2P/Protocol.hs
@@ -136,8 +136,9 @@ instance Proto.Serializable Service where
-- These mungings are ok, because an AssociatedFile is only ever displayed
-- to the user and does not need to match a file on disk.
instance Proto.Serializable AssociatedFile where
- serialize Nothing = ""
- serialize (Just af) = toInternalGitPath $ concatMap esc af
+ serialize (AssociatedFile Nothing) = ""
+ serialize (AssociatedFile (Just af)) =
+ toInternalGitPath $ concatMap esc af
where
esc '%' = "%%"
esc c
@@ -145,9 +146,9 @@ instance Proto.Serializable AssociatedFile where
| otherwise = [c]
deserialize s = case fromInternalGitPath $ deesc [] s of
- [] -> Just Nothing
+ [] -> Just (AssociatedFile Nothing)
f
- | isRelative f -> Just (Just f)
+ | isRelative f -> Just (AssociatedFile (Just f))
| otherwise -> Nothing
where
deesc b [] = reverse b
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 79020f40c..ea101a770 100644
--- a/Remote/GCrypt.hs
+++ b/Remote/GCrypt.hs
@@ -326,7 +326,8 @@ store r rsyncopts
return True
| Git.repoIsSsh (repo r) = if accessShell r
then fileStorer $ \k f p -> Ssh.rsyncHelper (Just p)
- =<< Ssh.rsyncParamsRemote False r Upload k f Nothing
+ =<< Ssh.rsyncParamsRemote False r Upload k f
+ (AssociatedFile Nothing)
else fileStorer $ Remote.Rsync.store rsyncopts
| otherwise = unsupportedUrl
@@ -336,8 +337,10 @@ retrieve r rsyncopts
guardUsable (repo r) (return False) $
sink =<< liftIO (L.readFile $ gCryptLocation r k)
| Git.repoIsSsh (repo r) = if accessShell r
- then fileRetriever $ \f k p ->
- unlessM (Ssh.rsyncHelper (Just p) =<< Ssh.rsyncParamsRemote False r Download k f Nothing) $
+ then fileRetriever $ \f k p -> do
+ ps <- Ssh.rsyncParamsRemote False r Download k f
+ (AssociatedFile Nothing)
+ unlessM (Ssh.rsyncHelper (Just p) ps) $
giveup "rsync failed"
else fileRetriever $ Remote.Rsync.retrieve rsyncopts
| otherwise = unsupportedUrl
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 9cb369e4d..e5d85d2c2 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -479,8 +479,9 @@ copyFromRemote' r key file dest meterupdate
)
feedprogressback' a = do
u <- getUUID
+ let AssociatedFile afile = file
let fields = (Fields.remoteUUID, fromUUID u)
- : maybe [] (\f -> [(Fields.associatedFile, f)]) file
+ : maybe [] (\f -> [(Fields.associatedFile, f)]) afile
Just (cmd, params) <- Ssh.git_annex_shell ConsumeStdin
(repo r) "transferinfo"
[Param $ key2file key] fields
diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs
index 7f64b4645..0bdc3535a 100644
--- a/Remote/Helper/Ssh.hs
+++ b/Remote/Helper/Ssh.hs
@@ -126,7 +126,7 @@ rsyncHelper m params = do
{- Generates rsync parameters that ssh to the remote and asks it
- to either receive or send the key's content. -}
rsyncParamsRemote :: Bool -> Remote -> Direction -> Key -> FilePath -> AssociatedFile -> Annex [CommandParam]
-rsyncParamsRemote unlocked r direction key file afile = do
+rsyncParamsRemote unlocked r direction key file (AssociatedFile afile) = do
u <- getUUID
let fields = (Fields.remoteUUID, fromUUID u)
: (Fields.unlocked, if unlocked then "1" else "")
diff --git a/Types.hs b/Types.hs
index 09c8adefd..884c91a6b 100644
--- a/Types.hs
+++ b/Types.hs
@@ -9,7 +9,7 @@ module Types (
Annex,
Backend,
Key,
- AssociatedFile,
+ AssociatedFile(..),
UUID(..),
GitConfig(..),
RemoteGitConfig(..),
diff --git a/Types/ActionItem.hs b/Types/ActionItem.hs
index d9beb049d..73d845101 100644
--- a/Types/ActionItem.hs
+++ b/Types/ActionItem.hs
@@ -13,8 +13,6 @@ import Key
import Types.Transfer
import Git.FilePath
-import Data.Maybe
-
data ActionItem
= ActionItemAssociatedFile AssociatedFile
| ActionItemKey
@@ -37,15 +35,15 @@ instance MkActionItem (Transfer, TransferInfo) where
mkActionItem = uncurry ActionItemFailedTransfer
actionItemDesc :: ActionItem -> Key -> String
-actionItemDesc (ActionItemAssociatedFile (Just f)) _ = f
-actionItemDesc (ActionItemAssociatedFile Nothing) k = key2file k
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile (Just f))) _ = f
+actionItemDesc (ActionItemAssociatedFile (AssociatedFile Nothing)) k = key2file k
actionItemDesc ActionItemKey k = key2file k
actionItemDesc (ActionItemBranchFilePath bfp) _ = descBranchFilePath bfp
-actionItemDesc (ActionItemFailedTransfer _ i) k =
- fromMaybe (key2file k) (associatedFile i)
+actionItemDesc (ActionItemFailedTransfer _ i) k =
+ actionItemDesc (ActionItemAssociatedFile (associatedFile i)) k
actionItemWorkTreeFile :: ActionItem -> Maybe FilePath
-actionItemWorkTreeFile (ActionItemAssociatedFile af) = af
+actionItemWorkTreeFile (ActionItemAssociatedFile (AssociatedFile af)) = af
actionItemWorkTreeFile _ = Nothing
actionItemTransferDirection :: ActionItem -> Maybe Direction
diff --git a/Types/Key.hs b/Types/Key.hs
index 9df1144aa..44ebe3ca0 100644
--- a/Types/Key.hs
+++ b/Types/Key.hs
@@ -23,7 +23,8 @@ data Key = Key
} deriving (Eq, Ord, Read, Show)
{- A filename may be associated with a Key. -}
-type AssociatedFile = Maybe FilePath
+newtype AssociatedFile = AssociatedFile (Maybe FilePath)
+ deriving (Show, Eq, Ord)
{- There are several different varieties of keys. -}
data KeyVariety
diff --git a/Types/Transfer.hs b/Types/Transfer.hs
index 349eccf4b..ade8fc763 100644
--- a/Types/Transfer.hs
+++ b/Types/Transfer.hs
@@ -36,13 +36,13 @@ data TransferInfo = TransferInfo
, transferTid :: Maybe ThreadId
, transferRemote :: Maybe Remote
, bytesComplete :: Maybe Integer
- , associatedFile :: Maybe FilePath
+ , associatedFile :: AssociatedFile
, transferPaused :: Bool
}
deriving (Show, Eq, Ord)
stubTransferInfo :: TransferInfo
-stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False
+stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing (AssociatedFile Nothing) False
data Direction = Upload | Download
deriving (Eq, Ord, Show, Read)
@@ -64,5 +64,5 @@ instance Arbitrary TransferInfo where
<*> pure Nothing -- remote not needed
<*> arbitrary
-- associated file cannot be empty (but can be Nothing)
- <*> arbitrary `suchThat` (/= Just "")
+ <*> (AssociatedFile <$> arbitrary `suchThat` (/= Just ""))
<*> arbitrary