b4cf22a388
I tend to prefer moving toward explicit exception handling, not away from it, but in this case, I think there are good reasons to let checkPresent throw exceptions: 1. They can all be caught in one place (Remote.hasKey), and we know every possible exception is caught there now, which we didn't before. 2. It simplified the code of the Remotes. I think it makes sense for Remotes to be able to be implemented without needing to worry about catching exceptions inside them. (Mostly.) 3. Types.StoreRetrieve.Preparer can only work on things that return a Bool, which all the other relevant remote methods already did. I do not see a good way to generalize that type; my previous attempts failed miserably.
127 lines
3.2 KiB
Haskell
127 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.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
|
|
|
|
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 _ 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 getUrls,
|
|
remoteFsck = Nothing,
|
|
repairRepo = Nothing,
|
|
config = c,
|
|
gitconfig = gc,
|
|
localpath = Nothing,
|
|
repo = r,
|
|
readonly = True,
|
|
availability = GloballyAvailable,
|
|
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 Bool
|
|
checkKey key = do
|
|
us <- getUrls key
|
|
if null us
|
|
then return False
|
|
else either error 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
|
|
Url.withUrlOptions $ catchMsgIO .
|
|
Url.checkBoth u' (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
|