export: cache connections for S3 and webdav
This commit is contained in:
Joey Hess
parent
7ad8e8b889
commit
9c3622882b
9 changed files with 98 additions and 90 deletions
|
|
@ -61,7 +61,7 @@ gen r u c gc = do
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = True
|
||||
, exportActions = ExportActions
|
||||
, exportActions = return $ ExportActions
|
||||
{ storeExport = storeExportDirectory dir
|
||||
, retrieveExport = retrieveExportDirectory dir
|
||||
, removeExport = removeExportDirectory dir
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ gen r u c gc
|
|||
avail <- getAvailability external r gc
|
||||
exportsupported <- checkExportSupported' external
|
||||
let exportactions = if exportsupported
|
||||
then ExportActions
|
||||
then return $ ExportActions
|
||||
{ storeExport = storeExportExternal external
|
||||
, retrieveExport = retrieveExportExternal external
|
||||
, removeExport = removeExportExternal external
|
||||
|
|
|
|||
|
|
@ -26,8 +26,8 @@ class HasExportUnsupported a where
|
|||
instance HasExportUnsupported (RemoteConfig -> RemoteGitConfig -> Annex Bool) where
|
||||
exportUnsupported = \_ _ -> return False
|
||||
|
||||
instance HasExportUnsupported (ExportActions Annex) where
|
||||
exportUnsupported = ExportActions
|
||||
instance HasExportUnsupported (Annex (ExportActions Annex)) where
|
||||
exportUnsupported = return $ ExportActions
|
||||
{ storeExport = \_ _ _ _ -> do
|
||||
warning "store export is unsupported"
|
||||
return False
|
||||
|
|
@ -103,7 +103,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
|
|||
[] -> do
|
||||
warning "unknown export location"
|
||||
return False
|
||||
(l:_) -> retrieveExport (exportActions r) k l dest p
|
||||
(l:_) -> do
|
||||
ea <- exportActions r
|
||||
retrieveExport ea k l dest p
|
||||
else do
|
||||
warning $ "exported content cannot be verified due to using the " ++ formatKeyVariety (keyVariety k) ++ " backend"
|
||||
return False
|
||||
|
|
@ -111,8 +113,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
|
|||
-- Remove all files a key was exported to.
|
||||
, removeKey = \k -> do
|
||||
locs <- liftIO $ getExportLocation db k
|
||||
ea <- exportActions r
|
||||
oks <- forM locs $ \loc -> do
|
||||
ok <- removeExport (exportActions r) k loc
|
||||
ok <- removeExport ea k loc
|
||||
when ok $
|
||||
liftIO $ removeExportLocation db k loc
|
||||
return ok
|
||||
|
|
@ -125,8 +128,9 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
|
|||
-- Check if any of the files a key was exported
|
||||
-- to are present. This doesn't guarantee the
|
||||
-- export contains the right content.
|
||||
, checkPresent = \k ->
|
||||
anyM (checkPresentExport (exportActions r) k)
|
||||
, checkPresent = \k -> do
|
||||
ea <- exportActions r
|
||||
anyM (checkPresentExport ea k)
|
||||
=<< liftIO (getExportLocation db k)
|
||||
, mkUnavailable = return Nothing
|
||||
, getInfo = do
|
||||
|
|
|
|||
46
Remote/S3.hs
46
Remote/S3.hs
|
|
@ -86,13 +86,14 @@ gen r u c gc = do
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportS3 this info
|
||||
, retrieveExport = retrieveExportS3 this info
|
||||
, removeExport = removeExportS3 this info
|
||||
, checkPresentExport = checkPresentExportS3 this info
|
||||
, renameExport = renameExportS3 this info
|
||||
}
|
||||
, exportActions = withS3Handle c gc u $ \h ->
|
||||
return $ ExportActions
|
||||
{ storeExport = storeExportS3 info h
|
||||
, retrieveExport = retrieveExportS3 info h
|
||||
, removeExport = removeExportS3 info h
|
||||
, checkPresentExport = checkPresentExportS3 info h
|
||||
, renameExport = renameExportS3 info h
|
||||
}
|
||||
, whereisKey = Just (getWebUrls info c)
|
||||
, remoteFsck = Nothing
|
||||
, repairRepo = Nothing
|
||||
|
|
@ -321,41 +322,40 @@ checkKeyHelper info h object = do
|
|||
| otherwise = Nothing
|
||||
#endif
|
||||
|
||||
storeExportS3 :: Remote -> S3Info -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportS3 r info f _k loc p =
|
||||
storeExportS3 :: S3Info -> S3Handle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportS3 info h f _k loc p =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
|
||||
go = do
|
||||
storeHelper info h f (T.pack $ bucketExportLocation info loc) p
|
||||
return True
|
||||
|
||||
retrieveExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 r info _k loc f p =
|
||||
retrieveExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportS3 info h _k loc f p =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
|
||||
go = do
|
||||
retrieveHelper info h (T.pack $ bucketExportLocation info loc) f p
|
||||
return True
|
||||
|
||||
removeExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 r info _k loc =
|
||||
removeExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportS3 info h _k loc =
|
||||
catchNonAsync go (\e -> warning (show e) >> return False)
|
||||
where
|
||||
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
|
||||
go = do
|
||||
res <- tryNonAsync $ sendS3Handle h $
|
||||
S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info)
|
||||
return $ either (const False) (const True) res
|
||||
|
||||
checkPresentExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportS3 r info _k loc =
|
||||
withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
|
||||
checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
|
||||
checkPresentExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportS3 info h _k loc =
|
||||
checkKeyHelper info h (T.pack $ bucketExportLocation info loc)
|
||||
|
||||
-- S3 has no move primitive; copy and delete.
|
||||
renameExportS3 :: Remote -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportS3 r info _k src dest = catchNonAsync go (\_ -> return False)
|
||||
renameExportS3 :: S3Info -> S3Handle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportS3 info h _k src dest = catchNonAsync go (\_ -> return False)
|
||||
where
|
||||
go = withS3Handle (config r) (gitconfig r) (uuid r) $ \h -> do
|
||||
go = do
|
||||
let co = S3.copyObject (bucket info) dstobject
|
||||
(S3.ObjectId (bucket info) srcobject Nothing)
|
||||
S3.CopyMetadata
|
||||
|
|
|
|||
|
|
@ -70,12 +70,12 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
|
|||
, lockContent = Nothing
|
||||
, checkPresent = checkPresentDummy
|
||||
, checkPresentCheap = False
|
||||
, exportActions = ExportActions
|
||||
{ storeExport = storeExportDav this
|
||||
, retrieveExport = retrieveExportDav this
|
||||
, removeExport = removeExportDav this
|
||||
, checkPresentExport = checkPresentExportDav this
|
||||
, renameExport = renameExportDav this
|
||||
, exportActions = withDAVHandle this $ \mh -> return $ ExportActions
|
||||
{ storeExport = storeExportDav mh
|
||||
, retrieveExport = retrieveExportDav mh
|
||||
, removeExport = removeExportDav mh
|
||||
, checkPresentExport = checkPresentExportDav this mh
|
||||
, renameExport = renameExportDav mh
|
||||
}
|
||||
, whereisKey = Nothing
|
||||
, remoteFsck = Nothing
|
||||
|
|
@ -178,37 +178,36 @@ checkKey r chunkconfig (Just dav) k = do
|
|||
existsDAV (keyLocation k)
|
||||
either giveup return v
|
||||
|
||||
storeExportDav :: Remote -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportDav r f _k loc p = runExport r $ \dav -> do
|
||||
storeExportDav :: Maybe DavHandle -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex Bool
|
||||
storeExportDav mh f _k loc p = runExport mh $ \dav -> do
|
||||
reqbody <- liftIO $ httpBodyStorer f p
|
||||
storeHelper dav (exportTmpLocation loc) (exportLocation loc) reqbody
|
||||
return True
|
||||
|
||||
retrieveExportDav :: Remote -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportDav r _k loc d p = runExport r $ \_dav -> do
|
||||
retrieveExportDav :: Maybe DavHandle -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Bool
|
||||
retrieveExportDav mh _k loc d p = runExport mh $ \_dav -> do
|
||||
retrieveHelper (exportLocation loc) d p
|
||||
return True
|
||||
|
||||
removeExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportDav r _k loc = runExport r $ \_dav ->
|
||||
removeExportDav :: Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
|
||||
removeExportDav mh _k loc = runExport mh $ \_dav ->
|
||||
removeHelper (exportLocation loc)
|
||||
|
||||
checkPresentExportDav :: Remote -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportDav r _k loc = withDAVHandle r $ \mh -> case mh of
|
||||
checkPresentExportDav :: Remote -> Maybe DavHandle -> Key -> ExportLocation -> Annex Bool
|
||||
checkPresentExportDav r mh _k loc = case mh of
|
||||
Nothing -> giveup $ name r ++ " not configured"
|
||||
Just h -> liftIO $ do
|
||||
v <- goDAV h $ existsDAV (exportLocation loc)
|
||||
either giveup return v
|
||||
|
||||
renameExportDav :: Remote -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportDav r _k src dest = runExport r $ \dav -> do
|
||||
renameExportDav :: Maybe DavHandle -> Key -> ExportLocation -> ExportLocation -> Annex Bool
|
||||
renameExportDav mh _k src dest = runExport mh $ \dav -> do
|
||||
moveDAV (baseURL dav) (exportLocation src) (exportLocation dest)
|
||||
return True
|
||||
|
||||
runExport :: Remote -> (DavHandle -> DAVT IO Bool) -> Annex Bool
|
||||
runExport r a = withDAVHandle r $ \mh -> case mh of
|
||||
Nothing -> return False
|
||||
Just h -> fromMaybe False <$> liftIO (goDAV h $ safely (a h))
|
||||
runExport :: Maybe DavHandle -> (DavHandle -> DAVT IO Bool) -> Annex Bool
|
||||
runExport Nothing _ = return False
|
||||
runExport (Just h) a = fromMaybe False <$> liftIO (goDAV h $ safely (a h))
|
||||
|
||||
configUrl :: Remote -> Maybe URLString
|
||||
configUrl r = fixup <$> M.lookup "url" (config r)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue