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

add optional object file location to storeKey

Browse source 
This will be used by the next commit to simplify the proxy.
This commit is contained in:
Joey Hess 2024-07-01 10:42:27 -04:00
parent 0dfdc9f951
commit 8b5fc94d50
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
20 changed files with 93 additions and 79 deletions
Download patch file Download diff file Expand all files Collapse all files

27
Annex/Content.hs
View file

@ -552,8 +552,8 @@ unlinkAnnex key = do
- If this happens, runs the rollback action and throws an exception. - If this happens, runs the rollback action and throws an exception.
- The rollback action should remove the data that was transferred. - The rollback action should remove the data that was transferred.
-} -}
sendAnnex :: Key -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a sendAnnex :: Key -> Maybe FilePath -> Annex () -> (FilePath -> FileSize -> Annex a) -> Annex a
sendAnnex key rollback sendobject = go =<< prepSendAnnex' key sendAnnex key o rollback sendobject = go =<< prepSendAnnex' key o
where where
go (Just (f, sz, check)) = do go (Just (f, sz, check)) = do
r <- sendobject f sz 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 - Annex monad of the remote that is receiving the object, rather than
- the sender. So it cannot rely on Annex state. - the sender. So it cannot rely on Annex state.
-} -}
prepSendAnnex :: Key -> Annex (Maybe (FilePath, FileSize, Annex Bool)) prepSendAnnex :: Key -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex Bool))
prepSendAnnex key = withObjectLoc key $ \f -> do prepSendAnnex key Nothing = withObjectLoc key $ \f -> do
let retval c cs = return $ Just let retval c cs = return $ Just
(fromRawFilePath f ( fromRawFilePath f
, inodeCacheFileSize c , inodeCacheFileSize c
, sameInodeCache f cs , sameInodeCache f cs
) )
@ -601,9 +601,22 @@ prepSendAnnex key = withObjectLoc key $ \f -> do
, return Nothing , return Nothing
) )
Nothing -> 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 -> Maybe FilePath -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String)))
prepSendAnnex' key = prepSendAnnex key >>= \case prepSendAnnex' key o = prepSendAnnex key o >>= \case
Just (f, sz, checksuccess) -> Just (f, sz, checksuccess) ->
let checksuccess' = ifM checksuccess let checksuccess' = ifM checksuccess
( return Nothing ( return Nothing

4
Annex/Proxy.hs
View file

@ -154,14 +154,14 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv endv = go
-- It will be dropped again afterwards. Unless it's already -- It will be dropped again afterwards. Unless it's already
-- present there. -- present there.
ifM (inAnnex k) 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 Right () -> liftIO $ sendmessage ALREADY_HAVE
Left err -> liftIO $ propagateerror err Left err -> liftIO $ propagateerror err
, do , do
liftIO $ sendmessage $ PUT_FROM (Offset 0) liftIO $ sendmessage $ PUT_FROM (Offset 0)
ifM receivedata ifM receivedata
( do ( do
tryNonAsync (Remote.storeKey r k af nullMeterUpdate) >>= \case tryNonAsync (Remote.storeKey r k af Nothing nullMeterUpdate) >>= \case
Right () -> do Right () -> do
depopulateobjectfile depopulateobjectfile
liftIO $ sendmessage SUCCESS liftIO $ sendmessage SUCCESS

6
Annex/Transfer.hs
View file

@ -55,13 +55,13 @@ import Data.Ord
-- Upload, supporting canceling detected stalls. -- Upload, supporting canceling detected stalls.
upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool 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 case getStallDetection Upload r of
Nothing -> go (Just ProbeStallDetection) Nothing -> go (Just ProbeStallDetection)
Just StallDetectionDisabled -> go Nothing 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 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, not supporting canceling detected stalls
upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v upload' :: Observable v => UUID -> Key -> AssociatedFile -> Maybe StallDetection -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v

2
Command/Export.hs
View file

@ -304,7 +304,7 @@ performExport r db ek af contentsha loc allfilledvar = do
alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do alwaysUpload (uuid r) ek af Nothing stdRetry $ \pm -> do
let rollback = void $ let rollback = void $
performUnexport r db [ek] loc performUnexport r db [ek] loc
sendAnnex ek rollback $ \f _sz -> sendAnnex ek Nothing rollback $ \f _sz ->
Remote.action $ Remote.action $
storer f ek loc pm storer f ek loc pm
, do , do

2
Command/SendKey.hs
View file

@ -32,7 +32,7 @@ start (_, key) = do
<$> getField "RsyncOptions" <$> getField "RsyncOptions"
ifM (inAnnex key) ifM (inAnnex key)
( fieldTransfer Upload key $ \_p -> ( fieldTransfer Upload key $ \_p ->
sendAnnex key rollback $ \f _sz -> sendAnnex key Nothing rollback $ \f _sz ->
liftIO $ rsyncServerSend (map Param opts) f liftIO $ rsyncServerSend (map Param opts) f
, do , do
warning "requested key is not present" warning "requested key is not present"

4
Command/TestRemote.hs
View file

@ -302,7 +302,7 @@ test runannex mkr mkk =
tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate (RemoteVerify r)) >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left _ -> return (False, UnVerified) 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 remove r k = Remote.removeKey r k
testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree] testExportTree :: RunAnnex -> Annex (Maybe Remote) -> Annex Key -> Annex Key -> [TestTree]
@ -368,7 +368,7 @@ testUnavailable runannex mkr mkk =
[ check isLeft "removeKey" $ \r k -> [ check isLeft "removeKey" $ \r k ->
Remote.removeKey r k Remote.removeKey r k
, check isLeft "storeKey" $ \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 -> , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k ->
Remote.checkPresent r k Remote.checkPresent r k
, check (== Right False) "retrieveKeyFile" $ \r k -> , check (== Right False) "retrieveKeyFile" $ \r k ->

14
Command/TransferKey.hs
View file

@ -50,9 +50,9 @@ start o (_, key) = startingCustomOutput key $ case fromToOptions o of
FromRemote src -> fromPerform key (fileOption o) =<< getParsed src FromRemote src -> fromPerform key (fileOption o) =<< getParsed src
toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
toPerform key file remote = go Upload file $ toPerform key af remote = go Upload af $
upload' (uuid remote) key file Nothing stdRetry $ \p -> do upload' (uuid remote) key af Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case
Right () -> do Right () -> do
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
return True return True
@ -61,10 +61,10 @@ toPerform key file remote = go Upload file $
return False return False
fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
fromPerform key file remote = go Upload file $ fromPerform key af remote = go Upload af $
download' (uuid remote) key file Nothing stdRetry $ \p -> download' (uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key file Nothing $ \t -> logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) vc key af Nothing $ \t ->
tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p vc) >>= \case tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p vc) >>= \case
Right v -> return (True, v) Right v -> return (True, v)
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))

16
Command/TransferKeys.hs
View file

@ -38,20 +38,20 @@ start = do
runRequests readh writeh runner runRequests readh writeh runner
stop stop
where where
runner (TransferRequest direction remote key file) runner (TransferRequest direction remote key af)
| direction == Upload = notifyTransfer direction file $ | direction == Upload = notifyTransfer direction af $
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))
return False return False
Right () -> do Right () -> do
Remote.logStatus remote key InfoPresent Remote.logStatus remote key InfoPresent
return True return True
| otherwise = notifyTransfer direction file $ | otherwise = notifyTransfer direction af $
download' (Remote.uuid remote) key file Nothing stdRetry $ \p -> download' (Remote.uuid remote) key af Nothing stdRetry $ \p ->
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) >>= \case r <- tryNonAsync (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote)) >>= \case
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))
return (False, UnVerified) return (False, UnVerified)

