aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--CHANGELOG6
-rw-r--r--Remote/WebDAV.hs55
-rw-r--r--doc/bugs/Upload_to_box_very_slow/comment_2_380443c65e576959dddae499745bff09._comment8
-rw-r--r--doc/bugs/git-annex_can_no_longer_copy_files_to_box/comment_7_654cda20c0775e16c14ae8b1134aa042._comment20
4 files changed, 72 insertions, 17 deletions
diff --git a/CHANGELOG b/CHANGELOG
index 91ea30fde..efc81decf 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -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..
+"""]]