add optional object file location to storeKey
This will be used by the next commit to simplify the proxy.
This commit is contained in:
Joey Hess
parent
0dfdc9f951
commit
8b5fc94d50
20 changed files with 93 additions and 79 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue