add optional object file location to storeKey

This will be used by the next commit to simplify the proxy.

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 693c1de2da19b1321c4ba3869ef2dffbb5b165e7..3c10def782b1f46d5fe12629da1ec9f92c7c7bf6 100644 (file)
--- 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
-
-prepSendAnnex' :: Key -> Annex (Maybe (FilePath, FileSize, Annex (Maybe String)))
-prepSendAnnex' key = prepSendAnnex key >>= \case
+-- 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 -> 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 60ab714f1d87cd5d74ba6df650cc4bd6290d8552..ccd00576116ea61fdd82e427eee4c67229b90ea3 100644 (file)
--- 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 4235dfcd8d0cace775cb37c085727db34d63a75f..1c1abf4fd5ab797dca85b013f95e7d6580f06635 100644 (file)
--- 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 3fd633c43b6cad8343840c39a27ac3df3ef1b759..a7ee89f11d7221382c98b322917ecd07f10682c2 100644 (file)
--- 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 ea6bbea0faf04fc6c4823cd087e0f1ae662850f2..4d92656ffb87e6a5f9569cc1f8a83f5f8dcfeb0b 100644 (file)
--- 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 a934a48d56b63839c1600f8deeb57f989abcdb73..f0f2ac8efe731f38f88f4487a42ec318739342df 100644 (file)
--- 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 e5564ce9890f29bfe6b864e0b539da4fd8445008..b942fe84b06878d5f9a592086ec52dac5ae7d2d3 100644 (file)
--- 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 fe7a71fb514438f7b602daf9f725d3b8a0125feb..4312ecaeb92c20d03085e7cbb0448d3f8a3bd9f3 100644 (file)
--- 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 f48567eb00e83c5f602667bedd92eebc8aed34a7..9be12f50fb6c46ea3955ea55bb0d555f66b3ed37 100644 (file)
--- 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 14a7aef1fcca768f7c9789ce62a74187384de178..2d7ea08f63c913971b414dbc27f292054998cf96 100644 (file)
--- 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 c65e5c0cd7a3849b3fc23e2f591ca5434310c836..1a3bcd5d7ecb4077e9a68856448b8c37b5d3b24f 100644 (file)
--- 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 16ed8ff86f45be1585abdf8bc30c7deea552fb9e..2a43c17fc76bb4d04c0cb052453c5903f863971d 100644 (file)
--- 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 9cc83c4397dc55500374eb724156e14842dc0d46..6c8772d47bd9750c936bc0c444ae6632260b532f 100644 (file)
--- 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 33c4771e4676a34f730d6adfed07829be4598250..d74aa669115ddcf6e6e9f32f9219bf91c7305e3c 100644 (file)
--- 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 80c0f9f6a9ef8bead2231a4038967285f646f155..244023899a437ca8f7a8e5a94d8b9a40f7ede657 100644 (file)
--- 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 abce2fe2f4117bfe8ea4ade4fd00c1f299faa787..c79bd20bf89f9dacd5711119993888b6e0415a50 100644 (file)
--- 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 4cb61241599f3a87d2602537f18d21f9b3c7fb35..dc0d307ccd77048c024b0b3360dc2770c8362383 100644 (file)
--- 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 6b9138b9816082211fb018bf65a9dd99358bce63..db6b12a34e283b9ecaa45e0fcdeb7462980fef3c 100644 (file)
--- 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 f953b8d929c3fcbfb232ecad16204d3a97811724..7bb54a9a4cc7aeef8c69f0674f2573bd2e24c92c 100644 (file)
--- 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 e4575eb3cd17391f6555fae8e221d5bd0922566f..62780db11e83394f51032d2634bb0e4703763a5b 100644 (file)
--- 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.)