22
Command/Transferrer.hs
View file

@ -42,27 +42,27 @@ start = do
runRequests readh writeh runner runRequests readh writeh runner
stop stop
where where
runner (UploadRequest _ key (TransferAssociatedFile file)) remote = runner (UploadRequest _ key (TransferAssociatedFile af)) remote =
-- This is called by eg, Annex.Transfer.upload, -- This is called by eg, Annex.Transfer.upload,
-- so caller is responsible for doing notification, -- so caller is responsible for doing notification,
-- and for retrying, and updating location log, -- and for retrying, and updating location log,
-- and stall canceling. -- and stall canceling.
upload' (Remote.uuid remote) key file Nothing noRetry upload' (Remote.uuid remote) key af Nothing noRetry
(Remote.action . Remote.storeKey remote key file) (Remote.action . Remote.storeKey remote key af Nothing)
noNotification noNotification
runner (DownloadRequest _ key (TransferAssociatedFile file)) remote = runner (DownloadRequest _ key (TransferAssociatedFile af)) remote =
-- This is called by eg, Annex.Transfer.download -- This is called by eg, Annex.Transfer.download
-- so caller is responsible for doing notification -- so caller is responsible for doing notification
-- and for retrying, and updating location log, -- and for retrying, and updating location log,
-- and stall canceling. -- and stall canceling.
let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file Nothing $ \t -> do let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key af Nothing $ \t -> do
Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p (RemoteVerify remote)) Remote.verifiedAction (Remote.retrieveKeyFile remote key af (fromRawFilePath t) p (RemoteVerify remote))
in download' (Remote.uuid remote) key file Nothing noRetry go in download' (Remote.uuid remote) key af Nothing noRetry go
noNotification noNotification
runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = runner (AssistantUploadRequest _ key (TransferAssociatedFile af)) remote =
notifyTransfer Upload file $ notifyTransfer Upload af $
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do upload' (Remote.uuid remote) key af Nothing stdRetry $ \p -> do
tryNonAsync (Remote.storeKey remote key file p) >>= \case tryNonAsync (Remote.storeKey remote key af Nothing p) >>= \case
Left e -> do Left e -> do
warning (UnquotedString (show e)) warning (UnquotedString (show e))
return False return False

