diff options
| -rw-r--r-- | Assistant/XMPP/Client.hs | 25 | ||||
| -rw-r--r-- | Creds.hs | 129 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Remote/List.hs | 6 | ||||
| -rw-r--r-- | Remote/S3.hs | 105 | ||||
| -rw-r--r-- | Remote/WebDAV.hs | 157 | ||||
| -rw-r--r-- | Types/Remote.hs | 3 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | doc/install/fromscratch.mdwn | 1 | ||||
| -rw-r--r-- | doc/special_remotes/webdav.mdwn | 36 | ||||
| -rw-r--r-- | git-annex.cabal | 7 |
11 files changed, 365 insertions, 107 deletions
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 @@ -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/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..b05de6ad4 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 @@ -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..e11011351 --- /dev/null +++ b/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" + } 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..a80dca3cb 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, libghc-testpack-dev, libghc-quickcheck2-dev, libghc-monad-control-dev (>= 0.3), 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..5cc5c55d9 --- /dev/null +++ b/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 diff --git a/git-annex.cabal b/git-annex.cabal index e993343ca..afbb47513 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 + CPP-Options: -DWITH_WebDAV + if flag(Assistant) && ! os(windows) && ! os(solaris) Build-Depends: stm >= 2.3 CPP-Options: -DWITH_ASSISTANT |