Does not yet update progress meter.
module P2P.Http.Client (
module P2P.Http.Client,
+ module P2P.Http.Types,
Validity(..),
) where
import Types.Remote
import P2P.Http
import P2P.Http.Url
+import P2P.Http.Types
import Annex.Common
import P2P.Protocol hiding (Offset, Bypass, auth)
import Annex.Concurrent
#ifdef WITH_SERVANT
clientPut
- :: ClientEnv
- -> ProtocolVersion
- -> B64Key
- -> B64UUID ServerSide
- -> B64UUID ClientSide
- -> [B64UUID Bypass]
- -> Maybe Auth
+ :: MeterUpdate
+ -> Key
-> Maybe Offset
-> AssociatedFile
-> FilePath
-> FileSize
-> Annex Bool
- -> Annex PutResultPlus
-clientPut clientenv (ProtocolVersion ver) k su cu bypass auth moffset af contentfile contentfilesize validitycheck = do
+ -- ^ Called after sending the file to check if it's valid.
+ -> ClientAction PutResultPlus
+clientPut meterupdate k moffset af contentfile contentfilesize validitycheck clientenv (ProtocolVersion ver) su cu bypass auth = do
checkv <- liftIO newEmptyTMVarIO
checkresultv <- liftIO newEmptyTMVarIO
let checker = do
Left err -> do
void $ liftIO $ atomically $ tryPutTMVar checkv ()
join $ liftIO (wait checkerthread)
- throwM err
+ return (Left err)
Right res -> do
join $ liftIO (wait checkerthread)
- return res
+ return (Right res)
where
stream h checkv checkresultv = S.SourceT $ \a -> do
bl <- L.hGetContents h
offset = case moffset of
Nothing -> 0
Just (Offset o) -> fromIntegral o
+
+ bk = B64Key k
cli src = case ver of
- 3 -> v3 su V3 len k cu bypass baf moffset src auth
- 2 -> v2 su V2 len k cu bypass baf moffset src auth
- 1 -> plus <$> v1 su V1 len k cu bypass baf moffset src auth
- 0 -> plus <$> v0 su V0 len k cu bypass baf moffset src auth
+ 3 -> v3 su V3 len bk cu bypass baf moffset src auth
+ 2 -> v2 su V2 len bk cu bypass baf moffset src auth
+ 1 -> plus <$> v1 su V1 len bk cu bypass baf moffset src auth
+ 0 -> plus <$> v0 su V0 len bk cu bypass baf moffset src auth
_ -> error "unsupported protocol version"
_ :<|> _ :<|> _ :<|> _ :<|>
_ :<|>
_ :<|>
v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI
+#else
+clientPut _ _ _ _ _ _ _ = ()
#endif
#ifdef WITH_SERVANT
clientPutOffset
- :: ClientEnv
- -> ProtocolVersion
- -> B64Key
- -> B64UUID ServerSide
- -> B64UUID ClientSide
- -> [B64UUID Bypass]
- -> Maybe Auth
- -> IO PutOffsetResultPlus
-clientPutOffset clientenv (ProtocolVersion ver) k su cu bypass auth
- | ver == 0 = return (PutOffsetResultPlus (Offset 0))
- | otherwise =
- withClientM cli clientenv $ \case
- Left err -> throwM err
- Right res -> return res
+ :: Key
+ -> ClientAction PutOffsetResultPlus
+clientPutOffset k clientenv (ProtocolVersion ver) su cu bypass auth
+ | ver == 0 = return (Right (PutOffsetResultPlus (Offset 0)))
+ | otherwise = liftIO $ withClientM cli clientenv return
where
+ bk = B64Key k
+
cli = case ver of
- 3 -> v3 su V3 k cu bypass auth
- 2 -> v2 su V2 k cu bypass auth
- 1 -> plus <$> v1 su V1 k cu bypass auth
+ 3 -> v3 su V3 bk cu bypass auth
+ 2 -> v2 su V2 bk cu bypass auth
+ 1 -> plus <$> v1 su V1 bk cu bypass auth
_ -> error "unsupported protocol version"
_ :<|> _ :<|> _ :<|> _ :<|>
_ :<|>
_ :<|> _ :<|> _ :<|> _ :<|>
v3 :<|> v2 :<|> v1 :<|> _ = client p2pHttpAPI
+#else
+clientPutOffset _ = ()
#endif
#ifdef WITH_SERVANT
copyFromRemote'' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
copyFromRemote'' repo r st@(State connpool _ _ _ _) key af dest meterupdate vc
- | isP2PHttp r = p2phttp
+ | isP2PHttp r = copyp2phttp
| Git.repoIsHttp repo = verifyKeyContentIncrementally vc key $ \iv -> do
gc <- Annex.getGitConfig
ok <- Url.withUrlOptionsPromptingCreds $
bwlimit = remoteAnnexBwLimitDownload (gitconfig r)
<|> remoteAnnexBwLimit (gitconfig r)
- p2phttp = verifyKeyContentIncrementally vc key $ \iv -> do
+ copyp2phttp = verifyKeyContentIncrementally vc key $ \iv -> do
startsz <- liftIO $ tryWhenExists $
getFileSize (toRawFilePath dest)
bracketIO (openBinaryFile dest ReadWriteMode) (hClose) $ \h -> do
copyToRemote' :: Git.Repo -> Remote -> State -> Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
copyToRemote' repo r st@(State connpool duc _ _ _) key af o meterupdate
+ | isP2PHttp r = prepsendwith copyp2phttp
| not $ Git.repoIsUrl repo = ifM duc
( guardUsable repo (giveup "cannot access remote") $ commitOnCleanup repo r st $
- copylocal =<< Annex.Content.prepSendAnnex' key o
+ prepsendwith copylocal
, giveup "remote does not have expected annex.uuid value"
)
| Git.repoIsSsh repo =
(Ssh.runProto r connpool (return Nothing))
key af o meterupdate
- | otherwise = giveup "copying to non-ssh repo not supported"
+ | otherwise = giveup "copying to this remote is not supported"
where
- copylocal Nothing = giveup "content not available"
- copylocal (Just (object, sz, check)) = do
+ prepsendwith a = Annex.Content.prepSendAnnex' key o >>= \case
+ Nothing -> giveup "content not available"
+ Just v -> a v
+
+ bwlimit = remoteAnnexBwLimitUpload (gitconfig r)
+ <|> remoteAnnexBwLimit (gitconfig r)
+
+ failedsend = giveup "failed to send content to remote"
+
+ copylocal (object, sz, check) = do
-- The check action is going to be run in
-- the remote's Annex, but it needs access to the local
-- Annex monad's state.
checkio <- Annex.withCurrentState check
u <- getUUID
hardlink <- wantHardLink
- let bwlimit = remoteAnnexBwLimitUpload (gitconfig r)
- <|> remoteAnnexBwLimit (gitconfig r)
-- run copy from perspective of remote
res <- onLocalFast st $ ifM (Annex.Content.inAnnex key)
( return True
copier object (fromRawFilePath dest) key p' checksuccess verify
)
unless res $
- giveup "failed to send content to remote"
+ failedsend
+
+ copyp2phttp (object, sz, check) =
+ let check' = check >>= \case
+ Just s -> do
+ warning (UnquotedString s)
+ return False
+ Nothing -> return True
+ in p2pHttpClient r (const $ pure $ PutOffsetResultPlus (Offset 0)) (clientPutOffset key) >>= \case
+ PutOffsetResultPlus offset ->
+ metered (Just meterupdate) key bwlimit $ \_ p -> do
+ res <- p2pHttpClient r giveup $
+ clientPut p key (Just offset) af object sz check'
+ case res of
+ PutResultPlus False _ ->
+ failedsend
+ PutResultPlus True fanoutuuids ->
+ storefanout fanoutuuids
+ PutOffsetResultAlreadyHavePlus fanoutuuids ->
+ storefanout fanoutuuids
+
+ storefanout = P2PHelper.storeFanout key (uuid r) . map fromB64UUID
fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool)
fsckOnRemote r params
let bwlimit = remoteAnnexBwLimitUpload gc <|> remoteAnnexBwLimit gc
metered (Just p) sizer bwlimit $ \_ p' ->
runner (P2P.put k af p') >>= \case
- Just (Just fanoutuuids) -> do
- -- Storing on the remote can cause it
- -- to be stored on additional UUIDs,
- -- so record those.
- forM_ fanoutuuids $ \u ->
- when (u /= remoteuuid) $
- logChange k u InfoPresent
+ Just (Just fanoutuuids) ->
+ storeFanout k remoteuuid fanoutuuids
Just Nothing -> giveup "Transfer failed"
Nothing -> remoteUnavail
+storeFanout :: Key -> UUID -> [UUID] -> Annex ()
+storeFanout k remoteuuid us =
+ -- Storing on the remote can cause it to be stored on additional UUIDs,
+ -- so record those.
+ forM_ us $ \u ->
+ when (u /= remoteuuid) $
+ logChange k u InfoPresent
+
retrieve :: RemoteGitConfig -> (ProtoRunner (Bool, Verification)) -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
retrieve gc runner k af dest p verifyconfig = do
iv <- startVerifyKeyContentIncrementally verifyconfig k
projects / git-annex.git / commitdiff