Merge branch 'webdav'

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

Assistant/WebApp/Configurators/S3.hs

@@ -116,7 +116,7 @@ getEnableS3R uuid = s3Configurator $ do
 makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
 makeS3Remote (S3Creds ak sk) name setup config = do
 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
-	liftIO $ S3.s3SetCredsEnv ( T.unpack ak, T.unpack sk)
+	liftIO $ S3.s3SetCredsEnv (T.unpack ak, T.unpack sk)
 	r <- liftAssistant $ liftAnnex $ addRemote $ do
 		makeSpecialRemote name S3.remote config
 		return remotename

Assistant/XMPP/Client.hs

@@ -8,8 +8,8 @@
 module Assistant.XMPP.Client where
 
 import Assistant.Common
-import Utility.FileMode
 import Utility.SRV
+import Creds
 
 import Network.Protocol.XMPP
 import Network
@@ -63,23 +63,12 @@ runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a
 runClientError s j u p x = either (error . show) return =<< runClient s j u p x
 
 getXMPPCreds :: Annex (Maybe XMPPCreds)
-getXMPPCreds = do
-	f <- xmppCredsFile
-	s <- liftIO $ catchMaybeIO $ readFile f
-	return $ readish =<< s
+getXMPPCreds = parse <$> readCacheCreds xmppCredsFile
+  where
+	parse s = readish =<< s
 
 setXMPPCreds :: XMPPCreds -> Annex ()
-setXMPPCreds creds = do
-	f <- xmppCredsFile
-	liftIO $ do
-		createDirectoryIfMissing True (parentDir f)
-		h <- openFile f WriteMode
-		modifyFileMode f $ removeModes
-			[groupReadMode, otherReadMode]
-		hPutStr h (show creds)
-		hClose h	
+setXMPPCreds creds = writeCacheCreds (show creds) xmppCredsFile
 
-xmppCredsFile :: Annex FilePath
-xmppCredsFile = do
-	dir <- fromRepo gitAnnexCredsDir
-	return $ dir </> "xmpp"
+xmppCredsFile :: FilePath
+xmppCredsFile = "xmpp"

Creds.hs