6
P2P/Annex.hs
View file

@ -51,7 +51,7 @@ runLocal runst runner a = case a of
let getsize = liftIO . catchMaybeIO . getFileSize let getsize = liftIO . catchMaybeIO . getFileSize
size <- inAnnex' isJust Nothing getsize k size <- inAnnex' isJust Nothing getsize k
runner (next (Len <$> size)) runner (next (Len <$> size))
ReadContent k af o sender next -> do ReadContent k af o offset sender next -> do
let proceed c = do let proceed c = do
r <- tryNonAsync c r <- tryNonAsync c
case r of case r of
@ -62,12 +62,12 @@ runLocal runst runner a = case a of
-- run for any other reason, the sender action still must -- run for any other reason, the sender action still must
-- be run, so is given empty and Invalid data. -- be run, so is given empty and Invalid data.
let fallback = runner (sender mempty (return Invalid)) let fallback = runner (sender mempty (return Invalid))
v <- tryNonAsync $ prepSendAnnex k v <- tryNonAsync $ prepSendAnnex k o
case v of case v of
Right (Just (f, _sz, checkchanged)) -> proceed $ do Right (Just (f, _sz, checkchanged)) -> proceed $ do
-- alwaysUpload to allow multiple uploads of the same key. -- alwaysUpload to allow multiple uploads of the same key.
let runtransfer ti = transfer alwaysUpload k af Nothing $ \p -> 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 checktransfer runtransfer fallback
Right Nothing -> proceed fallback Right Nothing -> proceed fallback
Left e -> return $ Left $ ProtoFailureException e Left e -> return $ Left $ ProtoFailureException e

13
P2P/Protocol.hs
View file

