skeltal webdav special remote

Doesn't actually store anything yet, but initremote works and tests the
server.

Makefile

@@ -7,7 +7,7 @@ BASEFLAGS=-Wall -outputdir $(GIT_ANNEX_TMP_BUILD_DIR) -IUtility
 #
 # If you're using an old version of yesod, enable -DWITH_OLD_YESOD
 # Or with an old version of the uri library, enable -DWITH_OLD_URI
-FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP -DWITH_DNS
+FEATURES?=$(GIT_ANNEX_LOCAL_FEATURES) -DWITH_ASSISTANT -DWITH_S3 -DWITH_WEBDAV -DWITH_WEBAPP -DWITH_PAIRING -DWITH_XMPP -DWITH_DNS
 
 bins=git-annex
 mans=git-annex.1 git-annex-shell.1

Remote/List.hs

@@ -29,6 +29,9 @@ import qualified Remote.Bup
 import qualified Remote.Directory
 import qualified Remote.Rsync
 import qualified Remote.Web
+#ifdef WITH_WEBDAV
+import qualified Remote.WebDAV
+#endif
 import qualified Remote.Hook
 
 remoteTypes :: [RemoteType]
@@ -41,6 +44,9 @@ remoteTypes =
 	, Remote.Directory.remote
 	, Remote.Rsync.remote
 	, Remote.Web.remote
+#ifdef WITH_WEBDAV
+	, Remote.WebDAV.remote
+#endif
 	, Remote.Hook.remote
 	]
 

Remote/WebDAV.hs

