avoid printing really ugly webdav exceptions
The responseheaders can sometimes include the entire input request, which is several pages of garbage.
This commit is contained in:
parent
81e1b2078e
commit
f69a9274f9
1 changed files with 18 additions and 5 deletions
|
@ -255,14 +255,14 @@ existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e))
|
||||||
check = do
|
check = do
|
||||||
setDepth Nothing
|
setDepth Nothing
|
||||||
catchJust
|
catchJust
|
||||||
(matchStatusCodeException notFound404)
|
(matchStatusCodeException (== notFound404))
|
||||||
(getPropsM >> ispresent True)
|
(getPropsM >> ispresent True)
|
||||||
(const $ ispresent False)
|
(const $ ispresent False)
|
||||||
ispresent = return . Right
|
ispresent = return . Right
|
||||||
|
|
||||||
matchStatusCodeException :: Status -> HttpException -> Maybe ()
|
matchStatusCodeException :: (Status -> Bool) -> HttpException -> Maybe HttpException
|
||||||
matchStatusCodeException want (StatusCodeException s _ _)
|
matchStatusCodeException want e@(StatusCodeException s _ _)
|
||||||
| s == want = Just ()
|
| want s = Just e
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
matchStatusCodeException _ _ = Nothing
|
matchStatusCodeException _ _ = Nothing
|
||||||
|
|
||||||
|
@ -289,12 +289,25 @@ withDAVHandle r a = do
|
||||||
_ -> a Nothing
|
_ -> a Nothing
|
||||||
|
|
||||||
goDAV :: DavHandle -> DAVT IO a -> IO a
|
goDAV :: DavHandle -> DAVT IO a -> IO a
|
||||||
goDAV (DavHandle ctx user pass _) a = choke $ run $ do
|
goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do
|
||||||
prepDAV user pass
|
prepDAV user pass
|
||||||
a
|
a
|
||||||
where
|
where
|
||||||
run = fst <$$> runDAVContext ctx
|
run = fst <$$> runDAVContext ctx
|
||||||
|
|
||||||
|
{- Catch StatusCodeException and trim it to only the statusMessage part,
|
||||||
|
- eliminating a lot of noise, which can include the whole request that
|
||||||
|
- failed. The rethrown exception is no longer a StatusCodeException. -}
|
||||||
|
prettifyExceptions :: DAVT IO a -> DAVT IO a
|
||||||
|
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
|
||||||
|
where
|
||||||
|
go (StatusCodeException status _ _) = error $ unwords
|
||||||
|
[ "DAV failure:"
|
||||||
|
, show (statusCode status)
|
||||||
|
, show (statusMessage status)
|
||||||
|
]
|
||||||
|
go e = throwM e
|
||||||
|
|
||||||
prepDAV :: DavUser -> DavPass -> DAVT IO ()
|
prepDAV :: DavUser -> DavPass -> DAVT IO ()
|
||||||
prepDAV user pass = do
|
prepDAV user pass = do
|
||||||
setResponseTimeout Nothing -- disable default (5 second!) timeout
|
setResponseTimeout Nothing -- disable default (5 second!) timeout
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue