summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
Diffstat (limited to 'Remote')
-rw-r--r--Remote/WebDAV.hs204
1 files changed, 128 insertions, 76 deletions
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 4714f10dd..de1b721c9 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -16,6 +16,7 @@ import qualified Data.ByteString.Lazy.UTF8 as L8
import qualified Data.ByteString.Lazy as L
import Network.URI (normalizePathSegments)
import qualified Control.Exception as E
+import qualified Control.Exception.Lifted as EL
import Network.HTTP.Conduit (HttpException(..))
import Network.HTTP.Types
import System.IO.Error
@@ -105,7 +106,7 @@ storeEncrypted r (cipher, enck) k p = metered (Just p) k $ \meterupdate ->
storeHelper :: Remote -> Key -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool
storeHelper r k baseurl user pass b = catchBoolIO $ do
- davMkdir tmpurl user pass
+ mkdirRecursiveDAV tmpurl user pass
storeChunks k tmpurl keyurl chunksize storer recorder finalizer
where
tmpurl = tmpLocation baseurl k
@@ -114,11 +115,10 @@ storeHelper r k baseurl user pass b = catchBoolIO $ do
storer urls = storeChunked chunksize urls storehttp b
recorder url s = storehttp url (L8.fromString s)
finalizer srcurl desturl = do
- void $ catchMaybeHttp (deleteContent desturl user pass)
- davMkdir (urlParent desturl) user pass
- moveContent srcurl (B8.fromString desturl) user pass
- storehttp url v = putContent url user pass
- (contentType, v)
+ void $ tryNonAsync (deleteDAV desturl user pass)
+ mkdirRecursiveDAV (urlParent desturl) user pass
+ moveDAV srcurl desturl user pass
+ storehttp url = putDAV url user pass
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
@@ -128,7 +128,7 @@ retrieve r k _f d p = metered (Just p) k $ \meterupdate ->
davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
withStoredFiles r k baseurl user pass onerr $ \urls -> do
meteredWriteFileChunks meterupdate d urls $ \url -> do
- mb <- davGetUrlContent url user pass
+ mb <- getDAV url user pass
case mb of
Nothing -> throwIO "download failed"
Just b -> return b
@@ -148,7 +148,7 @@ retrieveEncrypted r (cipher, enck) k d p = metered (Just p) k $ \meterupdate ->
feeder _ _ [] _ = noop
feeder user pass (url:urls) h = do
- mb <- davGetUrlContent url user pass
+ mb <- getDAV url user pass
case mb of
Nothing -> throwIO "download failed"
Just b -> do
@@ -160,7 +160,7 @@ remove r k = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
-- Delete the key's whole directory, including any chunked
-- files, etc, in a single action.
let url = davLocation baseurl k
- isJust <$> catchMaybeHttp (deleteContent url user pass)
+ isJust . eitherToMaybe <$> tryNonAsync (deleteDAV url user pass)
checkPresent :: Remote -> Key -> Annex (Either String Bool)
checkPresent r k = davAction r noconn go
@@ -173,7 +173,7 @@ checkPresent r k = davAction r noconn go
where
check [] = return $ Right True
check (url:urls) = do
- v <- davUrlExists url user pass
+ v <- existsDAV url user pass
if v == Right True
then check urls
else return v
@@ -182,7 +182,7 @@ checkPresent r k = davAction r noconn go
- or if there's a problem accessing it,
- or perhaps this was an intermittent error. -}
onerr url = do
- v <- davUrlExists url user pass
+ v <- existsDAV url user pass
return $ if v == Right True
then Left $ "failed to read " ++ url
else v
@@ -199,11 +199,11 @@ withStoredFiles
withStoredFiles r k baseurl user pass onerr a
| isJust $ chunkSize $ config r = do
let chunkcount = keyurl ++ chunkCount
- v <- davGetUrlContent chunkcount user pass
+ v <- getDAV chunkcount user pass
case v of
Just s -> a $ listChunks keyurl $ L8.toString s
Nothing -> do
- chunks <- probeChunks keyurl $ \u -> (== Right True) <$> davUrlExists u user pass
+ chunks <- probeChunks keyurl $ \u -> (== Right True) <$> existsDAV u user pass
if null chunks
then onerr chunkcount
else a chunks
@@ -244,33 +244,12 @@ tmpLocation baseurl k = addTrailingPathSeparator $
davUrl :: DavUrl -> FilePath -> DavUrl
davUrl baseurl file = baseurl </> file
-davUrlExists :: DavUrl -> DavUser -> DavPass -> IO (Either String Bool)
-davUrlExists url user pass = decode <$> catchHttp get
- where
- decode (Right _) = Right True
-#if ! MIN_VERSION_http_conduit(1,9,0)
- decode (Left (Left (StatusCodeException status _)))
-#else
- decode (Left (Left (StatusCodeException status _ _)))
-#endif
- | statusCode status == statusCode notFound404 = Right False
- decode (Left e) = Left $ showEitherException e
-#if ! MIN_VERSION_DAV(0,4,0)
- get = getProps url user pass
-#else
- get = getProps url user pass Nothing
-#endif
-
-davGetUrlContent :: DavUrl -> DavUser -> DavPass -> IO (Maybe L.ByteString)
-davGetUrlContent url user pass = fmap (snd . snd) <$>
- catchMaybeHttp (getPropsAndContent url user pass)
-
{- Creates a directory in WebDAV, if not already present; also creating
- any missing parent directories. -}
-davMkdir :: DavUrl -> DavUser -> DavPass -> IO ()
-davMkdir url user pass = go url
+mkdirRecursiveDAV :: DavUrl -> DavUser -> DavPass -> IO ()
+mkdirRecursiveDAV url user pass = go url
where
- make u = makeCollection u user pass
+ make u = mkdirDAV u user pass
go u = do
r <- E.try (make u) :: IO (Either E.SomeException Bool)
@@ -287,35 +266,6 @@ davMkdir url user pass = go url
- to use this directory will fail. -}
Left _ -> return ()
-{- Catches HTTP and IO exceptions. -}
-catchMaybeHttp :: IO a -> IO (Maybe a)
-catchMaybeHttp a = (Just <$> a) `E.catches`
- [ E.Handler $ \(_e :: HttpException) -> return Nothing
- , E.Handler $ \(_e :: E.IOException) -> return Nothing
- ]
-
-{- Catches HTTP and IO exceptions -}
-catchHttp :: IO a -> IO (Either EitherException a)
-catchHttp a = (Right <$> a) `E.catches`
- [ E.Handler $ \(e :: HttpException) -> return $ Left $ Left e
- , E.Handler $ \(e :: E.IOException) -> return $ Left $ Right e
- ]
-
-type EitherException = Either HttpException E.IOException
-
-showEitherException :: EitherException -> String
-#if ! MIN_VERSION_http_conduit(1,9,0)
-showEitherException (Left (StatusCodeException status _)) =
-#else
-showEitherException (Left (StatusCodeException status _ _)) =
-#endif
- show $ statusMessage status
-showEitherException (Left httpexception) = show httpexception
-showEitherException (Right ioexception) = show ioexception
-
-throwIO :: String -> IO a
-throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing
-
urlParent :: DavUrl -> DavUrl
urlParent url = dropTrailingPathSeparator $
normalizePathSegments (dropTrailingPathSeparator url ++ "/..")
@@ -326,25 +276,20 @@ urlParent url = dropTrailingPathSeparator $
testDav :: String -> Maybe CredPair -> Annex ()
testDav baseurl (Just (u, p)) = do
showSideAction "testing WebDAV server"
- test "make directory" $ davMkdir baseurl user pass
- test "write file" $ putContent testurl user pass
- (contentType, L.empty)
- test "delete file" $ deleteContent testurl user pass
+ test "make directory" $ mkdirRecursiveDAV baseurl user pass
+ test "write file" $ putDAV testurl user pass L.empty
+ test "delete file" $ deleteDAV testurl user pass
where
test desc a = liftIO $
- either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ showEitherException e)
+ either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ show e)
(const noop)
- =<< catchHttp a
+ =<< tryNonAsync a
user = toDavUser u
pass = toDavPass p
testurl = davUrl baseurl "git-annex-test"
testDav _ Nothing = error "Need to configure webdav username and password."
-{- Content-Type to use for files uploaded to WebDAV. -}
-contentType :: Maybe B8.ByteString
-contentType = Just $ B8.fromString "application/octet-stream"
-
getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair)
getCreds c u = getRemoteCredPairFor "webdav" c (davCreds u)
@@ -354,3 +299,110 @@ davCreds u = CredPairStorage
, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
, credPairRemoteKey = Just "davcreds"
}
+
+{- Content-Type to use for files uploaded to WebDAV. -}
+contentType :: Maybe B8.ByteString
+contentType = Just $ B8.fromString "application/octet-stream"
+
+throwIO :: String -> IO a
+throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing
+
+{---------------------------------------------------------------------
+ - Low-level DAV operations, using the new DAV monad when available.
+ ---------------------------------------------------------------------}
+
+putDAV :: DavUrl -> DavUser -> DavPass -> L.ByteString -> IO ()
+putDAV url user pass b =
+#if MIN_VERSION_DAV(0,6,0)
+ goDAV url user pass $ putContentM (contentType, b)
+#else
+ putContent url user pass (contentType, b)
+#endif
+
+getDAV :: DavUrl -> DavUser -> DavPass -> IO (Maybe L.ByteString)
+getDAV url user pass = eitherToMaybe <$> tryNonAsync go
+ where
+#if MIN_VERSION_DAV(0,6,0)
+ go = goDAV url user pass $ snd <$> getContentM
+#else
+ go = snd . snd <$> getPropsAndContent url user pass
+#endif
+
+deleteDAV :: DavUrl -> DavUser -> DavPass -> IO ()
+deleteDAV url user pass =
+#if MIN_VERSION_DAV(0,6,0)
+ goDAV url user pass delContentM
+#else
+ deleteContent url user pass
+#endif
+
+moveDAV :: DavUrl -> DavUrl -> DavUser -> DavPass -> IO ()
+moveDAV url newurl user pass =
+#if MIN_VERSION_DAV(0,6,0)
+ goDAV url user pass $ moveContentM newurl'
+#else
+ moveContent url newurl' user pass
+#endif
+ where
+ newurl' = B8.fromString newurl
+
+mkdirDAV :: DavUrl -> DavUser -> DavPass -> IO Bool
+mkdirDAV url user pass =
+#if MIN_VERSION_DAV(0,6,0)
+ goDAV url user pass mkCol
+#else
+ makeCollection url user pass
+#endif
+
+existsDAV :: DavUrl -> DavUser -> DavPass -> IO (Either String Bool)
+existsDAV url user pass = either onerr id <$> tryNonAsync check
+ where
+#if MIN_VERSION_DAV(0,6,0)
+ check = goDAV url user pass $ do
+ setDepth Nothing
+ EL.catchJust
+ (matchStatusCodeException notFound404)
+ (getPropsM >> ispresent True)
+ (const $ ispresent False)
+#else
+ check = E.catchJust
+ (matchStatusCodeException notFound404)
+#if ! MIN_VERSION_DAV(0,4,0)
+ (getProps url user pass >> ispresent True)
+#else
+ (getProps url user pass Nothing >> ispresent True)
+#endif
+ (const $ ispresent False)
+#endif
+ ispresent = return . Right
+ {- This is a horrible hack, it seems that the type of the
+ - HttpException gets screwed up with DAV 0.6.x, and so
+ - I'm reduced to string matching. :( -}
+ onerr e
+ | "StatusCodeException" `isInfixOf` show e
+ && "statusCode = 404" `isInfixOf` show e = Right False
+ | otherwise = Left (show e)
+
+matchStatusCodeException :: Status -> HttpException -> Maybe ()
+#if ! MIN_VERSION_http_conduit(1,9,0)
+matchStatusCodeException want (StatusCodeException s _)
+#else
+matchStatusCodeException want (StatusCodeException s _ _)
+#endif
+ | s == want = Just ()
+ | otherwise = Nothing
+matchStatusCodeException _ _ = Nothing
+
+#if MIN_VERSION_DAV(0,6,0)
+goDAV :: DavUrl -> DavUser -> DavPass -> DAVT IO a -> IO a
+goDAV url user pass a = choke $ evalDAVT url $ do
+ setCreds user pass
+ a
+ where
+ choke :: IO (Either String a) -> IO a
+ choke f = do
+ x <- f
+ case x of
+ Left e -> error e
+ Right r -> return r
+#endif