@@ -0,0 +1,157 @@
+{- WebDAV remotes.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+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.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Text.XML as XML
+import Data.Default
+
+import Common.Annex
+import Types.Remote
+import qualified Git
+import Config
+import Remote.Helper.Special
+import Remote.Helper.Encryptable
+import Crypto
+import Creds
+import Annex.Content
+
+remote :: RemoteType
+remote = RemoteType {
+	typename = "webdav",
+	enumerate = findSpecialRemotes "webdav",
+	generate = gen,
+	setup = webdavSetup
+}
+
+gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex Remote
+gen r u c = do
+	cst <- remoteCost r expensiveRemoteCost
+	return $ gen' r u c cst
+gen' :: Git.Repo -> UUID -> Maybe RemoteConfig -> Int -> Remote
+gen' r u c 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,
+		localpath = Nothing,
+		readonly = False,
+		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 = davAction r False $ \creds -> do
+	error "TODO"
+
+storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
+storeEncrypted r (cipher, enck) k _p = davAction r False $ \creds -> do
+	error "TODO"
+
+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve r k _f d = davAction r False $ \creds -> do
+	error "TODO"
+
+retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
+
+retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
+retrieveEncrypted r (cipher, enck) _ f = davAction r False $ \creds -> do
+	error "TODO"
+
+remove :: Remote -> Key -> Annex Bool
+remove r k = davAction r False $ \creds -> do
+	error "TODO"
+
+checkPresent :: Remote -> Key -> Annex (Either String Bool)
+checkPresent r k = davAction r noconn $ \creds -> do
+	showAction $ "checking " ++ name r
+	error "TODO"
+  where
+	noconn = Left $ error $ name r ++ " not configured"
+
+davAction :: Remote -> a -> (CredPair -> 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)
+
+davUrl :: String -> FilePath -> String
+davUrl baseurl file = baseurl </> 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. -}
+testDav :: String -> Maybe CredPair -> Annex ()
+testDav baseurl Nothing = error "Need to configure webdav username and password."
+testDav baseurl (Just (u, p)) = do
+	showSideAction "testing WebDAV server"
+	liftIO $ do
+		putContentAndProps testurl username password
+			(dummyProps, (contentType, L.empty))
+		-- TODO delete testurl
+  where
+	username = B8.pack u
+	password = B8.pack 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"
+
+{- 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>"
+
+getCreds :: RemoteConfig -> UUID -> Annex (Maybe CredPair)
+getCreds c u = maybe missing (return . Just) =<< getRemoteCredPair c creds
+  where
+	creds = davCreds u
+	(loginvar, passwordvar) = credPairEnvironment creds
+	missing = do
+		warning $ "Set both " ++ loginvar ++ " and " ++ passwordvar ++ " to use webdav"
+		return Nothing
+
+davCreds :: UUID -> CredPairStorage
+davCreds u = CredPairStorage
+        { credPairFile = fromUUID u
+        , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
+        , credPairRemoteKey = Just "davcreds"
+        }

debian/control

@@ -12,6 +12,7 @@ Build-Depends:
 	libghc-http-dev,
 	libghc-utf8-string-dev,
 	libghc-hs3-dev (>= 0.5.6),
+	libghc-dav-dev,
 	libghc-testpack-dev,
 	libghc-quickcheck2-dev,
 	libghc-monad-control-dev (>= 0.3),

doc/install/fromscratch.mdwn

@@ -18,6 +18,7 @@ quite a lot.
   * [bloomfilter](http://hackage.haskell.org/package/bloomfilter)
   * [edit-distance](http://hackage.haskell.org/package/edit-distance)
   * [hS3](http://hackage.haskell.org/package/hS3) (optional)
+  * [DAV](http://hackage.haskell.org/package/DAV) (optional)
   * [SafeSemaphore](http://hackage.haskell.org/package/SafeSemaphore)
 * Optional haskell stuff, used by the [[assistant]] and its webapp (edit Makefile to disable)
   * [stm](http://hackage.haskell.org/package/stm)

doc/special_remotes/webdav.mdwn

@@ -0,0 +1,36 @@
+This special remote type stores file contents in a WebDAV server.
+
+## configuration
+
+The environment variables `WEBDAV_USERNAME` and `WEBDAV_PASSWORD` are used
+to supply login credentials. When encryption is enabled, they are stored in
+encrypted form by `git annex initremote`. Without encryption, they are
+stored in a file only you can read inside the local git repository. So you
+do not need to keep the environment variables set after the initial
+initalization of the remote.
+
+A number of parameters can be passed to `git annex initremote` to configure
+the webdav remote.
+
+* `encryption` - Required. Either "none" to disable encryption
+  (not recommended),
+  or a value that can be looked up (using gpg -k) to find a gpg encryption
+  key that will be given access to the remote. Note that additional gpg
+  keys can be given access to a remote by rerunning initremote with
+  the new key id. See [[encryption]].
+
+* `url` - Required. The URL to the WebDAV directory where files will be
+  stored. This directory must already exist. Use of a https URL is strongly
+  encouraged, since HTTP basic authentication is used.
+
+* `chunksize` - Avoid storing files larger than the specified size in
+  WebDAV. For use when the WebDAV server has file size
+  limitations. The default is to never chunk files.  
+  The value can use specified using any commonly used units.
+  Example: `chunksize=100 megabytes`  
+  Note that enabling chunking on an existing remote with non-chunked
+  files is not recommended.
+
+Setup example:
+
+	# WEBDAV_USERNAME=joey@kitenet.net WEBDAV_PASSWORD=xxxxxxx git annex initremote box.com type=webdav url=https://www.box.com/dav/ encryption=joey@kitenet.net

git-annex.cabal

@@ -28,6 +28,9 @@ Description:
 Flag S3
   Description: Enable S3 support
 
+Flag WebDAV
+  Description: Enable WebDAV support
+
 Flag Inotify
   Description: Enable inotify support
 
@@ -69,6 +72,10 @@ Executable git-annex
     Build-Depends: hS3
     CPP-Options: -DWITH_S3
 
+  if flag(WebDAV)
+    Build-Depends: DAV
+    CPP-Options: -DWITH_WebDAV
+
   if flag(Assistant) && ! os(windows) && ! os(solaris)
     Build-Depends: stm >= 2.3
     CPP-Options: -DWITH_ASSISTANT