git-annex/Remote/Web.hs
Joey Hess 1ffb3bb0ba add remote fsck interface
Currently only implemented for local git remotes. May try to add support
to git-annex-shell for ssh remotes later. Could concevably also be
supported by some special remote, although that seems unlikely.

Cronner user this when available, and when not falls back to
fsck --fast --from remote

git annex fsck --from does not itself use this interface.
To do so, I would need to pass --fast and all other options that influence
fsck on to the git annex fsck that it runs inside the remote. And that
seems like a lot of work for a result that would be no better than
cd remote; git annex fsck
This may need to be revisited if git-annex-shell gets support, since it
may be the case that the user cannot ssh to the server to run git-annex
fsck there, but can run git-annex-shell there.

This commit was sponsored by Damien Diederen.
2013-10-11 16:03:18 -04:00

129 lines
3.2 KiB
Haskell

{- Web remotes.
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Remote.Web (remote) where
import Common.Annex
import Types.Remote
import qualified Git
import qualified Git.Construct
import Annex.Content
import Config
import Config.Cost
import Logs.Web
import Types.Key
import Utility.Metered
import qualified Annex.Url as Url
#ifdef WITH_QUVI
import Annex.Quvi
import qualified Utility.Quvi as Quvi
#endif
import qualified Data.Map as M
remote :: RemoteType
remote = RemoteType {
typename = "web",
enumerate = list,
generate = gen,
setup = error "not supported"
}
-- There is only one web remote, and it always exists.
-- (If the web should cease to exist, remove this module and redistribute
-- a new release to the survivors by carrier pigeon.)
list :: Annex [Git.Repo]
list = do
r <- liftIO $ Git.Construct.remoteNamed "web" Git.Construct.fromUnknown
return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r _ _ gc =
return $ Just Remote {
uuid = webUUID,
cost = expensiveRemoteCost,
name = Git.repoDescribe r,
storeKey = uploadKey,
retrieveKeyFile = downloadKey,
retrieveKeyFileCheap = downloadKeyCheap,
removeKey = dropKey,
hasKey = checkKey,
hasKeyCheap = False,
whereisKey = Just getUrls,
remoteFsck = Nothing,
config = M.empty,
gitconfig = gc,
localpath = Nothing,
repo = r,
readonly = True,
globallyAvailable = True,
remotetype = remote
}
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
downloadKey key _file dest _p = get =<< getUrls key
where
get [] = do
warning "no known url"
return False
get urls = do
showOutput -- make way for download progress bar
untilTrue urls $ \u -> do
let (u', downloader) = getDownloader u
case downloader of
QuviDownloader -> do
#ifdef WITH_QUVI
flip downloadUrl dest
=<< withQuviOptions Quvi.queryLinks [Quvi.httponly, Quvi.quiet] u'
#else
warning "quvi support needed for this url"
return False
#endif
DefaultDownloader -> downloadUrl [u'] dest
downloadKeyCheap :: Key -> FilePath -> Annex Bool
downloadKeyCheap _ _ = return False
uploadKey :: Key -> AssociatedFile -> MeterUpdate -> Annex Bool
uploadKey _ _ _ = do
warning "upload to web not supported"
return False
dropKey :: Key -> Annex Bool
dropKey k = do
mapM_ (setUrlMissing k) =<< getUrls k
return True
checkKey :: Key -> Annex (Either String Bool)
checkKey key = do
us <- getUrls key
if null us
then return $ Right False
else return =<< checkKey' key us
checkKey' :: Key -> [URLString] -> Annex (Either String Bool)
checkKey' key us = firsthit us (Right False) $ \u -> do
let (u', downloader) = getDownloader u
showAction $ "checking " ++ u'
case downloader of
QuviDownloader ->
#ifdef WITH_QUVI
Right <$> withQuviOptions Quvi.check [Quvi.httponly, Quvi.quiet] u'
#else
return $ Left "quvi support needed for this url"
#endif
DefaultDownloader -> do
headers <- getHttpHeaders
Right <$> Url.withUserAgent (Url.checkBoth u' headers $ keySize key)
where
firsthit [] miss _ = return miss
firsthit (u:rest) _ a = do
r <- a u
case r of
Right _ -> return r
Left _ -> firsthit rest r a