@ -264,7 +264,7 @@ data LocalF c
| ContentSize Key (Maybe Len -> c) | ContentSize Key (Maybe Len -> c)
-- ^ Gets size of the content of a key, when the full content is -- ^ Gets size of the content of a key, when the full content is
-- present. -- 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. -- ^ Reads the content of a key and sends it to the callback.
-- Must run the callback, or terminate the protocol connection. -- Must run the callback, or terminate the protocol connection.
-- --
@ -396,7 +396,7 @@ put key af p = do
net $ sendMessage (PUT (ProtoAssociatedFile af) key) net $ sendMessage (PUT (ProtoAssociatedFile af) key)
r <- net receiveMessage r <- net receiveMessage
case r of 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 -> return (Just [])
Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids) Just (ALREADY_HAVE_PLUS uuids) -> return (Just uuids)
_ -> do _ -> do
@ -502,7 +502,7 @@ serveAuthed servermode myuuid = void $ serverLoop handler
notallowed notallowed
return ServerContinue return ServerContinue
handler (GET offset (ProtoAssociatedFile af) key) = do 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 -- setPresent not called because the peer may have
-- requested the data but not permanently stored it. -- requested the data but not permanently stored it.
return ServerContinue return ServerContinue
@ -570,14 +570,14 @@ checkCONNECTServerMode service servermode a =
(ServeReadOnly, UploadPack) -> a Nothing (ServeReadOnly, UploadPack) -> a Nothing
(ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError) (ServeReadOnly, ReceivePack) -> a (Just sendReadOnlyError)
sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto (Maybe [UUID]) sendContent :: Key -> AssociatedFile -> Maybe FilePath -> Offset -> MeterUpdate -> Proto (Maybe [UUID])
sendContent key af offset@(Offset n) p = go =<< local (contentSize key) sendContent key af o offset@(Offset n) p = go =<< local (contentSize key)
where where
go (Just (Len totallen)) = do go (Just (Len totallen)) = do
let len = totallen - n let len = totallen - n
if len <= 0 if len <= 0
then sender (Len 0) L.empty (return Valid) then sender (Len 0) L.empty (return Valid)
else local $ readContent key af offset $ else local $ readContent key af o offset $
sender (Len len) sender (Len len)
-- Content not available to send. Indicate this by sending -- Content not available to send. Indicate this by sending
-- empty data and indlicate it's invalid. -- empty data and indlicate it's invalid.
@ -711,3 +711,4 @@ relayToPeer (RelayToPeer b) = do
sendMessage (DATA len) sendMessage (DATA len)
sendBytes len b nullMeterUpdate sendBytes len b nullMeterUpdate
relayToPeer (RelayFromPeer _) = return () relayToPeer (RelayFromPeer _) = return ()

4
Remote/BitTorrent.hs
View file

@ -118,8 +118,8 @@ downloadKey key _file dest p _ = do
unless ok $ unless ok $
get [] get []
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
uploadKey _ _ _ = giveup "upload to bittorrent not supported" uploadKey _ _ _ _ = giveup "upload to bittorrent not supported"
dropKey :: Key -> Annex () dropKey :: Key -> Annex ()
dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k dropKey k = mapM_ (setUrlMissing k) =<< getBitTorrentUrls k

20
Remote/Git.hs
View file

