diff options
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Remote/List.hs | 6 | ||||
| -rw-r--r-- | Remote/WebDAV.hs | 157 | ||||
| -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 |
7 files changed, 209 insertions, 1 deletions
@@ -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/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/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 |