From 8b5fc94d50a2f0b4c052d1e0cd984086226744e9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 1 Jul 2024 10:42:27 -0400 Subject: [PATCH] add optional object file location to storeKey This will be used by the next commit to simplify the proxy. --- Annex/Content.hs | 27 ++++++++++++++++++++------- Annex/Proxy.hs | 4 ++-- Annex/Transfer.hs | 6 +++--- Command/Export.hs | 2 +- Command/SendKey.hs | 2 +- Command/TestRemote.hs | 4 ++-- Command/TransferKey.hs | 14 +++++++------- Command/TransferKeys.hs | 16 ++++++++-------- Command/Transferrer.hs | 22 +++++++++++----------- P2P/Annex.hs | 6 +++--- P2P/Protocol.hs | 13 +++++++------ Remote/BitTorrent.hs | 4 ++-- Remote/Git.hs | 20 ++++++++++---------- Remote/Helper/Hooks.hs | 4 ++-- Remote/Helper/P2P.hs | 6 +++--- Remote/Helper/ReadOnly.hs | 4 ++-- Remote/Helper/Special.hs | 8 ++++---- Remote/Tahoe.hs | 4 ++-- Remote/Web.hs | 4 ++-- Types/Remote.hs | 2 +- 20 files changed, 93 insertions(+), 79 deletions(-) diff --git a/Annex/Content.hs b/Annex/Content.hs index 693c1de2da..3c10def782 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -552,8 +552,8 @@ unlinkAnnex key = do - If this happens, runs the rollback action and throws an exception. - The rollback action should remove the data that was transferred. -} -sendAnnex :: Key -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a -sendAnnex key rollback sendobject = go =<< prepSendAnnex' key +sendAnnex :: Key -> Maybe FilePath -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a +sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o where go (Just (f, sz, check)) = do r <- sendobject f sz @@ -575,10 +575,10 @@ sendAnnex key rollback sendobject = go =<< prepSendAnnex' key - Annex monad of the remote that is receiving the object, rather than - the sender. So it cannot rely on Annex state. -} -prepSendAnnex :: Key -> Annex (Maybe (FilePath, FileSize, Annex Bool)) -prepSendAnnex key = withObjectLoc key $ \f -> do +prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool)) +prepSendAnnex key Nothing = withObjectLoc key $ \f -> do let retval c cs = return $ Just - (fromRawFilePath f + ( fromRawFilePath f , inodeCacheFileSize c , sameInodeCache f cs ) @@ -601,9 +601,22 @@ prepSendAnnex key = withObjectLoc key $ \f -> do , return Nothing ) Nothing -> return Nothing +-- If the provided object file is the annex object file, handle as above. +prepSendAnnex key (Just o) = withObjectLoc key $ \aof -> + let o' = toRawFilePath o + in if aof == o' + then prepSendAnnex key Nothing + else do + withTSDelta (liftIO . genInodeCache o') >>= \case + Nothing -> return Nothing + Just c -> return $ Just + ( o + , inodeCacheFileSize c + , sameInodeCache o' [c] + ) -prepSendAnnex' :: Key -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) -prepSendAnnex' key = prepSendAnnex key >>= \case +prepSendAnnex' :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String))) +prepSendAnnex' key o = prepSendAnnex key o >>= \case Just (f, sz, checksuccess) -> let checksuccess' = ifM checksuccess ( return Nothing diff --git a/Annex/Proxy.hs b/Annex/Proxy.hs index 60ab714f1d..ccd0057611 100644 --- a/Annex/Proxy.hs +++ b/Annex/Proxy.hs @@ -154,14 +154,14 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv endv = go -- It will be dropped again afterwards. Unless it's already -- present there. ifM (inAnnex k) - ( tryNonAsync (Remote.storeKey r k af nullMeterUpdate) >>= \case + ( tryNonAsync (Remote.storeKey r k af Nothing nullMeterUpdate) >>= \case Right () -> liftIO $ sendmessage ALREADY_HAVE Left err -> liftIO $ propagateerror err , do liftIO $ sendmessage $ PUT_FROM (Offset 0) ifM receivedata ( do - tryNonAsync (Remote.storeKey r k af nullMeterUpdate) >>= \case + tryNonAsync (Remote.storeKey r k af Nothing nullMeterUpdate) >>= \case Right () -> do depopulateobjectfile liftIO $ sendmessage SUCCESS diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index 4235dfcd8d..1c1abf4fd5 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -55,13 +55,13 @@ import Data.Ord -- Upload, supporting canceling detected stalls. upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool -upload r key f d witness = +upload r key af d witness = case getStallDetection Upload r of Nothing -> go (Just ProbeStallDetection) Just StallDetectionDisabled -> go Nothing - Just sd -> runTransferrer sd r key f d Upload witness + Just sd -> runTransferrer sd r key af d Upload witness where - go sd = upload' (Remote.uuid r) key f sd d (action . Remote.storeKey r key f) witness + go sd = upload' (Remote.uuid r) key af sd d (action . Remote.storeKey r key af Nothing) witness -- Upload, not supporting canceling detected stalls upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v diff --git a/Command/Export.hs b/Command/Export.hs index 3fd633c43b..a7ee89f11d 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -304,7 +304,7 @@ performExport r db ek af contentsha loc allfilledvar = do alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc - sendAnnex ek rollback $ \f _sz -> + sendAnnex ek Nothing rollback $ \f _sz -> Remote.action $ storer f ek loc pm , do diff --git a/Command/SendKey.hs b/Command/SendKey.hs index ea6bbea0fa..4d92656ffb 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -32,7 +32,7 @@ start (_, key) = do <$> getField "RsyncOptions" ifM (inAnnex key) ( fieldTransfer Upload key $ \_p -> - sendAnnex key rollback $ \f _sz -> + sendAnnex key Nothing rollback $ \f _sz -> liftIO $ rsyncServerSend (map Param opts) f , do warning "requested key is not present" diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index a934a48d56..f0f2ac8efe 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -302,7 +302,7 @@ test runannex mkr mkk = tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) - store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate + store r k = Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate remove r k = Remote.removeKey r k testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree] @@ -368,7 +368,7 @@ testUnavailable runannex mkr mkk = [ check isLeft "removeKey" $ \r k -> Remote.removeKey r k , check isLeft "storeKey" $ \r k -> - Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate + Remote.storeKey r k (AssociatedFile Nothing) Nothing nullMeterUpdate , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index e5564ce989..b942fe84b0 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -50,9 +50,9 @@ start o (_, key) = startingCustomOutput key $ case fromToOptions o of FromRemote src -> fromPerform key (fileOption o) =<< getParsed src toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform -toPerform key file remote = go Upload file $ - upload' (uuid remote) key file Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key file p) >>= \case +toPerform key af remote = go Upload af $ + upload' (uuid remote) key af Nothing stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Right () -> do Remote.logStatus remote key InfoPresent return True @@ -61,10 +61,10 @@ toPerform key file remote = go Upload file $ return False fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform -fromPerform key file remote = go Upload file $ - download' (uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file Nothing $ \t -> - tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case +fromPerform key af remote = go Upload af $ + download' (uuid remote) key af Nothing stdRetry $ \p -> + logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t -> + tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case Right v -> return (True, v) Left e -> do warning (UnquotedString (show e)) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index fe7a71fb51..4312ecaeb9 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -38,20 +38,20 @@ start = do runRequests readh writeh runner stop where - runner (TransferRequest direction remote key file) - | direction == Upload = notifyTransfer direction file $ - upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key file p) >>= \case + runner (TransferRequest direction remote key af) + | direction == Upload = notifyTransfer direction af $ + upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Left e -> do warning (UnquotedString (show e)) return False Right () -> do Remote.logStatus remote key InfoPresent return True - | otherwise = notifyTransfer direction file $ - download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> - logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case + | otherwise = notifyTransfer direction af $ + download' (Remote.uuid remote) key af Nothing stdRetry $ \p -> + logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do + r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case Left e -> do warning (UnquotedString (show e)) return (False, UnVerified) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs index f48567eb00..9be12f50fb 100644 --- a/Command/Transferrer.hs +++ b/Command/Transferrer.hs @@ -42,27 +42,27 @@ start = do runRequests readh writeh runner stop where - runner (UploadRequest _ key (TransferAssociatedFile file)) remote = + runner (UploadRequest _ key (TransferAssociatedFile af)) remote = -- This is called by eg, Annex.Transfer.upload, -- so caller is responsible for doing notification, -- and for retrying, and updating location log, -- and stall canceling. - upload' (Remote.uuid remote) key file Nothing noRetry - (Remote.action . Remote.storeKey remote key file) + upload' (Remote.uuid remote) key af Nothing noRetry + (Remote.action . Remote.storeKey remote key af Nothing) noNotification - runner (DownloadRequest _ key (TransferAssociatedFile file)) remote = + runner (DownloadRequest _ key (TransferAssociatedFile af)) remote = -- This is called by eg, Annex.Transfer.download -- so caller is responsible for doing notification -- and for retrying, and updating location log, -- and stall canceling. - let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do - Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) - in download' (Remote.uuid remote) key file Nothing noRetry go + let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do + Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) + in download' (Remote.uuid remote) key af Nothing noRetry go noNotification - runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = - notifyTransfer Upload file $ - upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do - tryNonAsync (Remote.storeKey remote key file p) >>= \case + runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote = + notifyTransfer Upload af $ + upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case Left e -> do warning (UnquotedString (show e)) return False diff --git a/P2P/Annex.hs b/P2P/Annex.hs index 14a7aef1fc..2d7ea08f63 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -51,7 +51,7 @@ runLocal runst runner a = case a of let getsize = liftIO . catchMaybeIO . getFileSize size <- inAnnex' isJust Nothing getsize k runner (next (Len <$> size)) - ReadContent k af o sender next -> do + ReadContent k af o offset sender next -> do let proceed c = do r <- tryNonAsync c case r of @@ -62,12 +62,12 @@ runLocal runst runner a = case a of -- run for any other reason, the sender action still must -- be run, so is given empty and Invalid data. let fallback = runner (sender mempty (return Invalid)) - v <- tryNonAsync $ prepSendAnnex k + v <- tryNonAsync $ prepSendAnnex k o case v of Right (Just (f, _sz, checkchanged)) -> proceed $ do -- alwaysUpload to allow multiple uploads of the same key. let runtransfer ti = transfer alwaysUpload k af Nothing $ \p -> - sinkfile f o checkchanged sender p ti + sinkfile f offset checkchanged sender p ti checktransfer runtransfer fallback Right Nothing -> proceed fallback Left e -> return $ Left $ ProtoFailureException e diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs index c65e5c0cd7..1a3bcd5d7e 100644 --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -264,7 +264,7 @@ data LocalF c | ContentSize Key (Maybe Len -> c) -- ^ Gets size of the content of a key, when the full content is -- present. - | ReadContent Key AssociatedFile Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c) + | ReadContent Key AssociatedFile (Maybe FilePath) Offset (L.ByteString -> Proto Validity -> Proto (Maybe [UUID])) (Maybe [UUID] -> c) -- ^ Reads the content of a key and sends it to the callback. -- Must run the callback, or terminate the protocol connection. -- @@ -396,7 +396,7 @@ put key af p = do net $ sendMessage (PUT (ProtoAssociatedFile af) key) r <- net receiveMessage case r of - Just (PUT_FROM offset) -> sendContent key af offset p + Just (PUT_FROM offset) -> sendContent key af Nothing offset p Just ALREADY_HAVE -> return (Just []) Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids) _ -> do @@ -502,7 +502,7 @@ serveAuthed servermode myuuid = void $ serverLoop handler notallowed return ServerContinue handler (GET offset (ProtoAssociatedFile af) key) = do - void $ sendContent key af offset nullMeterUpdate + void $ sendContent key af Nothing offset nullMeterUpdate -- setPresent not called because the peer may have -- requested the data but not permanently stored it. return ServerContinue @@ -570,14 +570,14 @@ checkCONNECTServerMode service servermode a = (ServeReadOnly, UploadPack) -> a Nothing (ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError) -sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto (Maybe [UUID]) -sendContent key af offset@(Offset n) p = go =<< local (contentSize key) +sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID]) +sendContent key af o offset@(Offset n) p = go =<< local (contentSize key) where go (Just (Len totallen)) = do let len = totallen - n if len <= 0 then sender (Len 0) L.empty (return Valid) - else local $ readContent key af offset $ + else local $ readContent key af o offset $ sender (Len len) -- Content not available to send. Indicate this by sending -- empty data and indlicate it's invalid. @@ -711,3 +711,4 @@ relayToPeer (RelayToPeer b) = do sendMessage (DATA len) sendBytes len b nullMeterUpdate relayToPeer (RelayFromPeer _) = return () + diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs index 16ed8ff86f..2a43c17fc7 100644 --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -118,8 +118,8 @@ downloadKey key _file dest p _ = do unless ok $ get [] -uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () -uploadKey _ _ _ = giveup "upload to bittorrent not supported" +uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +uploadKey _ _ _ _ = giveup "upload to bittorrent not supported" dropKey :: Key -> Annex () dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k diff --git a/Remote/Git.hs b/Remote/Git.hs index 9cc83c4397..6c8772d47b 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -504,7 +504,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc let bwlimit = remoteAnnexBwLimitDownload (gitconfig r) <|> remoteAnnexBwLimit (gitconfig r) -- run copy from perspective of remote - onLocalFast st $ Annex.Content.prepSendAnnex' key >>= \case + onLocalFast st $ Annex.Content.prepSendAnnex' key Nothing >>= \case Just (object, _sz, check) -> do let checksuccess = check >>= \case Just err -> giveup err @@ -543,22 +543,22 @@ copyFromRemoteCheap _ _ = Nothing #endif {- Tries to copy a key's content to a remote's annex. -} -copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () -copyToRemote r st key file meterupdate = do +copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +copyToRemote r st key af o meterupdate = do repo <- getRepo r - copyToRemote' repo r st key file meterupdate + copyToRemote' repo r st key af o meterupdate -copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () -copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate +copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate | not $ Git.repoIsUrl repo = ifM duc ( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $ - copylocal =<< Annex.Content.prepSendAnnex' key + copylocal =<< Annex.Content.prepSendAnnex' key o , giveup "remote does not have expected annex.uuid value" ) | Git.repoIsSsh repo = P2PHelper.store (uuid r) (gitconfig r) (Ssh.runProto r connpool (return Nothing)) - key file meterupdate + key af o meterupdate | otherwise = giveup "copying to non-ssh repo not supported" where @@ -575,14 +575,14 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate -- run copy from perspective of remote res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) ( return True - , runTransfer (Transfer Download u (fromKey id key)) Nothing file Nothing stdRetry $ \p -> do + , runTransfer (Transfer Download u (fromKey id key)) Nothing af Nothing stdRetry $ \p -> do let verify = RemoteVerify r copier <- mkFileCopier hardlink st let rsp = RetrievalAllKeysSecure let checksuccess = liftIO checkio >>= \case Just err -> giveup err Nothing -> return True - logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file (Just sz) $ \dest -> + logStatusAfter key $ Annex.Content.getViaTmp rsp verify key af (Just sz) $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> copier object (fromRawFilePath dest) key p' checksuccess verify ) diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index 33c4771e46..d74aa66911 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -34,8 +34,8 @@ addHooks' r Nothing Nothing = r addHooks' r starthook stophook = r' where r' = r - { storeKey = \k f p -> - wrapper $ storeKey r k f p + { storeKey = \k af o p -> + wrapper $ storeKey r k af o p , retrieveKeyFile = \k f d p vc -> wrapper $ retrieveKeyFile r k f d p vc , retrieveKeyFileCheap = case retrieveKeyFileCheap r of diff --git a/Remote/Helper/P2P.hs b/Remote/Helper/P2P.hs index 80c0f9f6a9..244023899a 100644 --- a/Remote/Helper/P2P.hs +++ b/Remote/Helper/P2P.hs @@ -34,9 +34,9 @@ type ProtoConnRunner c = forall a. P2P.Proto a -> ClosableConnection c -> Annex -- the pool when done. type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a -store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> MeterUpdate -> Annex () -store remoteuuid gc runner k af p = do - let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k) +store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +store remoteuuid gc runner k af o p = do + let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k o) let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc metered (Just p) sizer bwlimit $ \_ p' -> runner (P2P.put k af p') >>= \case diff --git a/Remote/Helper/ReadOnly.hs b/Remote/Helper/ReadOnly.hs index abce2fe2f4..c79bd20bf8 100644 --- a/Remote/Helper/ReadOnly.hs +++ b/Remote/Helper/ReadOnly.hs @@ -44,8 +44,8 @@ adjustReadOnly r } | otherwise = r -readonlyStoreKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () -readonlyStoreKey _ _ _ = readonlyFail +readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +readonlyStoreKey _ _ _ _ = readonlyFail readonlyRemoveKey :: Key -> Annex () readonlyRemoveKey _ = readonlyFail diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 4cb6124159..dc0d307ccd 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -134,8 +134,8 @@ fileRetriever' a k m miv callback = do - but they are never actually used (since specialRemote replaces them). - Here are some dummy ones. -} -storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex () -storeKeyDummy _ _ _ = error "missing storeKey implementation" +storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +storeKeyDummy _ _ _ _ = error "missing storeKey implementation" retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation" removeKeyDummy :: Key -> Annex () @@ -181,7 +181,7 @@ specialRemote' :: SpecialRemoteCfg -> RemoteModifier specialRemote' cfg c storer retriever remover checkpresent baser = encr where encr = baser - { storeKey = \k _f p -> cip >>= storeKeyGen k p + { storeKey = \k _af o p -> cip >>= storeKeyGen k o p , retrieveKeyFile = \k _f d p vc -> cip >>= retrieveKeyFileGen k d p vc , retrieveKeyFileCheap = case retrieveKeyFileCheap baser of Nothing -> Nothing @@ -222,7 +222,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr isencrypted = isEncrypted c -- chunk, then encrypt, then feed to the storer - storeKeyGen k p enc = sendAnnex k rollback $ \src _sz -> + storeKeyGen k o p enc = sendAnnex k o rollback $ \src _sz -> displayprogress uploadbwlimit p k (Just src) $ \p' -> storeChunks (uuid baser) chunkconfig enck k src p' enc encr storer checkpresent diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs index 6b9138b981..db6b12a34e 100644 --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -138,8 +138,8 @@ tahoeSetup _ mu _ c _ = do where missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." -store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex () -store rs hdl k _f _p = sendAnnex k noop $ \src _sz -> +store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz -> parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe (giveup "tahoe failed to store content") (\cap -> storeCapability rs k cap) diff --git a/Remote/Web.hs b/Remote/Web.hs index f953b8d929..7bb54a9a4c 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -181,8 +181,8 @@ downloadKey urlincludeexclude key _af dest p vc = setEquivilantKey key ek return (Just Verified) -uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () -uploadKey _ _ _ = giveup "upload to web not supported" +uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () +uploadKey _ _ _ _ = giveup "upload to web not supported" dropKey :: UrlIncludeExclude -> Key -> Annex () dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k diff --git a/Types/Remote.hs b/Types/Remote.hs index e4575eb3cd..62780db11e 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -91,7 +91,7 @@ data RemoteA a = Remote -- The key should not appear to be present on the remote until -- all of its contents have been transferred. -- Throws exception on failure. - , storeKey :: Key -> AssociatedFile -> MeterUpdate -> a () + , storeKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> a () -- Retrieves a key's contents to a file. -- (The MeterUpdate does not need to be used if it writes -- sequentially to the file.)