@ -504,7 +504,7 @@ copyFromRemote'' repo r st@(State connpool _ _ _ _) key file dest meterupdate vc
let bwlimit = remoteAnnexBwLimitDownload (gitconfig r) let bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
<|> remoteAnnexBwLimit (gitconfig r) <|> remoteAnnexBwLimit (gitconfig r)
-- run copy from perspective of remote -- 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 Just (object, _sz, check) -> do
let checksuccess = check >>= \case let checksuccess = check >>= \case
Just err -> giveup err Just err -> giveup err
@ -543,22 +543,22 @@ copyFromRemoteCheap _ _ = Nothing
#endif #endif
{- Tries to copy a key's content to a remote's annex. -} {- Tries to copy a key's content to a remote's annex. -}
copyToRemote :: Remote -> State -> Key -> AssociatedFile -> MeterUpdate -> Annex () copyToRemote :: Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
copyToRemote r st key file meterupdate = do copyToRemote r st key af o meterupdate = do
repo <- getRepo r 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' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
| not $ Git.repoIsUrl repo = ifM duc | not $ Git.repoIsUrl repo = ifM duc
( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $ ( 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" , giveup "remote does not have expected annex.uuid value"
) )
| Git.repoIsSsh repo = | Git.repoIsSsh repo =
P2PHelper.store (uuid r) (gitconfig r) P2PHelper.store (uuid r) (gitconfig r)
(Ssh.runProto r connpool (return Nothing)) (Ssh.runProto r connpool (return Nothing))
key file meterupdate key af o meterupdate
| otherwise = giveup "copying to non-ssh repo not supported" | otherwise = giveup "copying to non-ssh repo not supported"
where where
@ -575,14 +575,14 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate
-- run copy from perspective of remote -- run copy from perspective of remote
res <- onLocalFast st $ ifM (Annex.Content.inAnnex key) res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
( return True ( 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 let verify = RemoteVerify r
copier <- mkFileCopier hardlink st copier <- mkFileCopier hardlink st
let rsp = RetrievalAllKeysSecure let rsp = RetrievalAllKeysSecure
let checksuccess = liftIO checkio >>= \case let checksuccess = liftIO checkio >>= \case
Just err -> giveup err Just err -> giveup err
Nothing -> return True 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' -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' ->
copier object (fromRawFilePath dest) key p' checksuccess verify copier object (fromRawFilePath dest) key p' checksuccess verify
) )

4
Remote/Helper/Hooks.hs
View file

@ -34,8 +34,8 @@ addHooks' r Nothing Nothing = r
addHooks' r starthook stophook = r' addHooks' r starthook stophook = r'
where where
r' = r r' = r
{ storeKey = \k f p -> { storeKey = \k af o p ->
wrapper $ storeKey r k f p wrapper $ storeKey r k af o p
, retrieveKeyFile = \k f d p vc -> , retrieveKeyFile = \k f d p vc ->
wrapper $ retrieveKeyFile r k f d p vc wrapper $ retrieveKeyFile r k f d p vc
, retrieveKeyFileCheap = case retrieveKeyFileCheap r of , retrieveKeyFileCheap = case retrieveKeyFileCheap r of

6
Remote/Helper/P2P.hs
View file

@ -34,9 +34,9 @@ type ProtoConnRunner c = forall a. P2P.Proto a -> ClosableConnection c -> Annex
-- the pool when done. -- the pool when done.
type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a type WithConn a c = (ClosableConnection c -> Annex (ClosableConnection c, a)) -> Annex a
store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> MeterUpdate -> Annex () store :: UUID -> RemoteGitConfig -> ProtoRunner (Maybe [UUID]) -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
store remoteuuid gc runner k af p = do store remoteuuid gc runner k af o p = do
let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k) let sizer = KeySizer k (fmap (toRawFilePath . fst3) <$> prepSendAnnex k o)
let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc
metered (Just p) sizer bwlimit $ \_ p' -> metered (Just p) sizer bwlimit $ \_ p' ->
runner (P2P.put k af p') >>= \case runner (P2P.put k af p') >>= \case

4
Remote/Helper/ReadOnly.hs
View file

@ -44,8 +44,8 @@ adjustReadOnly r
} }
| otherwise = r | otherwise = r
readonlyStoreKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () readonlyStoreKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
readonlyStoreKey _ _ _ = readonlyFail readonlyStoreKey _ _ _ _ = readonlyFail
readonlyRemoveKey :: Key -> Annex () readonlyRemoveKey :: Key -> Annex ()
readonlyRemoveKey _ = readonlyFail readonlyRemoveKey _ = readonlyFail

