1{- WebDAV remotes. 2 - 3 - Copyright 2012-2021 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE ScopedTypeVariables #-} 9{-# LANGUAGE OverloadedStrings #-} 10{-# LANGUAGE RankNTypes #-} 11 12module Remote.WebDAV (remote, davCreds, configUrl) where 13 14import Network.Protocol.HTTP.DAV 15import qualified Data.Map as M 16import qualified Data.ByteString.Lazy as L 17import qualified Data.ByteString.UTF8 as B8 18import qualified Data.ByteString.Lazy.UTF8 as L8 19import Network.HTTP.Client (HttpException(..), RequestBody) 20import qualified Network.HTTP.Client as HTTP 21import Network.HTTP.Client (HttpExceptionContent(..), responseStatus) 22import Network.HTTP.Types 23import System.IO.Error 24import Control.Monad.Catch 25import Control.Monad.IO.Class (MonadIO) 26import Control.Concurrent.STM hiding (check) 27 28import Annex.Common 29import Types.Remote 30import Types.Export 31import qualified Git 32import qualified Annex 33import Config 34import Config.Cost 35import Annex.SpecialRemote.Config 36import Remote.Helper.Special 37import Remote.Helper.Http 38import Remote.Helper.ExportImport 39import qualified Remote.Helper.Chunked.Legacy as Legacy 40import Creds 41import Utility.Metered 42import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionContent) 43import Utility.Hash (IncrementalVerifier(..)) 44import Annex.UUID 45import Remote.WebDAV.DavLocation 46import Types.ProposedAccepted 47 48remote :: RemoteType 49remote = specialRemoteType $ RemoteType 50 { typename = "webdav" 51 , enumerate = const (findSpecialRemotes "webdav") 52 , generate = gen 53 , configParser = mkRemoteConfigParser 54 [ optionalStringParser urlField 55 (FieldDesc "(required) url to the WebDAV directory") 56 , optionalStringParser davcredsField HiddenField 57 ] 58 , setup = webdavSetup 59 , exportSupported = exportIsSupported 60 , importSupported = importUnsupported 61 , thirdPartyPopulated = False 62 } 63 64urlField :: RemoteConfigField 65urlField = Accepted "url" 66 67davcredsField :: RemoteConfigField 68davcredsField = Accepted "davcreds" 69 70gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) 71gen r u rc gc rs = do 72 c <- parsedRemoteConfig remote rc 73 new 74 <$> pure c 75 <*> remoteCost gc expensiveRemoteCost 76 <*> mkDavHandleVar c gc u 77 where 78 new c cst hdl = Just $ specialRemote c 79 (store hdl chunkconfig) 80 (retrieve hdl chunkconfig) 81 (remove hdl) 82 (checkKey hdl chunkconfig) 83 this 84 where 85 this = Remote 86 { uuid = u 87 , cost = cst 88 , name = Git.repoDescribe r 89 , storeKey = storeKeyDummy 90 , retrieveKeyFile = retrieveKeyFileDummy 91 , retrieveKeyFileCheap = Nothing 92 -- HttpManagerRestricted is used here, so this is 93 -- secure. 94 , retrievalSecurityPolicy = RetrievalAllKeysSecure 95 , removeKey = removeKeyDummy 96 , lockContent = Nothing 97 , checkPresent = checkPresentDummy 98 , checkPresentCheap = False 99 , exportActions = ExportActions 100 { storeExport = storeExportDav hdl 101 , retrieveExport = retrieveExportDav hdl 102 , checkPresentExport = checkPresentExportDav hdl this 103 , removeExport = removeExportDav hdl 104 , versionedExport = False 105 , removeExportDirectory = Just $ 106 removeExportDirectoryDav hdl 107 , renameExport = renameExportDav hdl 108 } 109 , importActions = importUnsupported 110 , whereisKey = Nothing 111 , remoteFsck = Nothing 112 , repairRepo = Nothing 113 , config = c 114 , getRepo = return r 115 , gitconfig = gc 116 , localpath = Nothing 117 , readonly = False 118 , appendonly = False 119 , untrustworthy = False 120 , availability = GloballyAvailable 121 , remotetype = remote 122 , mkUnavailable = gen r u (M.insert urlField (Proposed "http://!dne!/") rc) gc rs 123 , getInfo = includeCredsInfo c (davCreds u) $ 124 [("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)] 125 , claimUrl = Nothing 126 , checkUrl = Nothing 127 , remoteStateHandle = rs 128 } 129 chunkconfig = getChunkConfig c 130 131webdavSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) 132webdavSetup ss mu mcreds c gc = do 133 u <- maybe (liftIO genUUID) return mu 134 url <- maybe (giveup "Specify url=") 135 (return . fromProposedAccepted) 136 (M.lookup urlField c) 137 (c', encsetup) <- encryptionSetup c gc 138 pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c' 139 creds <- maybe (getCreds pc gc u) (return . Just) mcreds 140 testDav url creds 141 gitConfigSpecialRemote u c' [("webdav", "true")] 142 c'' <- setRemoteCredPair ss encsetup pc gc (davCreds u) creds 143 return (c'', u) 144 145store :: DavHandleVar -> ChunkConfig -> Storer 146store hv (LegacyChunks chunksize) = fileStorer $ \k f p -> 147 withDavHandle hv $ \dav -> do 148 annexrunner <- Annex.makeRunner 149 liftIO $ withMeteredFile f p $ storeLegacyChunked annexrunner chunksize k dav 150store hv _ = httpStorer $ \k reqbody -> 151 withDavHandle hv $ \dav -> liftIO $ goDAV dav $ do 152 let tmp = keyTmpLocation k 153 let dest = keyLocation k 154 storeHelper dav tmp dest reqbody 155 156storeHelper :: DavHandle -> DavLocation -> DavLocation -> RequestBody -> DAVT IO () 157storeHelper dav tmp dest reqbody = do 158 maybe noop (void . mkColRecursive) (locationParent tmp) 159 debugDav $ "putContent " ++ tmp 160 inLocation tmp $ 161 putContentM' (contentType, reqbody) 162 finalizeStore dav tmp dest 163 164finalizeStore :: DavHandle -> DavLocation -> DavLocation -> DAVT IO () 165finalizeStore dav tmp dest = do 166 debugDav $ "delContent " ++ dest 167 inLocation dest $ void $ safely $ delContentM 168 maybe noop (void . mkColRecursive) (locationParent dest) 169 moveDAV (baseURL dav) tmp dest 170 171retrieve :: DavHandleVar -> ChunkConfig -> Retriever 172retrieve hv cc = fileRetriever' $ \d k p iv -> 173 withDavHandle hv $ \dav -> case cc of 174 LegacyChunks _ -> do 175 -- Not doing incremental verification for chunks. 176 liftIO $ maybe noop unableIncremental iv 177 retrieveLegacyChunked (fromRawFilePath d) k p dav 178 _ -> liftIO $ goDAV dav $ 179 retrieveHelper (keyLocation k) (fromRawFilePath d) p iv 180 181retrieveHelper :: DavLocation -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> DAVT IO () 182retrieveHelper loc d p iv = do 183 debugDav $ "retrieve " ++ loc 184 inLocation loc $ 185 withContentM $ httpBodyRetriever d p iv 186 187remove :: DavHandleVar -> Remover 188remove hv k = withDavHandle hv $ \dav -> liftIO $ goDAV dav $ 189 -- Delete the key's whole directory, including any 190 -- legacy chunked files, etc, in a single action. 191 removeHelper (keyDir k) 192 193removeHelper :: DavLocation -> DAVT IO () 194removeHelper d = do 195 debugDav $ "delContent " ++ d 196 v <- safely $ inLocation d delContentM 197 case v of 198 Just _ -> return () 199 Nothing -> do 200 v' <- existsDAV d 201 case v' of 202 Right False -> return () 203 _ -> giveup "failed to remove content from remote" 204 205checkKey :: DavHandleVar -> ChunkConfig -> CheckPresent 206checkKey hv chunkconfig k = withDavHandle hv $ \dav -> 207 case chunkconfig of 208 LegacyChunks _ -> checkKeyLegacyChunked dav k 209 _ -> do 210 v <- liftIO $ goDAV dav $ 211 existsDAV (keyLocation k) 212 either giveup return v 213 214storeExportDav :: DavHandleVar -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () 215storeExportDav hdl f k loc p = case exportLocation loc of 216 Right dest -> withDavHandle hdl $ \h -> runExport h $ \dav -> do 217 reqbody <- liftIO $ httpBodyStorer f p 218 storeHelper dav (exportTmpLocation loc k) dest reqbody 219 Left err -> giveup err 220 221retrieveExportDav :: DavHandleVar -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex () 222retrieveExportDav hdl _k loc d p = case exportLocation loc of 223 Right src -> withDavHandle hdl $ \h -> runExport h $ \_dav -> 224 retrieveHelper src d p Nothing 225 Left err -> giveup err 226 227checkPresentExportDav :: DavHandleVar -> Remote -> Key -> ExportLocation -> Annex Bool 228checkPresentExportDav hdl _ _k loc = case exportLocation loc of 229 Right p -> withDavHandle hdl $ \h -> liftIO $ do 230 v <- goDAV h $ existsDAV p 231 either giveup return v 232 Left err -> giveup err 233 234removeExportDav :: DavHandleVar-> Key -> ExportLocation -> Annex () 235removeExportDav hdl _k loc = case exportLocation loc of 236 Right p -> withDavHandle hdl $ \h -> runExport h $ \_dav -> 237 removeHelper p 238 -- When the exportLocation is not legal for webdav, 239 -- the content is certianly not stored there, so it's ok for 240 -- removal to succeed. This allows recovery after failure to store 241 -- content there, as the user can rename the problem file and 242 -- this will be called to make sure it's gone. 243 Left _err -> return () 244 245removeExportDirectoryDav :: DavHandleVar -> ExportDirectory -> Annex () 246removeExportDirectoryDav hdl dir = withDavHandle hdl $ \h -> runExport h $ \_dav -> do 247 let d = fromRawFilePath $ fromExportDirectory dir 248 debugDav $ "delContent " ++ d 249 inLocation d delContentM 250 251renameExportDav :: DavHandleVar -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) 252renameExportDav hdl _k src dest = case (exportLocation src, exportLocation dest) of 253 (Right srcl, Right destl) -> withDavHandle hdl $ \h -> do 254 -- Several webdav servers have buggy handing of renames, 255 -- and fail to rename in some circumstances. 256 -- Since after a failure it's not clear where the file ended 257 -- up, recover by deleting both the source and destination. 258 -- The file will later be re-uploaded to the destination, 259 -- so this deletion is ok. 260 let go = runExport h $ \dav -> do 261 maybe noop (void . mkColRecursive) (locationParent destl) 262 moveDAV (baseURL dav) srcl destl 263 return (Just ()) 264 let recover = do 265 void $ runExport h $ \_dav -> safely $ 266 inLocation srcl delContentM 267 void $ runExport h $ \_dav -> safely $ 268 inLocation destl delContentM 269 return Nothing 270 catchNonAsync go (const recover) 271 (Left err, _) -> giveup err 272 (_, Left err) -> giveup err 273 274runExport :: DavHandle -> (DavHandle -> DAVT IO a) -> Annex a 275runExport h a = liftIO (goDAV h (a h)) 276 277configUrl :: ParsedRemoteConfig -> Maybe URLString 278configUrl c = fixup <$> getRemoteConfigValue urlField c 279 where 280 -- box.com DAV url changed 281 fixup = replace "https://www.box.com/dav/" boxComUrl 282 283boxComUrl :: URLString 284boxComUrl = "https://dav.box.com/dav/" 285 286type DavUser = B8.ByteString 287type DavPass = B8.ByteString 288 289baseURL :: DavHandle -> URLString 290baseURL (DavHandle _ _ _ u) = u 291 292 293toDavUser :: String -> DavUser 294toDavUser = B8.fromString 295 296toDavPass :: String -> DavPass 297toDavPass = B8.fromString 298 299{- Test if a WebDAV store is usable, by writing to a test file, and then 300 - deleting the file. 301 - 302 - Also ensures that the path of the url exists, trying to create it if not. 303 - 304 - Throws an error if store is not usable. 305 -} 306testDav :: URLString -> Maybe CredPair -> Annex () 307testDav url (Just (u, p)) = do 308 showAction "testing WebDAV server" 309 test $ liftIO $ evalDAVT url $ do 310 prepDAV user pass 311 makeParentDirs 312 inLocation (tmpLocation "test") $ do 313 putContentM (Nothing, L8.fromString "test") 314 delContentM 315 where 316 test a = liftIO $ 317 either (\e -> throwIO $ "WebDAV test failed: " ++ show e) 318 (const noop) 319 =<< tryNonAsync a 320 321 user = toDavUser u 322 pass = toDavPass p 323testDav _ Nothing = error "Need to configure webdav username and password." 324 325{- Tries to make all the parent directories in the WebDAV urls's path, 326 - right down to the root. 327 - 328 - Ignores any failures, which can occur for reasons including the WebDAV 329 - server only serving up WebDAV in a subdirectory. -} 330makeParentDirs :: DAVT IO () 331makeParentDirs = go 332 where 333 go = do 334 l <- getDAVLocation 335 case locationParent l of 336 Nothing -> noop 337 Just p -> void $ safely $ inDAVLocation (const p) go 338 void $ safely mkCol 339 340{- Checks if the directory exists. If not, tries to create its 341 - parent directories, all the way down to the root, and finally creates 342 - it. -} 343mkColRecursive :: DavLocation -> DAVT IO Bool 344mkColRecursive d = go =<< existsDAV d 345 where 346 go (Right True) = return True 347 go _ = do 348 debugDav $ "mkCol " ++ d 349 ifM (inLocation d mkCol) 350 ( return True 351 , do 352 case locationParent d of 353 Nothing -> makeParentDirs 354 Just parent -> void (mkColRecursive parent) 355 inLocation d mkCol 356 ) 357 358getCreds :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair) 359getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u) 360 361davCreds :: UUID -> CredPairStorage 362davCreds u = CredPairStorage 363 { credPairFile = fromUUID u 364 , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD") 365 , credPairRemoteField = davcredsField 366 } 367 368{- Content-Type to use for files uploaded to WebDAV. -} 369contentType :: Maybe B8.ByteString 370contentType = Just $ B8.fromString "application/octet-stream" 371 372throwIO :: String -> IO a 373throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing 374 375moveDAV :: URLString -> DavLocation -> DavLocation -> DAVT IO () 376moveDAV baseurl src dest = do 377 debugDav $ "moveContent " ++ src ++ " " ++ newurl 378 inLocation src $ moveContentM (B8.fromString newurl) 379 where 380 newurl = locationUrl baseurl dest 381 382existsDAV :: DavLocation -> DAVT IO (Either String Bool) 383existsDAV l = do 384 debugDav $ "getProps " ++ l 385 inLocation l check `catchNonAsync` (\e -> return (Left $ show e)) 386 where 387 check = do 388 -- Some DAV services only support depth of 1, and 389 -- more depth is certainly not needed to check if a 390 -- location exists. 391 setDepth (Just Depth1) 392 catchJust missinghttpstatus 393 (getPropsM >> ispresent True) 394 (const $ ispresent False) 395 ispresent = return . Right 396 missinghttpstatus e = 397 matchStatusCodeException (== notFound404) e 398 <|> matchHttpExceptionContent toomanyredirects e 399 toomanyredirects (TooManyRedirects _) = True 400 toomanyredirects _ = False 401 402safely :: DAVT IO a -> DAVT IO (Maybe a) 403safely = eitherToMaybe <$$> tryNonAsync 404 405choke :: IO (Either String a) -> IO a 406choke f = do 407 x <- f 408 case x of 409 Left e -> error e 410 Right r -> return r 411 412data DavHandle = DavHandle DAVContext DavUser DavPass URLString 413 414type DavHandleVar = TVar (Either (Annex (Either String DavHandle)) (Either String DavHandle)) 415 416{- Prepares a DavHandle for later use. Does not connect to the server or do 417 - anything else expensive. -} 418mkDavHandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex DavHandleVar 419mkDavHandleVar c gc u = liftIO $ newTVarIO $ Left $ do 420 mcreds <- getCreds c gc u 421 case (mcreds, configUrl c) of 422 (Just (user, pass), Just baseurl) -> do 423 ctx <- mkDAVContext baseurl 424 let h = DavHandle ctx (toDavUser user) (toDavPass pass) baseurl 425 return (Right h) 426 _ -> return $ Left "webdav credentials not available" 427 428withDavHandle :: DavHandleVar -> (DavHandle -> Annex a) -> Annex a 429withDavHandle hv a = liftIO (readTVarIO hv) >>= \case 430 Right hdl -> either giveup a hdl 431 Left mkhdl -> do 432 hdl <- mkhdl 433 liftIO $ atomically $ writeTVar hv (Right hdl) 434 either giveup a hdl 435 436goDAV :: DavHandle -> DAVT IO a -> IO a 437goDAV (DavHandle ctx user pass _) a = choke $ run $ prettifyExceptions $ do 438 prepDAV user pass 439 a 440 where 441 run = fst <$$> runDAVContext ctx 442 443{- Catch StatusCodeException and trim it to only the statusMessage part, 444 - eliminating a lot of noise, which can include the whole request that 445 - failed. The rethrown exception is no longer a StatusCodeException. -} 446prettifyExceptions :: DAVT IO a -> DAVT IO a 447prettifyExceptions a = catchJust (matchStatusCodeException (const True)) a go 448 where 449 go (HttpExceptionRequest req (StatusCodeException response message)) = giveup $ unwords 450 [ "DAV failure:" 451 , show (responseStatus response) 452 , show (message) 453 , "HTTP request:" 454 , show (HTTP.method req) 455 , show (HTTP.path req) 456 ] 457 go e = throwM e 458 459prepDAV :: DavUser -> DavPass -> DAVT IO () 460prepDAV user pass = do 461 setResponseTimeout Nothing -- disable default (5 second!) timeout 462 setCreds user pass 463 464-- 465-- Legacy chunking code, to be removed eventually. 466-- 467 468storeLegacyChunked :: (Annex () -> IO ()) -> ChunkSize -> Key -> DavHandle -> L.ByteString -> IO () 469storeLegacyChunked annexrunner chunksize k dav b = 470 Legacy.storeChunks k tmp dest storer recorder finalizer 471 where 472 storehttp l b' = void $ goDAV dav $ do 473 maybe noop (void . mkColRecursive) (locationParent l) 474 debugDav $ "putContent " ++ l 475 inLocation l $ putContentM (contentType, b') 476 storer locs = Legacy.storeChunked annexrunner chunksize locs storehttp b 477 recorder l s = storehttp l (L8.fromString s) 478 finalizer tmp' dest' = goDAV dav $ 479 finalizeStore dav tmp' (fromJust $ locationParent dest') 480 481 tmp = addTrailingPathSeparator $ keyTmpLocation k 482 dest = keyLocation k 483 484retrieveLegacyChunked :: FilePath -> Key -> MeterUpdate -> DavHandle -> Annex () 485retrieveLegacyChunked d k p dav = liftIO $ 486 withStoredFilesLegacyChunked k dav onerr $ \locs -> 487 Legacy.meteredWriteFileChunks p d locs $ \l -> 488 goDAV dav $ do 489 debugDav $ "getContent " ++ l 490 inLocation l $ 491 snd <$> getContentM 492 where 493 onerr = error "download failed" 494 495checkKeyLegacyChunked :: DavHandle -> CheckPresent 496checkKeyLegacyChunked dav k = liftIO $ 497 either error id <$> withStoredFilesLegacyChunked k dav onerr check 498 where 499 check [] = return $ Right True 500 check (l:ls) = do 501 v <- goDAV dav $ existsDAV l 502 if v == Right True 503 then check ls 504 else return v 505 506 {- Failed to read the chunkcount file; see if it's missing, 507 - or if there's a problem accessing it, 508 - or perhaps this was an intermittent error. -} 509 onerr f = do 510 v <- goDAV dav $ existsDAV f 511 return $ if v == Right True 512 then Left $ "failed to read " ++ f 513 else v 514 515withStoredFilesLegacyChunked 516 :: Key 517 -> DavHandle 518 -> (DavLocation -> IO a) 519 -> ([DavLocation] -> IO a) 520 -> IO a 521withStoredFilesLegacyChunked k dav onerr a = do 522 let chunkcount = keyloc ++ Legacy.chunkCount 523 v <- goDAV dav $ safely $ do 524 debugDav $ "getContent " ++ chunkcount 525 inLocation chunkcount $ 526 snd <$> getContentM 527 case v of 528 Just s -> a $ Legacy.listChunks keyloc $ L8.toString s 529 Nothing -> do 530 chunks <- Legacy.probeChunks keyloc $ \f -> 531 (== Right True) <$> goDAV dav (existsDAV f) 532 if null chunks 533 then onerr chunkcount 534 else a chunks 535 where 536 keyloc = keyLocation k 537 538debugDav :: MonadIO m => String -> DAVT m () 539debugDav msg = liftIO $ debug "Remote.WebDAV" msg 540