mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

instrument webdav test

Browse source
This commit is contained in:
Joey Hess 2012-12-01 14:32:50 -04:00
parent 0b6c889012
commit 757f041cd8
1 changed files with 8 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

15
Remote/WebDAV.hs
View file

@ -292,14 +292,15 @@ urlParent url = dropTrailingPathSeparator $
testDav :: String -> Maybe CredPair -> Annex () testDav :: String -> Maybe CredPair -> Annex ()
testDav baseurl (Just (u, p)) = do testDav baseurl (Just (u, p)) = do
showSideAction "testing WebDAV server" showSideAction "testing WebDAV server"
liftIO $ either (throwIO . showEitherException) (const noop) test "make directory" $ davMkdir baseurl user pass
=<< catchHttp go test "write file" $ putContentAndProps testurl user pass
(noProps, (contentType, L.empty))
test "delete file" $ deleteContent testurl user pass
where where
go = do test desc a = liftIO $
davMkdir baseurl user pass either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ showEitherException e)
putContentAndProps testurl user pass (const noop)
(noProps, (contentType, L.empty)) =<< catchHttp a
deleteContent testurl user pass
user = toDavUser u user = toDavUser u
pass = toDavPass p pass = toDavPass p