This commit is contained in:
Joey Hess 2014-12-16 15:26:13 -04:00
parent c64ede23cd
commit 65bce2c80d
8 changed files with 206 additions and 206 deletions

View file

@ -46,32 +46,32 @@ gen r u c gc = do
(retrieve dir chunkconfig)
(simplyPrepare $ remove dir)
(simplyPrepare $ checkKey dir chunkconfig)
Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap dir chunkconfig,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = True,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
config = c,
repo = r,
gitconfig = gc,
localpath = Just dir,
readonly = False,
availability = LocallyAvailable,
remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexDirectory = Just "/dev/null" },
getInfo = return [("directory", dir)],
claimUrl = Nothing,
checkUrl = Nothing
}
Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap dir chunkconfig
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = True
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, repo = r
, gitconfig = gc
, localpath = Just dir
, readonly = False
, availability = LocallyAvailable
, remotetype = remote
, mkUnavailable = gen r u c $
gc { remoteAnnexDirectory = Just "/dev/null" }
, getInfo = return [("directory", dir)]
, claimUrl = Nothing
, checkUrl = Nothing
}
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc

View file

@ -48,32 +48,32 @@ gen r u c gc = do
(simplyPrepare $ retrieve external)
(simplyPrepare $ remove external)
(simplyPrepare $ checkKey external)
Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
config = c,
localpath = Nothing,
repo = r,
gitconfig = gc,
readonly = False,
availability = avail,
remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexExternalType = Just "!dne!" },
getInfo = return [("externaltype", externaltype)],
claimUrl = Just (claimurl external),
checkUrl = Just (checkurl external)
}
Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = \_ _ -> return False
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, localpath = Nothing
, repo = r
, gitconfig = gc
, readonly = False
, availability = avail
, remotetype = remote
, mkUnavailable = gen r u c $
gc { remoteAnnexExternalType = Just "!dne!" }
, getInfo = return [("externaltype", externaltype)]
, claimUrl = Just (claimurl external)
, checkUrl = Just (checkurl external)
}
where
externaltype = fromMaybe (error "missing externaltype") (remoteAnnexExternalType gc)

View file

@ -46,32 +46,32 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
(simplyPrepare $ checkKey this)
this
where
this = Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap this,
removeKey = removeKeyDummy,
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 = return Nothing,
getInfo = includeCredsInfo c (AWS.creds u) $
[ ("glacier vault", getVault c) ],
claimUrl = Nothing,
checkUrl = Nothing
}
this = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap this
, removeKey = removeKeyDummy
, 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 = return Nothing
, getInfo = includeCredsInfo c (AWS.creds u) $
[ ("glacier vault", getVault c) ]
, claimUrl = Nothing
, checkUrl = Nothing
}
specialcfg = (specialRemoteCfg c)
-- Disabled until jobList gets support for chunks.
{ chunkConfig = NoChunks

View file

@ -39,32 +39,32 @@ gen r u c gc = do
(simplyPrepare $ retrieve hooktype)
(simplyPrepare $ remove hooktype)
(simplyPrepare $ checkKey r hooktype)
Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap hooktype,
removeKey = removeKeyDummy,
checkPresent = checkPresentDummy,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
config = c,
localpath = Nothing,
repo = r,
gitconfig = gc,
readonly = False,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = gen r u c $
gc { remoteAnnexHookType = Just "!dne!" },
getInfo = return [("hooktype", hooktype)],
claimUrl = Nothing,
checkUrl = Nothing
}
Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap hooktype
, removeKey = removeKeyDummy
, checkPresent = checkPresentDummy
, checkPresentCheap = False
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, localpath = Nothing
, repo = r
, gitconfig = gc
, readonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = gen r u c $
gc { remoteAnnexHookType = Just "!dne!" }
, getInfo = return [("hooktype", hooktype)]
, claimUrl = Nothing
, checkUrl = Nothing
}
where
hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc

View file

@ -65,37 +65,37 @@ gen r u c gc = do
(prepareS3 this info $ checkKey this)
this
where
this = Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = storeKeyDummy,
retrieveKeyFile = retreiveKeyFileDummy,
retrieveKeyFileCheap = retrieveCheap,
removeKey = removeKeyDummy,
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 "host" "!dne!" c) gc,
getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes
this = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = removeKeyDummy
, 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 "host" "!dne!" c) gc
, getInfo = includeCredsInfo c (AWS.creds u) $ catMaybes
[ Just ("bucket", fromMaybe "unknown" (getBucketName c))
, if configIA c
then Just ("internet archive item", iaItemUrl $ fromMaybe "unknown" $ getBucketName c)
else Nothing
, Just ("partsize", maybe "unlimited" (roughSize storageUnits False) (getPartSize c))
],
claimUrl = Nothing,
checkUrl = Nothing
}
]
, claimUrl = Nothing
, checkUrl = Nothing
}
s3Setup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
s3Setup mu mcreds c = do

View file

@ -64,31 +64,31 @@ gen r u c gc = do
hdl <- liftIO $ TahoeHandle
<$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
<*> newEmptyTMVarIO
return $ Just $ Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
storeKey = store u hdl,
retrieveKeyFile = retrieve u hdl,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = remove,
checkPresent = checkKey u hdl,
checkPresentCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
repairRepo = Nothing,
config = c,
repo = r,
gitconfig = gc,
localpath = Nothing,
readonly = False,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = return Nothing,
getInfo = return [],
claimUrl = Nothing,
checkUrl = Nothing
}
return $ Just $ Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = store u hdl
, retrieveKeyFile = retrieve u hdl
, retrieveKeyFileCheap = \_ _ -> return False
, removeKey = remove
, checkPresent = checkKey u hdl
, checkPresentCheap = False
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, repo = r
, gitconfig = gc
, localpath = Nothing
, readonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return []
, claimUrl = Nothing
, checkUrl = Nothing
}
tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu _ c = do

View file

@ -42,31 +42,31 @@ list = do
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r _ c gc =
return $ Just Remote {
uuid = webUUID,
cost = expensiveRemoteCost,
name = Git.repoDescribe r,
storeKey = uploadKey,
retrieveKeyFile = downloadKey,
retrieveKeyFileCheap = downloadKeyCheap,
removeKey = dropKey,
checkPresent = checkKey,
checkPresentCheap = False,
whereisKey = Just getWebUrls,
remoteFsck = Nothing,
repairRepo = Nothing,
config = c,
gitconfig = gc,
localpath = Nothing,
repo = r,
readonly = True,
availability = GloballyAvailable,
remotetype = remote,
mkUnavailable = return Nothing,
getInfo = return [],
claimUrl = Nothing, -- implicitly claims all urls
checkUrl = Nothing
}
return $ Just Remote
{ uuid = webUUID
, cost = expensiveRemoteCost
, name = Git.repoDescribe r
, storeKey = uploadKey
, retrieveKeyFile = downloadKey
, retrieveKeyFileCheap = downloadKeyCheap
, removeKey = dropKey
, checkPresent = checkKey
, checkPresentCheap = False
, whereisKey = Just getWebUrls
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, gitconfig = gc
, localpath = Nothing
, repo = r
, readonly = True
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return []
, claimUrl = Nothing -- implicitly claims all urls
, checkUrl = Nothing
}
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
downloadKey key _file dest _p = get =<< getWebUrls key

View file

@ -51,32 +51,32 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
(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,
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
}
this = Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retreiveKeyFileDummy
, retrieveKeyFileCheap = retrieveCheap
, removeKey = removeKeyDummy
, 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 -> Annex (RemoteConfig, UUID)