summaryrefslogtreecommitdiff
path: root/Remote
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-14 20:25:00 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-14 20:25:31 -0400
commitca0c3f90bffd314b04ce4f85c800acbba385bcf6 (patch)
treefa648018608d2bb0afa24d4539978f2d16c756d1 /Remote
parent50548a7496bd72dcdd5b582f88c9bcad3522f3f9 (diff)
skeltal webdav special remote
Doesn't actually store anything yet, but initremote works and tests the server.
Diffstat (limited to 'Remote')
-rw-r--r--Remote/List.hs6
-rw-r--r--Remote/WebDAV.hs157
2 files changed, 163 insertions, 0 deletions
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"
+ }