summaryrefslogtreecommitdiff
path: root/Remote/WebDAV.hs
blob: 14947f1e9b4fc5eb98cb434f85a33f280e6acb73 (plain)
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
{- WebDAV remotes.
 -
 - Copyright 2012-2014 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Remote.WebDAV (remote, davCreds, configUrl) where

import Network.Protocol.HTTP.DAV
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as B8
import qualified Data.ByteString.Lazy.UTF8 as L8
import Network.HTTP.Client (HttpException(..))
import Network.HTTP.Types
import System.IO.Error
import Control.Monad.Catch

import Annex.Common
import Types.Remote
import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.Http
import qualified Remote.Helper.Chunked.Legacy as Legacy
import Creds
import Utility.Metered
import Utility.Url (URLString, matchStatusCodeException)
import Annex.UUID
import Remote.WebDAV.DavLocation

#if MIN_VERSION_http_client(0,5,0)
import Network.HTTP.Client (HttpExceptionContent(..), responseStatus)
#endif

remote :: RemoteType
remote = RemoteType {
	typename = "webdav",
	enumerate = const (findSpecialRemotes "webdav"),
	generate = gen,
	setup = webdavSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
  where
	new cst = Just $ specialRemote c
		(prepareDAV this $ store chunkconfig)
		(prepareDAV this $ retrieve chunkconfig)
		(prepareDAV this $ remove)
		(prepareDAV this $ checkKey this chunkconfig)
		this
	  where
		this = Remote
			{ uuid = u
			, cost = cst
			, name = Git.repoDescribe r
			, storeKey = storeKeyDummy
			, retrieveKeyFile = retreiveKeyFileDummy
			, retrieveKeyFileCheap = retrieveCheap
			, removeKey = removeKeyDummy
			, lockContent = Nothing
			, checkPresent = checkPresentDummy
			, checkPresentCheap = False
			, whereisKey = Nothing
			, remoteFsck = Nothing
			, repairRepo = Nothing
			, config = c
			, repo = r
			, gitconfig = gc
			, localpath = Nothing
			, readonly = False
			, availability = GloballyAvailable
			, remotetype = remote
			, mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
			, getInfo = includeCredsInfo c (davCreds u) $
				[("url", fromMaybe "unknown" (M.lookup "url" c))]
			, claimUrl = Nothing
			, checkUrl = Nothing
			}
		chunkconfig = getChunkConfig c

webdavSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
webdavSetup mu mcreds c gc = do
	u <- maybe (liftIO genUUID) return mu
	url <- case M.lookup "url" c of
		Nothing -> giveup "Specify url="
		Just url -> return url
	(c', encsetup) <- encryptionSetup c gc
	creds <- maybe (getCreds c' gc u) (return . Just) mcreds
	testDav url creds
	gitConfigSpecialRemote u c' "webdav" "true"
	c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds
	return (c'', u)

-- Opens a http connection to the DAV server, which will be reused
-- each time the helper is called.
prepareDAV :: Remote -> (Maybe DavHandle -> helper) -> Preparer helper
prepareDAV = resourcePrepare . const . withDAVHandle

store :: ChunkConfig -> Maybe DavHandle -> Storer
store _ Nothing = byteStorer $ \_k _b _p -> return False
store (LegacyChunks chunksize) (Just dav) = fileStorer $ \k f p -> liftIO $
	withMeteredFile f p $ storeLegacyChunked chunksize k dav
store _  (Just dav) = httpStorer $ \k reqbody -> liftIO $ goDAV dav $ do
	let tmp = keyTmpLocation k
	let dest = keyLocation k
	void $ mkColRecursive tmpDir
	inLocation tmp $
		putContentM' (contentType, reqbody)
	finalizeStore (baseURL dav) tmp dest
	return True

finalizeStore :: URLString -> DavLocation -> DavLocation -> DAVT IO ()
finalizeStore baseurl tmp dest = do
	inLocation dest $ void $ safely $ delContentM
	maybe noop (void . mkColRecursive) (locationParent dest)
	moveDAV baseurl tmp dest

retrieveCheap :: Key -> AssociatedFile -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False

retrieve :: ChunkConfig -> Maybe DavHandle -> Retriever
retrieve _ Nothing = giveup "unable to connect"
retrieve (LegacyChunks _) (Just dav) = retrieveLegacyChunked dav
retrieve _ (Just dav) = fileRetriever $ \d k p -> liftIO $
	goDAV dav $
		inLocation (keyLocation k) $
			withContentM $
				httpBodyRetriever d p

remove :: Maybe DavHandle -> Remover
remove Nothing _ = return False
remove (Just dav) k = liftIO $ do
	-- Delete the key's whole directory, including any
	-- legacy chunked files, etc, in a single action.
	let d = keyDir k
	goDAV dav $ do
		v <- safely $ inLocation d delContentM
		case v of
			Just _ -> return True
			Nothing -> do
				v' <- existsDAV d
				case v' of
					Right False -> return True
					_ -> return False

checkKey :: Remote -> ChunkConfig -> Maybe DavHandle -> CheckPresent
checkKey r _ Nothing _ = giveup $ name r ++ " not configured"
checkKey r chunkconfig (Just dav) k = do
	showChecking r
	case chunkconfig of
		LegacyChunks _ -> checkKeyLegacyChunked dav k
		_ -> do
			v <- liftIO $ goDAV dav $
				existsDAV (keyLocation k)
			either giveup return v

configUrl :: Remote -> Maybe URLString
configUrl r = fixup <$> M.lookup "url" (config r)
  where
	-- box.com DAV url changed
	fixup = replace "https://www.box.com/dav/" "https://dav.box.com/dav/"

type DavUser = B8.ByteString
type DavPass = B8.ByteString

baseURL :: DavHandle -> URLString
baseURL (DavHandle _ _ _ u) = u


toDavUser :: String -> DavUser
toDavUser = B8.fromString

toDavPass :: String -> DavPass
toDavPass = B8.fromString

{- Test if a WebDAV store is usable, by writing to a test file, and then
 - deleting the file.
 -
 - Also ensures that the path of the url exists, trying to create it if not.
 -
 - Throws an error if store is not usable.
 -}
testDav :: URLString -> Maybe CredPair -> Annex ()
testDav url (Just (u, p)) = do
	showAction "testing WebDAV server"
	test $ liftIO $ evalDAVT url $ do
		prepDAV user pass
		makeParentDirs
		void $ mkColRecursive tmpDir
		inLocation (tmpLocation "git-annex-test") $ do
			putContentM (Nothing, L8.fromString "test")
			delContentM
  where
	test a = liftIO $
		either (\e -> throwIO $ "WebDAV test failed: " ++ show e)
			(const noop)
			=<< tryNonAsync a

	user = toDavUser u
	pass = toDavPass p
testDav _ Nothing = error "Need to configure webdav username and password."

{- Tries to make all the parent directories in the WebDAV urls's path,
 - right down to the root.
 -
 - Ignores any failures, which can occur for reasons including the WebDAV
 - server only serving up WebDAV in a subdirectory. -}
makeParentDirs :: DAVT IO ()
makeParentDirs = go
  where
	go = do
		l <- getDAVLocation
		case locationParent l of
			Nothing -> noop
			Just p -> void $ safely $ inDAVLocation (const p) go
		void $ safely mkCol

{- Checks if the directory exists. If not, tries to create its
 - parent directories, all the way down to the root, and finally creates
 - it. -}
mkColRecursive :: DavLocation -> DAVT IO Bool
mkColRecursive d = go =<< existsDAV d
  where
	go (Right True) = return True
	go _ = ifM (inLocation d mkCol)
		( return True
		, do
			case locationParent d of
				Nothing -> makeParentDirs
				Just parent -> void (mkColRecursive parent)
			inLocation d mkCol
		)

getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)

davCreds :: UUID -> CredPairStorage
davCreds u = CredPairStorage
	{ credPairFile = fromUUID u
	, credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
	, credPairRemoteKey = Just "davcreds"
	}

{- Content-Type to use for files uploaded to WebDAV. -}
contentType :: Maybe B8.ByteString
contentType = Just $ B8.fromString "application/octet-stream"

throwIO :: String -> IO a
throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing

moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO ()
moveDAV baseurl src dest = inLocation src $ moveContentM newurl
  where
	newurl = B8.fromString (locationUrl baseurl dest)

existsDAV :: DavLocation -> DAVT IO (Either String Bool)
existsDAV l = inLocation l check `catchNonAsync` (\e -> return (Left $ show e))
  where
	check = do
		-- Some DAV services only support depth of 1, and
		-- more depth is certainly not needed to check if a
		-- location exists.
		setDepth (Just Depth1)
		catchJust
			(matchStatusCodeException (== notFound404))
			(getPropsM >> ispresent True)
			(const $ ispresent False)
	ispresent = return . Right

-- Ignores any exceptions when performing a DAV action.
safely :: DAVT IO a -> DAVT IO (Maybe a)
safely = eitherToMaybe <$$> tryNonAsync

choke :: IO (Either String a) -> IO a
choke f = do
	x <- f
	case x of
		Left e -> error e
		Right r -> return r

data DavHandle = DavHandle DAVContext DavUser DavPass URLString

withDAVHandle :: Remote -> (Maybe DavHandle -> Annex a) -> Annex a
withDAVHandle r a = do
	mcreds <- getCreds (config r) (gitconfig r) (uuid r)
	case (mcreds, configUrl r) of
		(Just (user, pass), Just baseurl) ->
			withDAVContext baseurl $ \ctx ->
				a (Just (DavHandle ctx (toDavUser user) (toDavPass pass) baseurl))
		_ -> a Nothing

goDAV :: DavHandle -> DAVT IO a -> IO a
goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do
	prepDAV user pass
	a
  where
	run = fst <$$> runDAVContext ctx

{- Catch StatusCodeException and trim it to only the statusMessage part,
 - eliminating a lot of noise, which can include the whole request that
 - failed. The rethrown exception is no longer a StatusCodeException. -}
#if MIN_VERSION_http_client(0,5,0)
prettifyExceptions :: DAVT IO a -> DAVT IO a
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
  where
	go (HttpExceptionRequest _ (StatusCodeException response message)) = error $ unwords
		[ "DAV failure:"
		, show (responseStatus response)
		, show (message)
		]
	go e = throwM e
#else
prettifyExceptions :: DAVT IO a -> DAVT IO a
prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go
  where
	go (StatusCodeException status _ _) = error $ unwords
		[ "DAV failure:"
		, show (statusCode status)
		, show (statusMessage status)
		]
	go e = throwM e
#endif

prepDAV :: DavUser -> DavPass -> DAVT IO ()
prepDAV user pass = do
	setResponseTimeout Nothing -- disable default (5 second!) timeout
	setCreds user pass

--
-- Legacy chunking code, to be removed eventually.
--

storeLegacyChunked :: ChunkSize -> Key -> DavHandle -> L.ByteString -> IO Bool
storeLegacyChunked chunksize k dav b =
	Legacy.storeChunks k tmp dest storer recorder finalizer
  where
	storehttp l b' = void $ goDAV dav $ do
		maybe noop (void . mkColRecursive) (locationParent l)
		inLocation l $ putContentM (contentType, b')
	storer locs = Legacy.storeChunked chunksize locs storehttp b
	recorder l s = storehttp l (L8.fromString s)
	finalizer tmp' dest' = goDAV dav $ 
		finalizeStore (baseURL dav) tmp' (fromJust $ locationParent dest')

	tmp = addTrailingPathSeparator $ keyTmpLocation k
	dest = keyLocation k

retrieveLegacyChunked :: DavHandle -> Retriever
retrieveLegacyChunked dav = fileRetriever $ \d k p -> liftIO $
	withStoredFilesLegacyChunked k dav onerr $ \locs ->
		Legacy.meteredWriteFileChunks p d locs $ \l ->
			goDAV dav $
				inLocation l $
					snd <$> getContentM
  where
	onerr = error "download failed"

checkKeyLegacyChunked :: DavHandle -> CheckPresent
checkKeyLegacyChunked dav k = liftIO $
	either error id <$> withStoredFilesLegacyChunked k dav onerr check
  where
	check [] = return $ Right True
	check (l:ls) = do
		v <- goDAV dav $ existsDAV l
		if v == Right True
			then check ls
			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 f = do
		v <- goDAV dav $ existsDAV f
		return $ if v == Right True
			then Left $ "failed to read " ++ f
			else v

withStoredFilesLegacyChunked
	:: Key
	-> DavHandle
	-> (DavLocation -> IO a)
	-> ([DavLocation] -> IO a)
	-> IO a
withStoredFilesLegacyChunked k dav onerr a = do
	let chunkcount = keyloc ++ Legacy.chunkCount
	v <- goDAV dav $ safely $ 
		inLocation chunkcount $
			snd <$> getContentM
	case v of
		Just s -> a $ Legacy.listChunks keyloc $ L8.toString s
		Nothing -> do
			chunks <- Legacy.probeChunks keyloc $ \f ->
				(== Right True) <$> goDAV dav (existsDAV f)
			if null chunks
				then onerr chunkcount
				else a chunks
  where
	keyloc = keyLocation k