mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

ported almost all remotes, until my brain melted

Browse source 
external is not started yet, and S3 is part way through and not
compiling yet
This commit is contained in:
Joey Hess 2020-01-14 15:41:34 -04:00
parent c498269a88
commit c4ea3ca40a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
13 changed files with 265 additions and 150 deletions
Download patch file Download diff file Expand all files Collapse all files

27
Remote/WebDAV.hs
View file

@ -1,6 +1,6 @@
{- WebDAV remotes.
-
- Copyright 2012-2017 Joey Hess <id@joeyh.name>
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
@ -29,6 +29,7 @@ import Types.Export
import qualified Git
import Config
import Config.Cost
import Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.Messages
import Remote.Helper.Http
@ -42,16 +43,22 @@ import Remote.WebDAV.DavLocation
import Types.ProposedAccepted
remote :: RemoteType
remote = RemoteType
remote = specialRemoteType $ RemoteType
{ typename = "webdav"
, enumerate = const (findSpecialRemotes "webdav")
, generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser urlField
]
, setup = webdavSetup
, exportSupported = exportIsSupported
, importSupported = importUnsupported
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
urlField :: RemoteConfigField
urlField = Accepted "url"
gen :: Git.Repo -> UUID -> ParsedRemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
where
new cst = Just $ specialRemote c
@ -96,9 +103,9 @@ gen r u c gc rs = new <$> remoteCost gc expensiveRemoteCost
, appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = gen r u (M.insert (Accepted "url") (Accepted "http://!dne!/") c) gc rs
, mkUnavailable = gen r u (M.insert urlField (RemoteConfigValue "http://!dne!/") c) gc rs
, getInfo = includeCredsInfo c (davCreds u) $
[("url", maybe "unknown" fromProposedAccepted (M.lookup (Accepted "url") c))]
[("url", fromMaybe "unknown" $ getRemoteConfigValue urlField c)]
, claimUrl = Nothing
, checkUrl = Nothing
, remoteStateHandle = rs
@ -110,9 +117,10 @@ webdavSetup _ mu mcreds c gc = do
u <- maybe (liftIO genUUID) return mu
url <- maybe (giveup "Specify url=")
(return . fromProposedAccepted)
(M.lookup (Accepted "url") c)
(M.lookup urlField c)
(c', encsetup) <- encryptionSetup c gc
creds <- maybe (getCreds c' gc u) (return . Just) mcreds
pc <- either giveup return . parseRemoteConfig c' =<< configParser remote
creds <- maybe (getCreds pc gc u) (return . Just) mcreds
testDav url creds
gitConfigSpecialRemote u c' [("webdav", "true")]
c'' <- setRemoteCredPair encsetup c' gc (davCreds u) creds
@ -256,8 +264,7 @@ runExport Nothing _ = return False
runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
configUrl :: Remote -> Maybe URLString
configUrl r = fixup . fromProposedAccepted
<$> M.lookup (Accepted "url") (config r)
configUrl r = fixup <$> getRemoteConfigValue urlField (config r)
where
-- box.com DAV url changed
fixup = replace "https://www.box.com/dav/" boxComUrl
@ -337,7 +344,7 @@ mkColRecursive d = go =<< existsDAV d
inLocation d mkCol
)
getCreds :: RemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
getCreds :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex (Maybe CredPair)
getCreds c gc u = getRemoteCredPairFor "webdav" c gc (davCreds u)
davCreds :: UUID -> CredPairStorage