diff options
4 files changed, 72 insertions, 17 deletions
@@ -1,3 +1,9 @@ +git-annex (6.20171004) UNRELEASED; urgency=medium + + * webdav: Make --debug show all webdav operations. + + -- Joey Hess <id@joeyh.name> Sat, 07 Oct 2017 14:11:00 -0400 + git-annex (6.20171003) unstable; urgency=medium * webdav: Improve error message for failed request to include the request diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index 6714dcbe4..b571d5ab4 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -20,6 +20,8 @@ import qualified Network.HTTP.Client as HTTP import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch +import Control.Monad.IO.Class (MonadIO) +import System.Log.Logger (debugM) import Annex.Common import Types.Remote @@ -130,12 +132,14 @@ store _ (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () storeHelper dav tmp dest reqbody = do maybe noop (void . mkColRecursive) (locationParent tmp) + debugDav $ "putContent " ++ tmp inLocation tmp $ putContentM' (contentType, reqbody) finalizeStore dav tmp dest finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO () finalizeStore dav tmp dest = do + debugDav $ "delContent " ++ dest inLocation dest $ void $ safely $ delContentM maybe noop (void . mkColRecursive) (locationParent dest) moveDAV (baseURL dav) tmp dest @@ -150,8 +154,10 @@ retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $ goDAV dav $ retrieveHelper (keyLocation k) d p retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> DAVT IO () -retrieveHelper loc d p = inLocation loc $ - withContentM $ httpBodyRetriever d p +retrieveHelper loc d p = do + debugDav $ "retrieve " ++ loc + inLocation loc $ + withContentM $ httpBodyRetriever d p remove :: Maybe DavHandle -> Remover remove Nothing _ = return False @@ -162,6 +168,7 @@ remove (Just dav) k = liftIO $ goDAV dav $ removeHelper :: DavLocation -> DAVT IO Bool removeHelper d = do + debugDav $ "delContent " ++ d v <- safely $ inLocation d delContentM case v of Just _ -> return True @@ -205,8 +212,10 @@ removeExportDav mh _k loc = runExport mh $ \_dav -> removeHelper (exportLocation loc) removeExportDirectoryDav :: Maybe DavHandle -> ExportDirectory -> Annex Bool -removeExportDirectoryDav mh dir = runExport mh $ \_dav -> - safely (inLocation (fromExportDirectory dir) delContentM) +removeExportDirectoryDav mh dir = runExport mh $ \_dav -> do + let d = fromExportDirectory dir + debugDav $ "delContent " ++ d + safely (inLocation d delContentM) >>= maybe (return False) (const $ return True) renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool @@ -295,14 +304,16 @@ mkColRecursive :: DavLocation -> DAVT IO Bool mkColRecursive d = go =<< existsDAV d where go (Right True) = return True - go _ = ifM (inLocation d mkCol) - ( return True - , do - case locationParent d of - Nothing -> makeParentDirs - Just parent -> void (mkColRecursive parent) - inLocation d mkCol - ) + go _ = do + debugDav $ "mkCol " ++ d + ifM (inLocation d mkCol) + ( return True + , do + case locationParent d of + Nothing -> makeParentDirs + Just parent -> void (mkColRecursive parent) + inLocation d mkCol + ) getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair) getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u) @@ -322,12 +333,16 @@ throwIO :: String -> IO a throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO () -moveDAV baseurl src dest = inLocation src $ moveContentM newurl +moveDAV baseurl src dest = do + debugDav $ "moveContent " ++ src ++ " " ++ newurl + inLocation src $ moveContentM (B8.fromString newurl) where - newurl = B8.fromString (locationUrl baseurl dest) + newurl = locationUrl baseurl dest existsDAV :: DavLocation -> DAVT IO (Either String Bool) -existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) +existsDAV l = do + debugDav $ "getProps " ++ l + inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) where check = do -- Some DAV services only support depth of 1, and @@ -415,6 +430,7 @@ storeLegacyChunked chunksize k dav b = where storehttp l b' = void $ goDAV dav $ do maybe noop (void . mkColRecursive) (locationParent l) + debugDav $ "putContent " ++ l inLocation l $ putContentM (contentType, b') storer locs = Legacy.storeChunked chunksize locs storehttp b recorder l s = storehttp l (L8.fromString s) @@ -428,7 +444,8 @@ retrieveLegacyChunked :: DavHandle -> Retriever retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $ withStoredFilesLegacyChunked k dav onerr $ \locs -> Legacy.meteredWriteFileChunks p d locs $ \l -> - goDAV dav $ + goDAV dav $ do + debugDav $ "getContent " ++ l inLocation l $ snd <$> getContentM where @@ -462,7 +479,8 @@ withStoredFilesLegacyChunked -> IO a withStoredFilesLegacyChunked k dav onerr a = do let chunkcount = keyloc ++ Legacy.chunkCount - v <- goDAV dav $ safely $ + v <- goDAV dav $ safely $ do + debugDav $ "getContent " ++ chunkcount inLocation chunkcount $ snd <$> getContentM case v of @@ -475,3 +493,6 @@ withStoredFilesLegacyChunked k dav onerr a = do else a chunks where keyloc = keyLocation k + +debugDav :: MonadIO m => String -> DAVT m () +debugDav msg = liftIO $ debugM "WebDAV" msg diff --git a/doc/bugs/Upload_to_box_very_slow/comment_2_380443c65e576959dddae499745bff09._comment b/doc/bugs/Upload_to_box_very_slow/comment_2_380443c65e576959dddae499745bff09._comment new file mode 100644 index 000000000..6dbd775ba --- /dev/null +++ b/doc/bugs/Upload_to_box_very_slow/comment_2_380443c65e576959dddae499745bff09._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 2""" + date="2017-10-07T18:05:44Z" + content=""" +Also, I've added logging of all webdav operations with --debug, which +should help with determining what operation is being slow. +"""]] diff --git a/doc/bugs/git-annex_can_no_longer_copy_files_to_box/comment_7_654cda20c0775e16c14ae8b1134aa042._comment b/doc/bugs/git-annex_can_no_longer_copy_files_to_box/comment_7_654cda20c0775e16c14ae8b1134aa042._comment new file mode 100644 index 000000000..eeac2f549 --- /dev/null +++ b/doc/bugs/git-annex_can_no_longer_copy_files_to_box/comment_7_654cda20c0775e16c14ae8b1134aa042._comment @@ -0,0 +1,20 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 7""" + date="2017-10-07T18:08:49Z" + content=""" +It's interesting you reproduced it when building with stack. I'm a bit +confused because in your other bug report, you seemed to have git-annex +built with stack working without this bug? + +In any case, IIRC stack will use haskell libraries installed system-wide in +some cases, so it may be picking up whatever the problimatic library is +from Arch Linux. + +If you can reproduce it with stack on a system that does not have a +system-wide ghc installed, I'd think I should also be able to build with +stack and reproduce it.. + +Also, I've just made --debug log all webdav operations, which should help +track down what operation is failing.. +"""]] |