8
Remote/Helper/Special.hs
View file

@ -134,8 +134,8 @@ fileRetriever' a k m miv callback = do
- but they are never actually used (since specialRemote replaces them). - but they are never actually used (since specialRemote replaces them).
- Here are some dummy ones. - Here are some dummy ones.
-} -}
storeKeyDummy :: Key -> AssociatedFile -> MeterUpdate -> Annex () storeKeyDummy :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
storeKeyDummy _ _ _ = error "missing storeKey implementation" storeKeyDummy _ _ _ _ = error "missing storeKey implementation"
retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification retrieveKeyFileDummy :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation" retrieveKeyFileDummy _ _ _ _ _ = error "missing retrieveKeyFile implementation"
removeKeyDummy :: Key -> Annex () removeKeyDummy :: Key -> Annex ()
@ -181,7 +181,7 @@ specialRemote' :: SpecialRemoteCfg -> RemoteModifier
specialRemote' cfg c storer retriever remover checkpresent baser = encr specialRemote' cfg c storer retriever remover checkpresent baser = encr
where where
encr = baser 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 , retrieveKeyFile = \k _f d p vc -> cip >>= retrieveKeyFileGen k d p vc
, retrieveKeyFileCheap = case retrieveKeyFileCheap baser of , retrieveKeyFileCheap = case retrieveKeyFileCheap baser of
Nothing -> Nothing Nothing -> Nothing
@ -222,7 +222,7 @@ specialRemote' cfg c storer retriever remover checkpresent baser = encr
isencrypted = isEncrypted c isencrypted = isEncrypted c
-- chunk, then encrypt, then feed to the storer -- 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' -> displayprogress uploadbwlimit p k (Just src) $ \p' ->
storeChunks (uuid baser) chunkconfig enck k src p' storeChunks (uuid baser) chunkconfig enck k src p'
enc encr storer checkpresent enc encr storer checkpresent

4
Remote/Tahoe.hs
View file

@ -138,8 +138,8 @@ tahoeSetup _ mu _ c _ = do
where where
missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use." missingfurl = giveup "Set TAHOE_FURL to the introducer furl to use."
store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex () store :: RemoteStateHandle -> TahoeHandle -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
store rs hdl k _f _p = sendAnnex k noop $ \src _sz -> store rs hdl k _af o _p = sendAnnex k o noop $ \src _sz ->
parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe
(giveup "tahoe failed to store content") (giveup "tahoe failed to store content")
(\cap -> storeCapability rs k cap) (\cap -> storeCapability rs k cap)

4
Remote/Web.hs
View file

@ -181,8 +181,8 @@ downloadKey urlincludeexclude key _af dest p vc =
setEquivilantKey key ek setEquivilantKey key ek
return (Just Verified) return (Just Verified)
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex () uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
uploadKey _ _ _ = giveup "upload to web not supported" uploadKey _ _ _ _ = giveup "upload to web not supported"
dropKey :: UrlIncludeExclude -> Key -> Annex () dropKey :: UrlIncludeExclude -> Key -> Annex ()
dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k dropKey urlincludeexclude k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k

2
Types/Remote.hs
View file

@ -91,7 +91,7 @@ data RemoteA a = Remote
-- The key should not appear to be present on the remote until -- The key should not appear to be present on the remote until
-- all of its contents have been transferred. -- all of its contents have been transferred.
-- Throws exception on failure. -- Throws exception on failure.
, storeKey :: Key -> AssociatedFile -> MeterUpdate -> a () , storeKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> a ()
-- Retrieves a key's contents to a file. -- Retrieves a key's contents to a file.
-- (The MeterUpdate does not need to be used if it writes -- (The MeterUpdate does not need to be used if it writes
-- sequentially to the file.) -- sequentially to the file.)