diff options
| -rw-r--r-- | Assistant/NetMessager.hs | 1 | ||||
| -rw-r--r-- | Assistant/XMPP/Client.hs | 25 | ||||
| -rw-r--r-- | Creds.hs | 129 | ||||
| -rw-r--r-- | Locations.hs | 1 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Remote/Directory.hs | 101 | ||||
| -rw-r--r-- | Remote/Helper/Chunked.hs | 145 | ||||
| -rw-r--r-- | Remote/List.hs | 6 | ||||
| -rw-r--r-- | Remote/S3.hs | 111 | ||||
| -rw-r--r-- | Remote/WebDAV.hs | 320 | ||||
| -rw-r--r-- | Types/Remote.hs | 3 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | doc/design/assistant/progressbars.mdwn | 1 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 5 | ||||
| -rw-r--r-- | doc/install/fromscratch.mdwn | 1 | ||||
| -rw-r--r-- | doc/special_remotes/webdav.mdwn | 37 | ||||
| -rw-r--r-- | doc/tips/using_box.com_as_a_special_remote.mdwn | 15 | ||||
| -rw-r--r-- | git-annex.cabal | 7 |
18 files changed, 714 insertions, 197 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/Assistant/XMPP/Client.hs b/Assistant/XMPP/Client.hs index 8ab0c2857..c2a86cb41 100644 --- a/Assistant/XMPP/Client.hs +++ b/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" diff --git a/Creds.hs b/Creds.hs new file mode 100644 index 000000000..b907073f5 --- /dev/null +++ b/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 diff --git a/Locations.hs b/Locations.hs index 3a7c89ea7..6213385bd 100644 --- a/Locations.hs +++ b/Locations.hs @@ -11,6 +11,7 @@ module Locations ( keyPaths, gitAnnexLocation, annexLocations, + annexLocation, gitAnnexDir, gitAnnexObjectDir, gitAnnexTmpDir, @@ -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 diff --git a/Remote/Directory.hs b/Remote/Directory.hs index 006638a2f..794a8c468 100644 --- a/Remote/Directory.hs +++ b/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 - 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) + createDirectoryIfMissing True dir + allowWrite dir + preventWrite dir `after` storeChunks basedest chunksize storer recorder finalizer + finalizer f dest = do + renameFile f dest + preventWrite dest + 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 ([], []) diff --git a/Remote/Helper/Chunked.hs b/Remote/Helper/Chunked.hs new file mode 100644 index 000000000..dd6e3eb0d --- /dev/null +++ b/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 diff --git a/Remote/List.hs b/Remote/List.hs index ea1d61ce3..a25533bb1 100644 --- a/Remote/List.hs +++ b/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 ] diff --git a/Remote/S3.hs b/Remote/S3.hs index 0c9d523b8..f7dbf813c 100644 --- a/Remote/S3.hs +++ b/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 - warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey ++ " to use S3" - return Nothing +s3Connection c u = go =<< getRemoteCredPair c creds where + go Nothing = do + warning $ "Set both " ++ s3AccessKey ++ " and " ++ s3SecretKey ++ " to use S3" + return Nothing + 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) - -{- 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 +s3Creds :: UUID -> CredPairStorage +s3Creds u = CredPairStorage + { credPairFile = fromUUID u + , credPairEnvironment = ("AWS_ACCESS_KEY_ID", "AWS_SECRET_ACCESS_KEY") + , credPairRemoteKey = Just "s3creds" + } -{- 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 diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs new file mode 100644 index 000000000..b69d51f23 --- /dev/null +++ b/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" + } diff --git a/Types/Remote.hs b/Types/Remote.hs index d31d9a78f..572240de0 100644 --- a/Types/Remote.hs +++ b/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 { diff --git a/debian/control b/debian/control index a7ffe7f89..d3840463d 100644 --- a/debian/control +++ b/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), diff --git a/doc/design/assistant/progressbars.mdwn b/doc/design/assistant/progressbars.mdwn index 61e19ba1e..6228cb7f8 100644 --- a/doc/design/assistant/progressbars.mdwn +++ b/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 diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 842139c2b..474a6a09b 100644 --- a/doc/git-annex.mdwn +++ b/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. diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn index 000bc8451..49dd1302e 100644 --- a/doc/install/fromscratch.mdwn +++ b/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) diff --git a/doc/special_remotes/webdav.mdwn b/doc/special_remotes/webdav.mdwn new file mode 100644 index 000000000..8421dd5f4 --- /dev/null +++ b/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 diff --git a/doc/tips/using_box.com_as_a_special_remote.mdwn b/doc/tips/using_box.com_as_a_special_remote.mdwn index cafbc033c..6616d0a1e 100644 --- a/doc/tips/using_box.com_as_a_special_remote.mdwn +++ b/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 diff --git a/git-annex.cabal b/git-annex.cabal index e993343ca..c72a6c0bd 100644 --- a/git-annex.cabal +++ b/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 |