@@ -0,0 +1,129 @@
+{- Credentials storage
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Creds where
+
+import Common.Annex
+import Annex.Perms
+import Utility.FileMode
+import Crypto
+import Types.Remote (RemoteConfig, RemoteConfigKey)
+import Remote.Helper.Encryptable (remoteCipher, isTrustedCipher)
+
+import System.Environment
+import System.Posix.Env (setEnv)
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Map as M
+import Utility.Base64
+
+type Creds = String -- can be any data
+type CredPair = (String, String) -- login, password
+
+{- A CredPair can be stored in a file, or in the environment, or perhaps
+ - in a remote's configuration. -}
+data CredPairStorage = CredPairStorage
+	{ credPairFile :: FilePath
+	, credPairEnvironment :: (String, String)
+	, credPairRemoteKey :: Maybe RemoteConfigKey
+	}
+
+{- Stores creds in a remote's configuration, if the remote is encrypted
+ - with a GPG key. Otherwise, caches them locally. -}
+setRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex RemoteConfig
+setRemoteCredPair c storage = go =<< getRemoteCredPair c storage
+  where
+	go (Just creds) = do
+		mcipher <- remoteCipher c
+		case (mcipher, credPairRemoteKey storage) of
+			(Just cipher, Just key) | isTrustedCipher c -> do
+				s <- liftIO $ withEncryptedContent cipher
+					(return $ L.pack $ encodeCredPair creds)
+					(return . L.unpack)
+				return $ M.insert key (toB64 s) c
+			_ -> do
+				writeCacheCredPair creds storage
+				return c
+	go Nothing = return c
+
+{- Gets a remote's credpair, from the environment if set, otherwise
+ - from the cache in gitAnnexCredsDir, or failing that, from the encrypted
+ - value in RemoteConfig. -}
+getRemoteCredPair :: RemoteConfig -> CredPairStorage -> Annex (Maybe CredPair)
+getRemoteCredPair c storage = maybe fromcache (return . Just) =<< fromenv
+  where
+	fromenv = liftIO $ getEnvCredPair storage
+	fromcache = maybe fromconfig (return . Just) =<< readCacheCredPair storage
+	fromconfig = case credPairRemoteKey storage of
+		Just key -> do
+			mcipher <- remoteCipher c
+			case (M.lookup key c, mcipher) of
+				(Just enccreds, Just cipher) -> do
+					creds <- liftIO $ decrypt enccreds cipher
+					case decodeCredPair creds of
+						Just credpair -> do
+							writeCacheCredPair credpair storage 
+							return $ Just credpair
+						_ -> do error $ "bad " ++ key
+				_ -> return Nothing
+		Nothing -> return Nothing
+	decrypt enccreds cipher = withDecryptedContent cipher
+		(return $ L.pack $ fromB64 enccreds)
+		(return . L.unpack)
+
+{- Gets a CredPair from the environment. -}
+getEnvCredPair :: CredPairStorage -> IO (Maybe CredPair)
+getEnvCredPair storage = liftM2 (,)
+	<$> get uenv
+	<*> get penv
+  where
+	(uenv, penv) = credPairEnvironment storage
+	get = catchMaybeIO . getEnv
+
+{- Stores a CredPair in the environment. -}
+setEnvCredPair :: CredPair -> CredPairStorage -> IO ()
+setEnvCredPair (l, p) storage = do
+	set uenv l
+	set penv p
+  where
+	(uenv, penv) = credPairEnvironment storage
+	set var val = setEnv var val True
+
+writeCacheCredPair :: CredPair -> CredPairStorage -> Annex ()
+writeCacheCredPair credpair storage =
+	writeCacheCreds (encodeCredPair credpair) (credPairFile storage)
+
+{- Stores the creds in a file inside gitAnnexCredsDir that only the user
+ - can read. -}
+writeCacheCreds :: Creds -> FilePath -> Annex ()
+writeCacheCreds creds file = do
+	d <- fromRepo gitAnnexCredsDir
+	createAnnexDirectory d
+	liftIO $ do
+		let f = d </> file
+		h <- openFile f WriteMode
+		modifyFileMode f $ removeModes
+			[groupReadMode, otherReadMode]
+		hPutStr h creds
+		hClose h
+
+readCacheCredPair :: CredPairStorage -> Annex (Maybe CredPair)
+readCacheCredPair storage = maybe Nothing decodeCredPair
+	<$> readCacheCreds (credPairFile storage)
+
+readCacheCreds :: FilePath -> Annex (Maybe Creds)
+readCacheCreds file = do
+	d <- fromRepo gitAnnexCredsDir
+	let f = d </> file
+	liftIO $ catchMaybeIO $ readFile f
+
+encodeCredPair :: CredPair -> Creds
+encodeCredPair (l, p) = unlines [l, p]
+
+decodeCredPair :: Creds -> Maybe CredPair
+decodeCredPair creds = case lines creds of
+	l:p:[] -> Just (l, p)
+	_ -> Nothing

Locations.hs

@@ -11,6 +11,7 @@ module Locations (
 	keyPaths,
 	gitAnnexLocation,
 	annexLocations,
+	annexLocation,
 	gitAnnexDir,
 	gitAnnexObjectDir,
 	gitAnnexTmpDir,

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/Directory.hs

@@ -19,8 +19,8 @@ import Config
 import Utility.FileMode
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
+import Remote.Helper.Chunked
 import Crypto
-import Utility.DataUnits
 import Data.Int
 import Annex.Content
 
@@ -58,19 +58,6 @@ gen r u c = do
 			remotetype = remote
 		}
 
-type ChunkSize = Maybe Int64
-
-chunkSize :: Maybe RemoteConfig -> ChunkSize
-chunkSize Nothing = Nothing
-chunkSize (Just m) =
-	case M.lookup "chunksize" m of
-		Nothing -> Nothing
-		Just v -> case readSize dataUnits v of
-			Nothing -> error "bad chunksize"
-			Just size
-				| size <= 0 -> error "bad chunksize"
-				| otherwise -> Just $ fromInteger size
-
 directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
 directorySetup u c = do
 	-- verify configuration is sane
@@ -89,14 +76,6 @@ directorySetup u c = do
 locations :: FilePath -> Key -> [FilePath]
 locations d k = map (d </>) (keyPaths k)
 
-{- An infinite stream of chunks to use for a given file. -}
-chunkStream :: FilePath -> [FilePath]
-chunkStream f = map (\n -> f ++ ".chunk" ++ show n) [1 :: Integer ..]
-
-{- A file that records the number of chunks used. -}
-chunkCount :: FilePath -> FilePath
-chunkCount f = f ++ ".chunkcount"
-
 withCheckedFiles :: (FilePath -> IO Bool) -> ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
 withCheckedFiles _ _ [] _ _ = return False
 withCheckedFiles check Nothing d k a = go $ locations d k
@@ -107,18 +86,14 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
   where
 	go [] = return False
 	go (f:fs) = do
-		let chunkcount = chunkCount f
+		let chunkcount = f ++ chunkCount
 		ifM (check chunkcount)
 			( do
-				count <- readcount chunkcount
-				let chunks = take count $ chunkStream f
+				chunks <- listChunks f <$> readFile chunkcount
 				ifM (all id <$> mapM check chunks)
 					( a chunks , return False )
 			, go fs
 			)
-	readcount f = fromMaybe (error $ "cannot parse " ++ f)
-		. (readish :: String -> Maybe Int)
-		<$> readFile f
 
 withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
 withStoredFiles = withCheckedFiles doesFileExist
@@ -180,74 +155,32 @@ storeSplit' meterupdate chunksize (d:dests) bs c = do
 				feed (sz - s) ls h
 			else return (l:ls)
 
-{- Write a L.ByteString to a file, updating a progress meter
- - after each chunk of the L.ByteString, typically every 64 kb or so. -}
-meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
-meteredWriteFile meterupdate dest b =
-	meteredWriteFile' meterupdate dest (L.toChunks b) feeder
-  where
-	feeder chunks = return ([], chunks)
-
-{- Writes a series of S.ByteString chunks to a file, updating a progress
- - meter after each chunk. The feeder is called to get more chunks. -}
-meteredWriteFile' :: MeterUpdate -> FilePath -> s -> (s -> IO (s, [S.ByteString])) -> IO ()
-meteredWriteFile' meterupdate dest startstate feeder =
-	E.bracket (openFile dest WriteMode) hClose (feed startstate [])
-  where
-	feed state [] h = do
-		(state', cs) <- feeder state
-		unless (null cs) $
-			feed state' cs h
-	feed state (c:cs) h = do
-		S.hPut h c
-		meterupdate $ toInteger $ S.length c
-		feed state cs h
-
-{- Generates a list of destinations to write to in order to store a key.
- - When chunksize is specified, this list will be a list of chunks.
- - The action should store the file, and return a list of the destinations
- - it stored it to, or [] on error.
- - The stored files are only put into their final place once storage is
- - complete.
- -}
 storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool
-storeHelper d chunksize key a = prep <&&> check <&&> go
+storeHelper d chunksize key storer = check <&&> go
   where
-	desttemplate = Prelude.head $ locations d key
-	dir = parentDir desttemplate
-	tmpdests = case chunksize of
-		Nothing -> [desttemplate ++ tmpprefix]
-		Just _ -> map (++ tmpprefix) (chunkStream desttemplate)
-	tmpprefix = ".tmp"
-	detmpprefix f = take (length f - tmpprefixlen) f
-	tmpprefixlen = length tmpprefix
-	prep = liftIO $ catchBoolIO $ do
-		createDirectoryIfMissing True dir
-		allowWrite dir
-		return True
+	basedest = Prelude.head $ locations d key
+	dir = parentDir basedest
 	{- The size is not exactly known when encrypting the key;
 	 - this assumes that at least the size of the key is
 	 - needed as free space. -}
 	check = checkDiskSpace (Just dir) key 0
 	go = liftIO $ catchBoolIO $ do
-		stored <- a tmpdests
-		forM_ stored $ \f -> do
-			let dest = detmpprefix f
+		createDirectoryIfMissing True dir
+		allowWrite dir
+		preventWrite dir `after` storeChunks basedest chunksize storer recorder finalizer
+	finalizer f dest = do
 		renameFile f dest
 		preventWrite dest
-		when (chunksize /= Nothing) $ do
-			let chunkcount = chunkCount desttemplate
-			_ <- tryIO $ allowWrite chunkcount
-			writeFile chunkcount (show $ length stored)
-			preventWrite chunkcount
-		preventWrite dir
-		return (not $ null stored)
+	recorder f s = do
+		void $ tryIO $ allowWrite f
+		writeFile f s
+		preventWrite f
 
 retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool
 retrieve d chunksize k _ f = metered Nothing k $ \meterupdate ->
 	liftIO $ withStoredFiles chunksize d k $ \files ->
 		catchBoolIO $ do
-			meteredWriteFile' meterupdate f files feeder
+			meteredWriteFileChunks meterupdate f files feeder
 			return True
   where
 	feeder [] = return ([], [])

Remote/Helper/Chunked.hs

@@ -0,0 +1,145 @@
+{- git-annex chunked remotes
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Helper.Chunked where
+
+import Common.Annex
+import Utility.DataUnits
+import Types.Remote
+
+import qualified Data.Map as M
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString as S
+import Data.Int
+import qualified Control.Exception as E
+
+type ChunkSize = Maybe Int64
+
+{- Gets a remote's configured chunk size. -}
+chunkSize :: Maybe RemoteConfig -> ChunkSize
+chunkSize Nothing = Nothing
+chunkSize (Just m) =
+	case M.lookup "chunksize" m of
+		Nothing -> Nothing
+		Just v -> case readSize dataUnits v of
+			Nothing -> error "bad chunksize"
+			Just size
+				| size <= 0 -> error "bad chunksize"
+				| otherwise -> Just $ fromInteger size
+
+{- This is an extension that's added to the usual file (or whatever)
+ - where the remote stores a key. -}
+type ChunkExt = String
+
+{- A record of the number of chunks used.
+ -
+ - While this can be guessed at based on the size of the key, encryption
+ - makes that larger. Also, using this helps deal with changes to chunksize
+ - over the life of a remote.
+ -}
+chunkCount :: ChunkExt
+chunkCount = ".chunkcount"
+
+{- Parses the String from the chunkCount file, and returns the files that
+ - are used to store the chunks. -}
+listChunks :: FilePath -> String -> [FilePath]
+listChunks basedest chunkcount = take count $ map (basedest ++) chunkStream
+  where
+	count = fromMaybe 0 $ readish chunkcount
+
+{- An infinite stream of extensions to use for chunks. -}
+chunkStream :: [ChunkExt]
+chunkStream = map (\n -> ".chunk" ++ show n) [1 :: Integer ..]
+
+{- Given the base destination to use to store a value,
+ - generates a stream of temporary destinations (just one when not chunking)
+ - and passes it to an action, which should chunk and store the data,
+ - and return the destinations it stored to, or [] on error.
+ -
+ - Then calles the finalizer to rename the temporary destinations into
+ - their final places (and do any other cleanup), and writes the chunk count
+ - (if chunking)
+ -}
+storeChunks :: FilePath -> ChunkSize -> ([FilePath] -> IO [FilePath]) -> (FilePath -> String -> IO ()) -> (FilePath -> FilePath -> IO ()) -> IO Bool
+storeChunks basedest chunksize storer recorder finalizer =
+	either (const $ return False) return
+		=<< (E.try go :: IO (Either E.SomeException Bool))
+  where
+	go = do
+		stored <- storer tmpdests
+		forM_ stored $ \d -> do
+			let dest = detmpprefix d
+			finalizer d dest
+		when (chunksize /= Nothing) $ do
+			let chunkcount = basedest ++ chunkCount
+			recorder chunkcount (show $ length stored)
+		return (not $ null stored)
+
+	tmpprefix = ".tmp"
+	detmpprefix f = take (length f - tmpprefixlen) f
+	tmpprefixlen = length tmpprefix
+	tmpdests
+		| chunksize == Nothing = [basedest ++ tmpprefix]
+		| otherwise = map (++ tmpprefix) $ map (basedest ++) chunkStream
+
+{- Given a list of destinations to use, chunks the data according to the
+ - ChunkSize, and runs the storer action to store each chunk. Returns
+ - the destinations where data was stored, or [] on error.
+ -
+ - This buffers each chunk in memory.
+ - More optimal versions of this can be written, that rely
+ - on L.toChunks to split the lazy bytestring into chunks (typically
+ - smaller than the ChunkSize), and eg, write those chunks to a Handle.
+ - But this is the best that can be done with the storer interface that
+ - writes a whole L.ByteString at a time.
+ -}
+storeChunked :: ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath]
+storeChunked chunksize dests storer content =
+	either (const $ return []) return
+		=<< (E.try (go chunksize dests) :: IO (Either E.SomeException [FilePath]))
+  where
+	go _ [] = return [] -- no dests!?
+
+	go Nothing (d:_) = do
+		storer d content
+		return [d]
+
+	go (Just sz) _
+		-- always write a chunk, even if the data is 0 bytes
+		| L.null content = go Nothing dests
+		| otherwise = storechunks sz [] dests content
+		
+	storechunks _ _ [] _ = return [] -- ran out of dests
+	storechunks sz useddests (d:ds) b
+		| L.null b = return $ reverse useddests
+		| otherwise = do
+			let (chunk, b') = L.splitAt sz b
+			storer d chunk
+			storechunks sz (d:useddests) ds b'
+
+{- Write a L.ByteString to a file, updating a progress meter
+ - after each chunk of the L.ByteString, typically every 64 kb or so. -}
+meteredWriteFile :: MeterUpdate -> FilePath -> L.ByteString -> IO ()
+meteredWriteFile meterupdate dest b =
+	meteredWriteFileChunks meterupdate dest (L.toChunks b) feeder
+  where
+	feeder chunks = return ([], chunks)
+
+{- Writes a series of S.ByteString chunks to a file, updating a progress
+ - meter after each chunk. The feeder is called to get more chunks. -}
+meteredWriteFileChunks :: MeterUpdate -> FilePath -> s -> (s -> IO (s, [S.ByteString])) -> IO ()
+meteredWriteFileChunks meterupdate dest startstate feeder =
+	E.bracket (openFile dest WriteMode) hClose (feed startstate [])
+  where
+	feed state [] h = do
+		(state', cs) <- feeder state
+		unless (null cs) $
+			feed state' cs h
+	feed state (c:cs) h = do
+		S.hPut h c
+		meterupdate $ toInteger $ S.length c
+		feed state cs h

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/S3.hs

@@ -14,8 +14,6 @@ import Network.AWS.AWSResult
 import qualified Data.ByteString.Lazy.Char8 as L
 import qualified Data.Map as M
 import Data.Char
-import System.Environment
-import System.Posix.Env (setEnv)
 
 import Common.Annex
 import Types.Remote
@@ -25,10 +23,8 @@ import Config
 import Remote.Helper.Special
 import Remote.Helper.Encryptable
 import Crypto
+import Creds
 import Annex.Content
-import Utility.Base64
-import Annex.Perms
-import Utility.FileMode
 
 remote :: RemoteType
 remote = RemoteType {
@@ -87,7 +83,7 @@ s3Setup u c = handlehost $ M.lookup "host" c
 
 	use fullconfig = do
 		gitConfigSpecialRemote u fullconfig "s3" "true"
-		s3SetCreds fullconfig u
+		setRemoteCredPair fullconfig (s3Creds u)
 
 	defaulthost = do
 		c' <- encryptionSetup c
@@ -116,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
@@ -126,7 +122,7 @@ storeEncrypted r (cipher, enck) k _p = s3Action r False $ \(conn, bucket) ->
 	-- (An alternative would be chunking to to a constant size.)
 	withTmp enck $ \tmp -> do
 		f <- inRepo $ gitAnnexLocation k
-		liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
+		liftIO $ withEncryptedContent cipher (L.readFile f) $ L.writeFile tmp
 		res <- liftIO $ storeHelper (conn, bucket) r enck tmp
 		s3Bool res
 
@@ -257,93 +253,28 @@ s3ConnectionRequired c u =
 	maybe (error "Cannot connect to S3") return =<< s3Connection c u
 
 s3Connection :: RemoteConfig -> UUID -> Annex (Maybe AWSConnection)
-s3Connection c u = do
-	creds <- s3GetCreds c u
-	case creds of
-		Just (ak, sk) -> return $ Just $ AWSConnection host port ak sk
-		_ -> do
+s3Connection c u = go =<< getRemoteCredPair c creds
+  where
+	go Nothing = do
 		warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey  ++ " to use S3"
 		return Nothing
-  where
+	go (Just (ak, sk)) = return $ Just $ AWSConnection host port ak sk
+
+	creds = s3Creds u
+	(s3AccessKey, s3SecretKey) = credPairEnvironment creds
+
 	host = fromJust $ M.lookup "host" c
 	port = let s = fromJust $ M.lookup "port" c in
 		case reads s of
 		[(p, _)] -> p
 		_ -> error $ "bad S3 port value: " ++ s
 
-{- S3 creds come from the environment if set, otherwise from the cache
- - in gitAnnexCredsDir, or failing that, might be stored encrypted in
- - the remote's config. -}
-s3GetCreds :: RemoteConfig -> UUID -> Annex (Maybe (String, String))
-s3GetCreds c u = maybe fromcache (return . Just) =<< liftIO getenv
-  where
-	getenv = liftM2 (,)
-		<$> get s3AccessKey
-		<*> get s3SecretKey
-	  where
-		get = catchMaybeIO . getEnv
-	fromcache = do
-		d <- fromRepo gitAnnexCredsDir
-		let f = d </> fromUUID u
-		v <- liftIO $ catchMaybeIO $ readFile f
-		case lines <$> v of
-			Just (ak:sk:[]) -> return $ Just (ak, sk)
-			_ -> fromconfig
-	fromconfig = do
-		mcipher <- remoteCipher c
-		case (M.lookup "s3creds" c, mcipher) of
-			(Just s3creds, Just cipher) -> do
-				creds <- liftIO $ decrypt s3creds cipher
-				case creds of
-					[ak, sk] -> do
-						s3CacheCreds (ak, sk) u
-						return $ Just (ak, sk)
-					_ -> do error "bad s3creds"		
-			_ -> return Nothing
-	decrypt s3creds cipher = lines 
-		<$> withDecryptedContent cipher
-			(return $ L.pack $ fromB64 s3creds)
-			(return . L.unpack)
+s3Creds :: UUID -> CredPairStorage
+s3Creds u = CredPairStorage
+	{ credPairFile = fromUUID u
+	, credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY")
+	, credPairRemoteKey = Just "s3creds"
+	}
 
-{- Stores S3 creds encrypted in the remote's config if possible to do so
- - securely, and otherwise locally in gitAnnexCredsDir. -}
-s3SetCreds :: RemoteConfig -> UUID -> Annex RemoteConfig
-s3SetCreds c u = do
-	creds <- s3GetCreds c u
-	case creds of
-		Just (ak, sk) -> do
-			mcipher <- remoteCipher c
-			case mcipher of
-				Just cipher | isTrustedCipher c -> do
-					s <- liftIO $ withEncryptedContent cipher
-						(return $ L.pack $ unlines [ak, sk])
-						(return . L.unpack)
-					return $ M.insert "s3creds" (toB64 s) c
-				_ -> do
-					s3CacheCreds (ak, sk) u
-					return c
-		_ -> return c
-
-{- The S3 creds are cached in gitAnnexCredsDir. -}
-s3CacheCreds :: (String, String) -> UUID -> Annex ()
-s3CacheCreds (ak, sk) u = do
-	d <- fromRepo gitAnnexCredsDir
-	createAnnexDirectory d
-	liftIO $ do
-		let f = d </> fromUUID u
-		h <- openFile f WriteMode
-		modifyFileMode f $ removeModes
-			[groupReadMode, otherReadMode]
-		hPutStr h $ unlines [ak, sk]
-		hClose h
-
-{- Sets the S3 creds in the environment. -}
 s3SetCredsEnv :: (String, String) -> IO ()
-s3SetCredsEnv (ak, sk) = do
-	setEnv s3AccessKey ak True
-	setEnv s3SecretKey sk True
-
-s3AccessKey :: String
-s3AccessKey = "AWS_ACCESS_KEY_ID"
-s3SecretKey :: String
-s3SecretKey = "AWS_SECRET_ACCESS_KEY"
+s3SetCredsEnv creds = setEnvCredPair creds $ s3Creds undefined

Remote/WebDAV.hs

@@ -0,0 +1,320 @@
+{- WebDAV remotes.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Remote.WebDAV (remote) 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 qualified Data.Text as T
+import qualified Text.XML as XML
+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 Remote.Helper.Special
+import Remote.Helper.Encryptable
+import Remote.Helper.Chunked
+import Crypto
+import Creds
+
+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 -> 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 $ \(baseurl, user, pass) -> do
+	let url = davLocation baseurl k
+	f <- inRepo $ gitAnnexLocation k
+	liftIO $ storeHelper r url user pass =<< L.readFile f
+
+storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
+storeEncrypted r (cipher, enck) k _p = davAction r False $ \(baseurl, user, pass) -> do
+	let url = davLocation baseurl enck
+	f <- inRepo $ gitAnnexLocation k
+	liftIO $ withEncryptedContent cipher (L.readFile f) $
+		storeHelper r url user pass
+
+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))
+
+retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool
+retrieveCheap _ _ _ = return False
+
+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve r k _f d = metered Nothing k $ \meterupdate ->
+	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
+		withStoredFiles r k baseurl user pass onerr $ \urls -> do
+			meteredWriteFileChunks meterupdate d urls $
+				feeder user pass
+			return True
+  where
+	onerr _ = return False
+
+	feeder _ _ [] = return ([], [])
+	feeder user pass (url:urls) = do
+		mb <- davGetUrlContent url user pass
+		case mb of
+			Nothing -> throwDownloadFailed
+			Just b -> return (urls, L.toChunks b)
+
+throwDownloadFailed :: IO a
+throwDownloadFailed = ioError $ mkIOError userErrorType "download failed" Nothing Nothing
+
+retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
+retrieveEncrypted r (cipher, enck) k d = metered Nothing k $ \meterupdate ->
+	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
+		withStoredFiles r enck baseurl user pass onerr $ \urls -> do
+			withDecryptedContent cipher (L.concat <$> feeder user pass urls []) $
+				meteredWriteFile meterupdate d
+			return True
+  where
+	onerr _ = return False
+
+	feeder _ _ [] c = return $ reverse c
+	feeder user pass (url:urls) c = do
+		mb <- davGetUrlContent url user pass
+		case mb of
+			Nothing -> throwDownloadFailed
+			Just b -> feeder user pass urls (b:c)
+
+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 = urlParent $ 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 = url ++ chunkCount
+		maybe (onerr chunkcount) (a . listChunks url . L8.toString)
+			=<< davGetUrlContent chunkcount user pass
+	| otherwise = a [url]
+  where
+	url = davLocation baseurl k
+
+davAction :: Remote -> a -> ((DavUrl, DavUser, DavPass) -> Annex a) -> Annex a
+davAction r unconfigured action = case config r of
+	Nothing -> return unconfigured
+	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
+
+toDavPass :: String -> DavPass
+toDavPass = B8.fromString
+
+{- The location to use to store a Key. -}
+davLocation :: DavUrl -> Key -> DavUrl
+davLocation baseurl k = davUrl baseurl $ annexLocation k hashDirLower
+
+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
+	decode (Left (Left (StatusCodeException status _)))
+		| statusCode status == statusCode notFound404 = Right False
+		| otherwise = Left $ show $ statusMessage status
+	decode (Left (Left httpexception)) = Left $ show httpexception
+	decode (Left (Right ioexception)) = Left $ show ioexception
+
+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 (Either HttpException E.IOException) a)
+catchHttp a = (Right <$> a) `E.catches`
+	[ E.Handler $ \(e :: HttpException) -> return $ Left $ Left e
+	, E.Handler $ \(e :: E.IOException) -> return $ Left $ Right e
+	]
+
+urlParent :: DavUrl -> DavUrl
+urlParent url = reverse $ dropWhile (== '/') $ reverse $
+	normalizePathSegments (url ++ "/..")
+
+{- 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 (Just (u, p)) = do
+	showSideAction "testing WebDAV server"
+	liftIO $ do
+		davMkdir baseurl user pass
+		putContentAndProps testurl user pass
+			(noProps, (contentType, L.empty))
+		deleteContent testurl user pass
+  where
+	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"
+
+{- The DAV library requires that properties be specified when storing a file.
+ - 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
+  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"
+        }

Types/Remote.hs

@@ -16,7 +16,8 @@ import qualified Git
 import Types.Key
 import Types.UUID
 
-type RemoteConfig = M.Map String String
+type RemoteConfigKey = String
+type RemoteConfig = M.Map RemoteConfigKey String
 
 {- There are different types of remotes. -}
 data RemoteTypeA a = RemoteType {

debian/control

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

doc/design/assistant/progressbars.mdwn

@@ -23,6 +23,7 @@ the MeterUpdate callback as the upload progresses.
 * rsync: **done**
 * directory: **done**
 * web: Not applicable; does not upload 
+* webdav: TODO
 * S3: TODO
 * bup: TODO
 * hook: Would require the hook interface to somehow do this, which seems

doc/git-annex.mdwn

@@ -885,6 +885,11 @@ Here are all the supported configuration settings.
   Used to identify Amazon S3 special remotes.
   Normally this is automaticaly set up by `git annex initremote`.
 
+* `remote.<name>.webdav`
+
+  Used to identify webdav special remotes.
+  Normally this is automaticaly set up by `git annex initremote`.
+
 * `remote.<name>.annex-xmppaddress`
 
   Used to identify the XMPP address of a Jabber buddy.

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,37 @@
+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 can be a subdirectory of a larger WebDAV repository, and will
+  be created as needed. 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=75 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/git-annex chunksize=75mb encryption=joey@kitenet.net

doc/tips/using_box.com_as_a_special_remote.mdwn

@@ -2,8 +2,19 @@
 for providing 50 gb of free storage if you sign up with its Android client.
 (Or a few gb free otherwise.)
 
-With a little setup, git-annex can use Box as a
-[[special remote|special_remotes]]. 
+git-annex can use Box as a [[special remote|special_remotes]].
+Recent versions of git-annex make this very easy to set up:
+
+	WEBDAV_USERNAME=you@example.com WEBDAV_PASSWORD=xxxxxxx git annex initremote box.com type=webdav url=https://www.box.com/dav/git-annex chunksize=75mb encryption=you@example.com
+
+Note the use of chunksize; Box has a 100 mb maximum file size, and this
+breaks up large files into chunks before that limit is reached.
+
+# old davfs2 method
+
+This method is deprecated, but still documented here just in case.
+Note that the files stored using this method cannot reliably be retreived
+using the webdav special remote.
 
 ## davfs2 setup
 

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 (>= 0.2), http-conduit
+    CPP-Options: -DWITH_WebDAV
+
   if flag(Assistant) && ! os(windows) && ! os(solaris)
     Build-Depends: stm >= 2.3
     CPP-Options: -DWITH_ASSISTANT