Merge branch 'master' into s3-aws

Conflicts:
	Remote/S3.hs
This commit is contained in:
Joey Hess 2014-10-22 17:14:38 -04:00
commit 35551d0ed0
502 changed files with 7127 additions and 2453 deletions

View file

@ -73,6 +73,7 @@ gen r u c gc = do
, availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable
, readonly = False
, mkUnavailable = return Nothing
, getInfo = return [("repo", buprepo)]
}
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this buprepo)
@ -94,7 +95,7 @@ bupSetup mu _ c = do
-- verify configuration is sane
let buprepo = fromMaybe (error "Specify buprepo=") $
M.lookup "buprepo" c
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
-- bup init will create the repository.
-- (If the repository already exists, bup init again appears safe.)

View file

@ -70,6 +70,7 @@ gen r u c gc = do
, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
, readonly = False
, mkUnavailable = return Nothing
, getInfo = return [("repo", ddarrepo)]
}
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
specialcfg = (specialRemoteCfg c)
@ -84,7 +85,7 @@ ddarSetup mu _ c = do
-- verify configuration is sane
let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
M.lookup "ddarrepo" c
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
-- The ddarrepo is stored in git config, as well as this repo's
-- persistant state, so it can vary between hosts.

View file

@ -67,7 +67,8 @@ gen r u c gc = do
availability = LocallyAvailable,
remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexDirectory = Just "/dev/null" }
gc { remoteAnnexDirectory = Just "/dev/null" },
getInfo = return [("directory", dir)]
}
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
@ -81,7 +82,7 @@ directorySetup mu _ c = do
absdir <- liftIO $ absPath dir
liftIO $ unlessM (doesDirectoryExist absdir) $
error $ "Directory does not exist: " ++ absdir
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
-- The directory is stored in git config, not in this remote's
-- persistant state, so it can vary between hosts.

View file

@ -68,6 +68,7 @@ gen r u c gc = do
remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexExternalType = Just "!dne!" }
, getInfo = return [("externaltype", externaltype)]
}
where
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)
@ -77,7 +78,7 @@ externalSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let externaltype = fromMaybe (error "Specify externaltype=") $
M.lookup "externaltype" c
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
external <- newExternal externaltype u c'
handleRequest external INITREMOTE Nothing $ \resp -> case resp of
@ -169,7 +170,7 @@ handleRequest' lck external req mp responsehandler
go
| otherwise = go
where
go = do
go = do
sendMessage lck external req
loop
loop = receiveMessage lck external responsehandler
@ -191,7 +192,7 @@ handleRequest' lck external req mp responsehandler
send $ VALUE value
handleRemoteRequest (SETCREDS setting login password) = do
c <- liftIO $ atomically $ readTMVar $ externalConfig external
c' <- setRemoteCredPair c (credstorage setting) $
c' <- setRemoteCredPair encryptionAlreadySetup c (credstorage setting) $
Just (login, password)
void $ liftIO $ atomically $ swapTMVar (externalConfig external) c'
handleRemoteRequest (GETCREDS setting) = do

View file

@ -121,6 +121,7 @@ gen' r u c gc = do
, availability = availabilityCalc r
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return $ gitRepoInfo r
}
return $ Just $ specialRemote' specialcfg c
(simplyPrepare $ store this rsyncopts)
@ -147,7 +148,7 @@ rsyncTransport r
| ":" `isInfixOf` loc = sshtransport $ separate (== ':') loc
| otherwise = othertransport
where
loc = Git.repoLocation r
loc = Git.repoLocation r
sshtransport (host, path) = do
let rsyncpath = if "/~/" `isPrefixOf` path
then drop 3 path
@ -166,9 +167,9 @@ gCryptSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConf
gCryptSetup mu _ c = go $ M.lookup "gitrepo" c
where
remotename = fromJust (M.lookup "name" c)
go Nothing = error "Specify gitrepo="
go Nothing = error "Specify gitrepo="
go (Just gitrepo) = do
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
inRepo $ Git.Command.run
[ Params "remote add"
, Param remotename
@ -234,7 +235,7 @@ setupRepo gcryptid r
- create the objectDir on the remote,
- which is needed for direct rsync of objects to work.
-}
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
rsyncsetup = Remote.Rsync.withRsyncScratchDir $ \tmp -> do
liftIO $ createDirectoryIfMissing True $ tmp </> objectDir
(rsynctransport, rsyncurl, _) <- rsyncTransport r
let tmpconfig = tmp </> "config"
@ -266,7 +267,7 @@ isShell r = case method of
AccessShell -> True
_ -> False
where
method = toAccessMethod $ fromMaybe "" $
method = toAccessMethod $ fromMaybe "" $
remoteAnnexGCrypt $ gitconfig r
shellOrRsync :: Remote -> Annex a -> Annex a -> Annex a
@ -352,7 +353,7 @@ checkKey r rsyncopts k
| Git.repoIsSsh (repo r) = shellOrRsync r checkshell checkrsync
| otherwise = unsupportedUrl
where
checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
checkrsync = Remote.Rsync.checkKey (repo r) rsyncopts k
checkshell = Ssh.inAnnex (repo r) k
{- Annexed objects are hashed using lower-case directories for max

View file

@ -159,6 +159,7 @@ gen r u c gc
, availability = availabilityCalc r
, remotetype = remote
, mkUnavailable = unavailable r u c gc
, getInfo = return $ gitRepoInfo r
}
unavailable :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
@ -305,7 +306,7 @@ inAnnex rmt key
| Git.repoIsUrl r = checkremote
| otherwise = checklocal
where
r = repo rmt
r = repo rmt
checkhttp = do
showChecking r
ifM (Url.withUrlOptions $ \uo -> anyM (\u -> Url.checkBoth u (keySize key) uo) (keyUrls rmt key))

