From 8cb9381befed4174624edfc80e09185c9340b4f6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 10 Mar 2017 13:12:24 -0400 Subject: AssociatedFile newtype To prevent any further mistakes like 1a497cefb47557f0b4788c606f9071be422b2511 This commit was sponsored by Francois Marier on Patreon. --- Annex/Drop.hs | 12 +++++---- Annex/FileMatcher.hs | 4 +-- Annex/Notification.hs | 16 ++++++------ Annex/Transfer.hs | 10 ++++---- Assistant/DeleteRemote.hs | 2 +- Assistant/Threads/Committer.hs | 7 +++--- Assistant/Threads/Cronner.hs | 2 +- Assistant/Threads/SanityChecker.hs | 4 +-- Assistant/Threads/TransferScanner.hs | 9 ++++--- Assistant/TransferSlots.hs | 9 ++++--- Assistant/Upgrade.hs | 2 +- Backend/Hash.hs | 4 +-- Command/AddUrl.hs | 15 +++++++---- Command/Copy.hs | 4 +-- Command/Drop.hs | 7 +++--- Command/DropUnused.hs | 4 +-- Command/Fsck.hs | 49 +++++++++++++++++++++--------------- Command/Get.hs | 7 +++--- Command/Info.hs | 9 +++++-- Command/MetaData.hs | 4 +-- Command/Migrate.hs | 5 ++-- Command/Mirror.hs | 10 +++++--- Command/Move.hs | 4 +-- Command/SendKey.hs | 2 +- Command/Sync.hs | 4 +-- Command/TestRemote.hs | 11 ++++---- Command/TransferInfo.hs | 4 +-- Command/TransferKey.hs | 4 +-- Command/TransferKeys.hs | 8 +++--- Command/Whereis.hs | 2 +- Key.hs | 2 +- Limit/Wanted.hs | 10 +++++--- Logs/Transfer.hs | 17 ++++++++----- P2P/Protocol.hs | 9 ++++--- Remote/GCrypt.hs | 9 ++++--- Remote/Git.hs | 3 ++- Remote/Helper/Ssh.hs | 2 +- Types.hs | 2 +- Types/ActionItem.hs | 12 ++++----- Types/Key.hs | 3 ++- Types/Transfer.hs | 6 ++--- 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 -- cgit v1.2.3