9e11699c76
Most remotes have meters in their implementations of retrieveKeyFile already. Simply hooking these up to the transfer log makes that information available. Easy peasy. This is particularly valuable information for encrypted remotes, which otherwise bypass the assistant's polling of temp files, and so don't have good progress bars yet. Still some work to do here (see progressbars.mdwn changes), but this is entirely an improvement from the lack of progress bars for encrypted downloads.
337 lines
11 KiB
Haskell
337 lines
11 KiB
Haskell
{- WebDAV remotes.
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables, CPP #-}
|
|
|
|
module Remote.WebDAV (remote, davCreds, setCredsEnv) where
|
|
|
|
import Network.Protocol.HTTP.DAV
|
|
import qualified Data.Map as M
|
|
import qualified Data.ByteString.UTF8 as B8
|
|
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 Network.HTTP.Conduit (HttpException(..))
|
|
import Network.HTTP.Types
|
|
import System.IO.Error
|
|
|
|
import Common.Annex
|
|
import Types.Remote
|
|
import qualified Git
|
|
import Config
|
|
import Config.Cost
|
|
import Remote.Helper.Special
|
|
import Remote.Helper.Encryptable
|
|
import Remote.Helper.Chunked
|
|
import Crypto
|
|
import Creds
|
|
import Utility.Metered
|
|
import Annex.Content
|
|
|
|
type DavUrl = String
|
|
type DavUser = B8.ByteString
|
|
type DavPass = B8.ByteString
|
|
|
|
remote :: RemoteType
|
|
remote = RemoteType {
|
|
typename = "webdav",
|
|
enumerate = findSpecialRemotes "webdav",
|
|
generate = gen,
|
|
setup = webdavSetup
|
|
}
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
|
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|
where
|
|
new cst = encryptableRemote c
|
|
(storeEncrypted this)
|
|
(retrieveEncrypted this)
|
|
this
|
|
where
|
|
this = Remote {
|
|
uuid = u,
|
|
cost = cst,
|
|
name = Git.repoDescribe r,
|
|
storeKey = store this,
|
|
retrieveKeyFile = retrieve this,
|
|
retrieveKeyFileCheap = retrieveCheap this,
|
|
removeKey = remove this,
|
|
hasKey = checkPresent this,
|
|
hasKeyCheap = False,
|
|
whereisKey = Nothing,
|
|
config = c,
|
|
repo = r,
|
|
gitconfig = gc,
|
|
localpath = Nothing,
|
|
readonly = False,
|
|
globallyAvailable = True,
|
|
remotetype = remote
|
|
}
|
|
|
|
webdavSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
|
webdavSetup u c = do
|
|
let url = fromMaybe (error "Specify url=") $
|
|
M.lookup "url" c
|
|
c' <- encryptionSetup c
|
|
creds <- getCreds c' u
|
|
testDav url creds
|
|
gitConfigSpecialRemote u c' "webdav" "true"
|
|
setRemoteCredPair c' (davCreds u)
|
|
|
|
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
|
store r k _f p = metered (Just p) k $ \meterupdate ->
|
|
davAction r False $ \(baseurl, user, pass) ->
|
|
sendAnnex k (void $ remove r k) $ \src ->
|
|
liftIO $ withMeteredFile src meterupdate $
|
|
storeHelper r k baseurl user pass
|
|
|
|
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
|
storeEncrypted r (cipher, enck) k p = metered (Just p) k $ \meterupdate ->
|
|
davAction r False $ \(baseurl, user, pass) ->
|
|
sendAnnex k (void $ remove r enck) $ \src ->
|
|
liftIO $ encrypt (getGpgOpts r) cipher
|
|
(streamMeteredFile src meterupdate) $
|
|
readBytes $ storeHelper r enck baseurl user pass
|
|
|
|
storeHelper :: Remote -> Key -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool
|
|
storeHelper r k baseurl user pass b = catchBoolIO $ do
|
|
davMkdir tmpurl user pass
|
|
storeChunks k tmpurl keyurl chunksize storer recorder finalizer
|
|
where
|
|
tmpurl = tmpLocation baseurl k
|
|
keyurl = davLocation baseurl k
|
|
chunksize = chunkSize $ config r
|
|
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)
|
|
|
|
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
|
|
retrieveCheap _ _ _ = return False
|
|
|
|
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
|
|
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
|
|
case mb of
|
|
Nothing -> throwIO "download failed"
|
|
Just b -> return b
|
|
return True
|
|
where
|
|
onerr _ = return False
|
|
|
|
retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
|
|
retrieveEncrypted r (cipher, enck) k d p = metered (Just p) k $ \meterupdate ->
|
|
davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
|
|
withStoredFiles r enck baseurl user pass onerr $ \urls -> do
|
|
decrypt cipher (feeder user pass urls) $
|
|
readBytes $ meteredWriteFile meterupdate d
|
|
return True
|
|
where
|
|
onerr _ = return False
|
|
|
|
feeder _ _ [] _ = noop
|
|
feeder user pass (url:urls) h = do
|
|
mb <- davGetUrlContent url user pass
|
|
case mb of
|
|
Nothing -> throwIO "download failed"
|
|
Just b -> do
|
|
L.hPut h b
|
|
feeder user pass urls h
|
|
|
|
remove :: Remote -> Key -> Annex Bool
|
|
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)
|
|
|
|
checkPresent :: Remote -> Key -> Annex (Either String Bool)
|
|
checkPresent r k = davAction r noconn go
|
|
where
|
|
noconn = Left $ error $ name r ++ " not configured"
|
|
|
|
go (baseurl, user, pass) = do
|
|
showAction $ "checking " ++ name r
|
|
liftIO $ withStoredFiles r k baseurl user pass onerr check
|
|
where
|
|
check [] = return $ Right True
|
|
check (url:urls) = do
|
|
v <- davUrlExists url user pass
|
|
if v == Right True
|
|
then check urls
|
|
else return v
|
|
|
|
{- Failed to read the chunkcount file; see if it's missing,
|
|
- or if there's a problem accessing it,
|
|
- or perhaps this was an intermittent error. -}
|
|
onerr url = do
|
|
v <- davUrlExists url user pass
|
|
if v == Right True
|
|
then return $ Left $ "failed to read " ++ url
|
|
else return v
|
|
|
|
withStoredFiles
|
|
:: Remote
|
|
-> Key
|
|
-> DavUrl
|
|
-> DavUser
|
|
-> DavPass
|
|
-> (DavUrl -> IO a)
|
|
-> ([DavUrl] -> IO a)
|
|
-> IO a
|
|
withStoredFiles r k baseurl user pass onerr a
|
|
| isJust $ chunkSize $ config r = do
|
|
let chunkcount = keyurl ++ chunkCount
|
|
maybe (onerr chunkcount) (a . listChunks keyurl . L8.toString)
|
|
=<< davGetUrlContent chunkcount user pass
|
|
| otherwise = a [keyurl]
|
|
where
|
|
keyurl = davLocation baseurl k ++ keyFile k
|
|
|
|
davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
|
|
davAction r unconfigured action = do
|
|
mcreds <- getCreds (config r) (uuid r)
|
|
case (mcreds, M.lookup "url" $ config r) of
|
|
(Just (user, pass), Just url) ->
|
|
action (url, toDavUser user, toDavPass pass)
|
|
_ -> return unconfigured
|
|
|
|
toDavUser :: String -> DavUser
|
|
toDavUser = B8.fromString
|
|
|
|
toDavPass :: String -> DavPass
|
|
toDavPass = B8.fromString
|
|
|
|
{- The directory where files(s) for a key are stored. -}
|
|
davLocation :: DavUrl -> Key -> DavUrl
|
|
davLocation baseurl k = addTrailingPathSeparator $
|
|
davUrl baseurl $ hashDirLower k </> keyFile k
|
|
|
|
{- Where we store temporary data for a key as it's being uploaded. -}
|
|
tmpLocation :: DavUrl -> Key -> DavUrl
|
|
tmpLocation baseurl k = addTrailingPathSeparator $
|
|
davUrl baseurl $ "tmp" </> keyFile k
|
|
|
|
davUrl :: DavUrl -> FilePath -> DavUrl
|
|
davUrl baseurl file = baseurl </> file
|
|
|
|
davUrlExists :: DavUrl -> DavUser -> DavPass -> IO (Either String Bool)
|
|
davUrlExists url user pass = decode <$> catchHttp (getProps url user pass)
|
|
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
|
|
|
|
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
|
|
where
|
|
make u = makeCollection u user pass
|
|
|
|
go u = do
|
|
r <- E.try (make u) :: IO (Either E.SomeException Bool)
|
|
case r of
|
|
{- Parent directory is missing. Recurse to create
|
|
- it, and try once more to create the directory. -}
|
|
Right False -> do
|
|
go (urlParent u)
|
|
void $ make u
|
|
{- Directory created successfully -}
|
|
Right True -> return ()
|
|
{- Directory already exists, or some other error
|
|
- occurred. In the latter case, whatever wanted
|
|
- 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 ++ "/..")
|
|
where
|
|
|
|
{- Test if a WebDAV store is usable, by writing to a test file, and then
|
|
- deleting the file. Exits with an IO error if not. -}
|
|
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
|
|
where
|
|
test desc a = liftIO $
|
|
either (\e -> throwIO $ "WebDAV failed to " ++ desc ++ ": " ++ showEitherException e)
|
|
(const noop)
|
|
=<< catchHttp 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)
|
|
|
|
davCreds :: UUID -> CredPairStorage
|
|
davCreds u = CredPairStorage
|
|
{ credPairFile = fromUUID u
|
|
, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
|
|
, credPairRemoteKey = Just "davcreds"
|
|
}
|
|
|
|
setCredsEnv :: (String, String) -> IO ()
|
|
setCredsEnv creds = setEnvCredPair creds $ davCreds undefined
|