1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
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"
}
|
