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

webdav now supports sending chunked content

Browse source 
Not yet getting it though.
This commit is contained in:
Joey Hess 2012-11-16 17:58:58 -04:00
parent 92d5d81c2c
commit a1869ad662
1 changed files with 23 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

38
Remote/WebDAV.hs
View file

@ -12,6 +12,7 @@ module Remote.WebDAV (remote) where
import Network.Protocol.HTTP.DAV import Network.Protocol.HTTP.DAV
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.UTF8 as B8
import qualified Data.ByteString.Lazy.UTF8 as L8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.XML as XML import qualified Text.XML as XML
@ -26,6 +27,7 @@ import qualified Git
import Config import Config
import Remote.Helper.Special import Remote.Helper.Special
import Remote.Helper.Encryptable import Remote.Helper.Encryptable
import Remote.Helper.Chunked
import Crypto import Crypto
import Creds import Creds
@ -84,34 +86,40 @@ store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f _p = davAction r False $ \(baseurl, user, pass) -> do store r k _f _p = davAction r False $ \(baseurl, user, pass) -> do
let url = davLocation baseurl k let url = davLocation baseurl k
f <- inRepo $ gitAnnexLocation k f <- inRepo $ gitAnnexLocation k
b <- liftIO $ L.readFile f liftIO $ storeHelper r url user pass =<< L.readFile f
liftIO $ davMkdir (urlParent url) user pass
v <- liftIO $ catchMaybeHttp $ putContentAndProps url user pass
(noProps, (contentType, b))
return $ isJust v
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r (cipher, enck) k _p = davAction r False $ \(baseurl, user, pass) -> do storeEncrypted r (cipher, enck) k _p = davAction r False $ \(baseurl, user, pass) -> do
f <- inRepo $ gitAnnexLocation k
let url = davLocation baseurl enck let url = davLocation baseurl enck
liftIO $ davMkdir (urlParent url) user pass f <- inRepo $ gitAnnexLocation k
v <- liftIO $ withEncryptedContent cipher (L.readFile f) $ \b -> liftIO $ withEncryptedContent cipher (L.readFile f) $
catchMaybeHttp $ putContentAndProps url user pass storeHelper r url user pass
(noProps, (contentType, b))
return $ isJust v storeHelper :: Remote -> DavUrl -> DavUser -> DavPass -> L.ByteString -> IO Bool
storeHelper r urlbase user pass b = catchBoolIO $ do
davMkdir (urlParent urlbase) user pass
storeChunks urlbase chunksize storer recorder finalizer
where
chunksize = chunkSize $ config r
storer urls = storeChunked chunksize urls storehttp b
recorder url s = storehttp url (L8.fromString s)
finalizer srcurl desturl =
moveContent srcurl (B8.fromString desturl) user pass
storehttp url v = putContentAndProps url user pass
(noProps, (contentType, v))
retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieve r k _f d = retrieve' r k (L.writeFile d) retrieve r k _f d = retrieveHelper r k (L.writeFile d)
retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False retrieveCheap _ _ _ = return False
retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted r (cipher, enck) _ d = retrieve' r enck $ \b -> do retrieveEncrypted r (cipher, enck) _ d = retrieveHelper r enck $ \b -> do
withDecryptedContent cipher (return b) (L.writeFile d) withDecryptedContent cipher (return b) (L.writeFile d)
retrieve' :: Remote -> Key -> (L.ByteString -> IO ()) -> Annex Bool retrieveHelper :: Remote -> Key -> (L.ByteString -> IO ()) -> Annex Bool
retrieve' r k saver = davAction r False $ \(baseurl, user, pass) -> liftIO $ do retrieveHelper r k saver = davAction r False $ \(baseurl, user, pass) -> liftIO $ do
let url = davLocation baseurl k let url = davLocation baseurl k
maybe (return False) save maybe (return False) save
=<< catchMaybeHttp (getPropsAndContent url user pass) =<< catchMaybeHttp (getPropsAndContent url user pass)