summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-15 13:46:16 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-15 13:46:16 -0400
commit5703b97ceb3febbb521914aab7cb57f506e77529 (patch)
tree31d22289bf4a43542185afe88285b531e439b774
parent9d492cd0c4944ea346734e7b46ebf0a26f06e529 (diff)
update to dav 0.1, and basic uploading is working!
-rw-r--r--Assistant/NetMessager.hs1
-rw-r--r--Remote/S3.hs4
-rw-r--r--Remote/WebDAV.hs73
-rw-r--r--debian/control2
-rw-r--r--git-annex.cabal2
5 files changed, 53 insertions, 29 deletions
diff --git a/Assistant/NetMessager.hs b/Assistant/NetMessager.hs
index 05dfd05a3..2191e06f2 100644
--- a/Assistant/NetMessager.hs
+++ b/Assistant/NetMessager.hs
@@ -9,7 +9,6 @@ module Assistant.NetMessager where
import Assistant.Common
import Assistant.Types.NetMessager
-import qualified Git
import Control.Concurrent
import Control.Concurrent.STM
diff --git a/Remote/S3.hs b/Remote/S3.hs
index b05de6ad4..67a64e464 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -112,8 +112,8 @@ s3Setup u c = handlehost $ M.lookup "host" c
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store r k _f _p = s3Action r False $ \(conn, bucket) -> do
- dest <- inRepo $ gitAnnexLocation k
- res <- liftIO $ storeHelper (conn, bucket) r k dest
+ src <- inRepo $ gitAnnexLocation k
+ res <- liftIO $ storeHelper (conn, bucket) r k src
s3Bool res
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index e11011351..9d6efb51e 100644
--- a/Remote/WebDAV.hs
+++ b/Remote/WebDAV.hs
@@ -9,11 +9,10 @@ module Remote.WebDAV (remote) where
import Network.Protocol.HTTP.DAV
import qualified Data.Map as M
-import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.UTF8 as B8
import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.Text as T
import qualified Text.XML as XML
-import Data.Default
import Common.Annex
import Types.Remote
@@ -25,6 +24,10 @@ import Crypto
import Creds
import Annex.Content
+type DavUrl = String
+type DavUser = B8.ByteString
+type DavPass = B8.ByteString
+
remote :: RemoteType
remote = RemoteType {
typename = "webdav",
@@ -73,8 +76,14 @@ webdavSetup u c = do
setRemoteCredPair c (davCreds u)
store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store r k _f _p = davAction r False $ \creds -> do
- error "TODO"
+store r k _f _p = do
+ f <- inRepo $ gitAnnexLocation k
+ davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $ do
+ content <- L.readFile f
+ let url = Prelude.head $ davLocations baseurl k
+ putContentAndProps url user pass
+ (noProps, (contentType, content))
+ return True
storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r (cipher, enck) k _p = davAction r False $ \creds -> do
@@ -98,17 +107,37 @@ remove r k = davAction r False $ \creds -> do
checkPresent :: Remote -> Key -> Annex (Either String Bool)
checkPresent r k = davAction r noconn $ \creds -> do
showAction $ "checking " ++ name r
- error "TODO"
+ return $ Right False
+ --error "TODO"
where
noconn = Left $ error $ name r ++ " not configured"
-davAction :: Remote -> a -> (CredPair -> Annex a) -> Annex a
+davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
davAction r unconfigured action = case config r of
Nothing -> return unconfigured
- Just c -> maybe (return unconfigured) action =<< getCreds c (uuid r)
+ Just c -> do
+ mcreds <- getCreds c (uuid r)
+ case (mcreds, M.lookup "url" c) of
+ (Just (user, pass), Just url) ->
+ action (url, toDavUser user, toDavPass pass)
+ _ -> return unconfigured
+
+toDavUser :: String -> DavUser
+toDavUser = B8.fromString
-davUrl :: String -> FilePath -> String
-davUrl baseurl file = baseurl </> file
+toDavPass :: String -> DavPass
+toDavPass = B8.fromString
+
+{- All possibile locations to try to access a given Key.
+ -
+ - This is intentially the same as the directory special remote uses, to
+ - allow interoperability. -}
+davLocations :: DavUrl -> Key -> [DavUrl]
+davLocations baseurl k = map (davUrl baseurl) (keyPaths k)
+
+{- FIXME: Replacing / with _ to avoid needing collections. -}
+davUrl :: DavUrl -> FilePath -> DavUrl
+davUrl baseurl file = baseurl </> replace "/" "_" file
{- Test if a WebDAV store is usable, by writing to a test file, and then
- deleting the file. Exits with an error if not. -}
@@ -118,27 +147,23 @@ testDav baseurl (Just (u, p)) = do
showSideAction "testing WebDAV server"
liftIO $ do
putContentAndProps testurl username password
- (dummyProps, (contentType, L.empty))
- -- TODO delete testurl
+ (noProps, (contentType, L.empty))
+ deleteContent testurl username password
where
- username = B8.pack u
- password = B8.pack p
+ username = toDavUser u
+ password = toDavPass p
testurl = davUrl baseurl "git-annex-test"
{- Content-Type to use for files uploaded to WebDAV. -}
contentType :: Maybe B8.ByteString
-contentType = Just $ B8.pack "application/octet-stream"
+contentType = Just $ B8.fromString "application/octet-stream"
{- The DAV library requires that properties be specified when storing a file.
- -
- - Also, it has a bug where if no properties are present, it generates an
- - invalid XML document, that will make putContentAndProps fail.
- -
- - We don't really need to store any properties, so this is an
- - XML document that stores a single dummy property. -}
-dummyProps :: XML.Document
-dummyProps = XML.parseLBS_ def $ L8.pack
- "<D:multistatus xmlns:D=\"DAV:\"><D:response><D:propstat><D:prop><D:gitannex></D:gitannex></D:prop></D:propstat></D:response></D:multistatus>"
+ - This just omits any real properties. -}
+noProps :: XML.Document
+noProps = XML.Document (XML.Prologue [] Nothing []) root []
+ where
+ root = XML.Element (XML.Name (T.pack "propertyupdate") Nothing Nothing) [] []
getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair)
getCreds c u = maybe missing (return . Just) =<< getRemoteCredPair c creds
diff --git a/debian/control b/debian/control
index a80dca3cb..74d9c0c6a 100644
--- a/debian/control
+++ b/debian/control
@@ -12,7 +12,7 @@ Build-Depends:
libghc-http-dev,
libghc-utf8-string-dev,
libghc-hs3-dev (>= 0.5.6),
- libghc-dav-dev,
+ libghc-dav-dev (>= 0.1),
libghc-testpack-dev,
libghc-quickcheck2-dev,
libghc-monad-control-dev (>= 0.3),
diff --git a/git-annex.cabal b/git-annex.cabal
index afbb47513..8db659fbf 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -73,7 +73,7 @@ Executable git-annex
CPP-Options: -DWITH_S3
if flag(WebDAV)
- Build-Depends: DAV
+ Build-Depends: DAV (>= 0.1)
CPP-Options: -DWITH_WebDAV
if flag(Assistant) && ! os(windows) && ! os(solaris)