View file

@ -66,7 +66,9 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
readonly = False,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = return Nothing
mkUnavailable = return Nothing,
getInfo = includeCredsInfo c (AWS.creds u) $
[ ("glacier vault", getVault c) ]
}
specialcfg = (specialRemoteCfg c)
-- Disabled until jobList gets support for chunks.
@ -76,12 +78,12 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
glacierSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
c' <- setRemoteCredPair c (AWS.creds u) mcreds
glacierSetup' (isJust mu) u c'
glacierSetup' :: Bool -> UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup' enabling u c = do
c' <- encryptionSetup c
let fullconfig = c' `M.union` defaults
glacierSetup' (isJust mu) u mcreds c
glacierSetup' :: Bool -> UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
glacierSetup' enabling u mcreds c = do
(c', encsetup) <- encryptionSetup c
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
unless enabling $
genVault fullconfig u
gitConfigSpecialRemote u fullconfig "glacier" "true"
@ -141,7 +143,10 @@ retrieve r k sink = go =<< glacierEnv c u
]
go Nothing = error "cannot retrieve from glacier"
go (Just e) = do
let cmd = (proc "glacier" (toCommand params)) { env = Just e }
let cmd = (proc "glacier" (toCommand params))
{ env = Just e
, std_out = CreatePipe
}
(_, Just h, _, pid) <- liftIO $ createProcess cmd
-- Glacier cannot store empty files, so if the output is
-- empty, the content is not available yet.

View file

