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
Show stats 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 baseurl (Just (u, p)) = do
showSideAction "testing WebDAV server"
liftIO $ either (throwIO . showEitherException) (const noop)
=<< catchHttp go
test "make directory" $ davMkdir baseurl user pass
test "write file" $ putContentAndProps testurl user pass
(noProps, (contentType, L.empty))
test "delete file" $ deleteContent testurl user pass
where
go = do
davMkdir baseurl user pass
putContentAndProps testurl user pass
(noProps, (contentType, L.empty))
deleteContent testurl user pass
test desc a = liftIO $
either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ showEitherException e)
(const noop)
=<< catchHttp a
user = toDavUser u
pass = toDavPass p