@ -8,6 +8,7 @@
module Remote.Helper.Chunked (
ChunkSize,
ChunkConfig(..),
describeChunkConfig,
getChunkConfig,
storeChunks,
removeChunks,
@ -34,6 +35,14 @@ data ChunkConfig
| LegacyChunks ChunkSize
deriving (Show)
describeChunkConfig :: ChunkConfig -> String
describeChunkConfig NoChunks = "none"
describeChunkConfig (UnpaddedChunks sz) = describeChunkSize sz ++ "chunks"
describeChunkConfig (LegacyChunks sz) = describeChunkSize sz ++ " chunks (old style)"
describeChunkSize :: ChunkSize -> String
describeChunkSize sz = roughSize storageUnits False (fromIntegral sz)
noChunks :: ChunkConfig -> Bool
noChunks NoChunks = True
noChunks _ = False
@ -123,7 +132,7 @@ storeChunks u chunkconfig k f p storer checker =
loop bytesprocessed (chunk, bs) chunkkeys
| L.null chunk && numchunks > 0 = do
-- Once all chunks are successfully
-- Once all chunks are successfully
-- stored, update the chunk log.
chunksStored u k (FixedSizeChunks chunksize) numchunks
return True
@ -138,7 +147,7 @@ storeChunks u chunkconfig k f p storer checker =
)
where
numchunks = numChunks chunkkeys
{- The MeterUpdate that is passed to the action
{- The MeterUpdate that is passed to the action
- storing a chunk is offset, so that it reflects
- the total bytes that have already been stored
- in previous chunks. -}
@ -290,7 +299,7 @@ retrieveChunks retriever u chunkconfig encryptor basek dest basep sink
hSeek h AbsoluteSeek startpoint
return h
{- Progress meter updating is a bit tricky: If the Retriever
{- Progress meter updating is a bit tricky: If the Retriever
- populates a file, it is responsible for updating progress
- as the file is being retrieved.
-

View file

@ -5,7 +5,19 @@
- Licensed under the GNU GPL version 3 or higher.
-}
module Remote.Helper.Encryptable where
module Remote.Helper.Encryptable (
EncryptionIsSetup,
encryptionSetup,
noEncryptionUsed,
encryptionAlreadySetup,
remoteCipher,
remoteCipher',
embedCreds,
cipherKey,
storeCipher,
extractCipher,
describeEncryption,
) where
import qualified Data.Map as M
@ -16,11 +28,26 @@ import Types.Crypto
import qualified Annex
import Utility.Base64
-- Used to ensure that encryption has been set up before trying to
-- eg, store creds in the remote config that would need to use the
-- encryption setup.
data EncryptionIsSetup = EncryptionIsSetup | NoEncryption
-- Remotes that don't use encryption can use this instead of
-- encryptionSetup.
noEncryptionUsed :: EncryptionIsSetup
noEncryptionUsed = NoEncryption
-- Using this avoids the type-safe check, so you'd better be sure
-- of what you're doing.
encryptionAlreadySetup :: EncryptionIsSetup
encryptionAlreadySetup = EncryptionIsSetup
{- Encryption setup for a remote. The user must specify whether to use
- an encryption key, or not encrypt. An encrypted cipher is created, or is
- updated to be accessible to an additional encryption key. Or the user
- could opt to use a shared cipher, which is stored unencrypted. -}
encryptionSetup :: RemoteConfig -> Annex RemoteConfig
encryptionSetup :: RemoteConfig -> Annex (RemoteConfig, EncryptionIsSetup)
encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
where
-- The type of encryption
@ -28,11 +55,11 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
-- Generate a new cipher, depending on the chosen encryption scheme
genCipher = case encryption of
_ | M.member "cipher" c || M.member "cipherkeys" c -> cannotchange
Just "none" -> return c
Just "none" -> return (c, NoEncryption)
Just "shared" -> use "encryption setup" . genSharedCipher
=<< highRandomQuality
-- hybrid encryption is the default when a keyid is
-- specified but no encryption
-- specified but no encryption
_ | maybe (M.member "keyid" c) (== "hybrid") encryption ->
use "encryption setup" . genEncryptedCipher key Hybrid
=<< highRandomQuality
@ -48,7 +75,7 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
cannotchange = error "Cannot set encryption type of existing remotes."
-- Update an existing cipher if possible.
updateCipher v = case v of
SharedCipher _ | maybe True (== "shared") encryption -> return c'
SharedCipher _ | maybe True (== "shared") encryption -> return (c', EncryptionIsSetup)
EncryptedCipher _ variant _
| maybe True (== if variant == Hybrid then "hybrid" else "pubkey") encryption ->
use "encryption update" $ updateEncryptedCipher newkeys v
@ -57,22 +84,22 @@ encryptionSetup c = maybe genCipher updateCipher $ extractCipher c
showNote m
cipher <- liftIO a
showNote $ describeCipher cipher
return $ storeCipher c' cipher
return (storeCipher c' cipher, EncryptionIsSetup)
highRandomQuality =
(&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c)
<$> fmap not (Annex.getState Annex.fast)
c' = foldr M.delete c
-- git-annex used to remove 'encryption' as well, since
-- it was redundant; we now need to keep it for
-- public-key encryption, hence we leave it on newer
-- remotes (while being backward-compatible).
-- git-annex used to remove 'encryption' as well, since
-- it was redundant; we now need to keep it for
-- public-key encryption, hence we leave it on newer
-- remotes (while being backward-compatible).
[ "keyid", "keyid+", "keyid-", "highRandomQuality" ]
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
- state. -}
remoteCipher :: RemoteConfig -> Annex (Maybe Cipher)
remoteCipher = fmap fst <$$> remoteCipher'
{- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex
- state. -}
remoteCipher' :: RemoteConfig -> Annex (Maybe (Cipher, StorableCipher))
remoteCipher' c = go $ extractCipher c
where
@ -131,3 +158,15 @@ extractCipher c = case (M.lookup "cipher" c,
_ -> Nothing
where
readkeys = KeyIds . split ","
describeEncryption :: RemoteConfig -> String
describeEncryption c = case extractCipher c of
Nothing -> "not encrypted"
(Just (SharedCipher _)) -> "encrypted (encryption key stored in git repository)"
(Just (EncryptedCipher _ v (KeyIds { keyIds = ks }))) -> unwords $ catMaybes
[ Just "encrypted (to gpg keys:"
, Just (unwords ks ++ ")")
, case v of
PubKey -> Nothing
Hybrid -> Just "(hybrid mode)"
]

View file

@ -30,3 +30,8 @@ guardUsable :: Git.Repo -> Annex a -> Annex a -> Annex a
guardUsable r fallback a
| Git.repoIsLocalUnknown r = fallback
| otherwise = a
gitRepoInfo :: Git.Repo -> [(String, String)]
gitRepoInfo r =
[ ("repository location", Git.repoLocation r)
]

View file

@ -87,7 +87,7 @@ checkPrepare checker helper k a = ifM (checker k)
-- Use to acquire a resource when preparing a helper.
resourcePrepare :: (Key -> (r -> Annex Bool) -> Annex Bool) -> (r -> helper) -> Preparer helper
resourcePrepare withr helper k a = withr k $ \r ->
a (Just (helper r))
a (Just (helper r))
-- A Storer that expects to be provided with a file containing
-- the content of the key to store.
@ -168,6 +168,12 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
(cost baser)
(const $ cost baser + encryptedRemoteCostAdj)
(extractCipher c)
, getInfo = do
l <- getInfo baser
return $ l ++
[ ("encryption", describeEncryption c)
, ("chunking", describeChunkConfig (chunkConfig cfg))
]
}
cip = cipherKey c
gpgopts = getGpgEncParams encr
@ -196,7 +202,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
retrieveKeyFileGen k dest p enc =
safely $ prepareretriever k $ safely . go
where
go (Just retriever) = displayprogress p k $ \p' ->
go (Just retriever) = displayprogress p k $ \p' ->
retrieveChunks retriever (uuid baser) chunkconfig
enck k dest p' (sink dest enc)
go Nothing = return False
@ -210,7 +216,7 @@ specialRemote' cfg c preparestorer prepareretriever prepareremover preparecheckp
checkPresentGen k enc = preparecheckpresent k go
where
go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
go (Just checker) = checkPresentChunks checker (uuid baser) chunkconfig enck k
go Nothing = cantCheck baser
enck = maybe id snd enc

View file

@ -60,7 +60,8 @@ gen r u c gc = do
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexHookType = Just "!dne!" }
gc { remoteAnnexHookType = Just "!dne!" },
getInfo = return [("hooktype", hooktype)]
}
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc
@ -70,7 +71,7 @@ hookSetup mu _ c = do
u <- maybe (liftIO genUUID) return mu
let hooktype = fromMaybe (error "Specify hooktype=") $
M.lookup "hooktype" c
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
gitConfigSpecialRemote u c' "hooktype" hooktype
return (c', u)
@ -138,7 +139,7 @@ checkKey r h k = do
v <- lookupHook h action
liftIO $ check v
where
action = "checkpresent"
action = "checkpresent"
findkey s = key2file k `elem` lines s
check Nothing = error $ action ++ " hook misconfigured"
check (Just hook) = do

View file

@ -83,6 +83,7 @@ gen r u c gc = do
, availability = if islocal then LocallyAvailable else GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return [("url", url)]
}
where
specialcfg = (specialRemoteCfg c)
@ -138,7 +139,7 @@ rsyncSetup mu _ c = do
-- verify configuration is sane
let url = fromMaybe (error "Specify rsyncurl=") $
M.lookup "rsyncurl" c
c' <- encryptionSetup c
(c', _encsetup) <- encryptionSetup c
-- The rsyncurl is stored in git config, not only in this remote's
-- persistant state, so it can vary between hosts.
@ -175,7 +176,7 @@ store o k src meterupdate = withRsyncScratchDir $ \tmp -> do
]
else return False
where
{- If the key being sent is encrypted or chunked, the file
{- If the key being sent is encrypted or chunked, the file
- containing its content is a temp file, and so can be
- renamed into place. Otherwise, the file is the annexed
- object file, and has to be copied or hard linked into place. -}

View file

@ -5,9 +5,7 @@
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies #-}
module Remote.S3 (remote, iaHost, configIA, isIAHost, iaItemUrl) where
module Remote.S3 (remote, iaHost, configIA, isIA, iaItemUrl) where
import qualified Aws as AWS
import qualified Aws.Core as AWS
@ -83,16 +81,21 @@ gen r u c gc = do
readonly = False,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc
mkUnavailable = gen r u (M.insert "host" "!dne!" c) gc,
getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes
[ Just ("bucket", fromMaybe "unknown" (getBucket c))
, if isIA c
then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucket c)
else Nothing
]
}
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu mcreds c = do
u <- maybe (liftIO genUUID) return mu
c' <- setRemoteCredPair c (AWS.creds u) mcreds
s3Setup' u c'
s3Setup' :: UUID -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup' u c = if configIA c then archiveorg else defaulthost
s3Setup' u mcreds c
s3Setup' :: UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup' u mcreds c = if isIA c then archiveorg else defaulthost
where
remotename = fromJust (M.lookup "name" c)
defbucket = remotename ++ "-" ++ fromUUID u
@ -109,25 +112,27 @@ s3Setup' u c = if configIA c then archiveorg else defaulthost
return (fullconfig, u)
defaulthost = do
c' <- encryptionSetup c
let fullconfig = c' `M.union` defaults
(c', encsetup) <- encryptionSetup c
c'' <- setRemoteCredPair encsetup c' (AWS.creds u) mcreds
let fullconfig = c'' `M.union` defaults
genBucket fullconfig u
use fullconfig
archiveorg = do
showNote "Internet Archive mode"
c' <- setRemoteCredPair noEncryptionUsed c (AWS.creds u) mcreds
-- Ensure user enters a valid bucket name, since
-- this determines the name of the archive.org item.
let validbucket = replace " " "-" $ map toLower $
fromMaybe (error "specify bucket=") $
getBucketName c
getBucketName c'
let archiveconfig =
-- IA acdepts x-amz-* as an alias for x-archive-*
M.mapKeys (replace "x-archive-" "x-amz-") $
-- encryption does not make sense here
M.insert "encryption" "none" $
M.insert "bucket" validbucket $
M.union c $
M.union c' $
-- special constraints on key names
M.insert "mungekeys" "ia" defaults
info <- extractS3Info archiveconfig

View file

@ -84,7 +84,8 @@ gen r u c gc = do
readonly = False,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = return Nothing
mkUnavailable = return Nothing,
getInfo = return []
}
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
@ -167,7 +168,7 @@ writeSharedConvergenceSecret configdir scs =
getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret
getSharedConvergenceSecret configdir = go (60 :: Int)
where
f = convergenceFile configdir
f = convergenceFile configdir
go n
| n == 0 = error $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
| otherwise = do
@ -190,7 +191,7 @@ startTahoeDaemon configdir = void $ boolTahoe configdir "start" []
withTahoeConfigDir :: TahoeHandle -> (TahoeConfigDir -> IO a) -> IO a
withTahoeConfigDir (TahoeHandle configdir v) a = go =<< atomically needsstart
where
go True = do
go True = do
startTahoeDaemon configdir
a configdir
go False = a configdir

View file

@ -62,7 +62,8 @@ gen r _ c gc =
readonly = True,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = return Nothing
mkUnavailable = return Nothing,
getInfo = return []
}
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
@ -120,7 +121,7 @@ checkKey' key us = firsthit us (Right False) $ \u -> do
Url.withUrlOptions $ catchMsgIO .
Url.checkBoth u' (keySize key)
where
firsthit [] miss _ = return miss
firsthit [] miss _ = return miss
firsthit (u:rest) _ a = do
r <- a u
case r of

View file

@ -71,7 +71,9 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
readonly = False,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc
mkUnavailable = gen r u (M.insert "url" "http://!dne!/" c) gc,
getInfo = includeCredsInfo c (davCreds u) $
[("url", fromMaybe "unknown" (M.lookup "url" c))]
}
chunkconfig = getChunkConfig c
@ -81,11 +83,11 @@ webdavSetup mu mcreds c = do
url <- case M.lookup "url" c of
Nothing -> error "Specify url="
Just url -> return url
c' <- encryptionSetup c
(c', encsetup) <- encryptionSetup c
creds <- maybe (getCreds c' u) (return . Just) mcreds
testDav url creds
gitConfigSpecialRemote u c' "webdav" "true"
c'' <- setRemoteCredPair c' (davCreds u) creds
c'' <- setRemoteCredPair encsetup c' (davCreds u) creds
return (c'', u)
-- Opens a http connection to the DAV server, which will be reused