git-annex/Remote/Web.hs
Joey Hess 9828f45d85
add RemoteStateHandle
This solves the problem of sameas remotes trampling over per-remote
state. Used for:

* per-remote state, of course
* per-remote metadata, also of course
* per-remote content identifiers, because two remote implementations
  could in theory generate the same content identifier for two different
  peices of content

While chunk logs are per-remote data, they don't use this, because the
number and size of chunks stored is a common property across sameas
remotes.

External special remote had a complication, where it was theoretically
possible for a remote to send SETSTATE or GETSTATE during INITREMOTE or
EXPORTSUPPORTED. Since the uuid of the remote is typically generate in
Remote.setup, it would only be possible to pass a Maybe
RemoteStateHandle into it, and it would otherwise have to construct its
own. Rather than go that route, I decided to send an ERROR in this case.
It seems unlikely that any existing external special remote will be
affected. They would have to make up a git-annex key, and set state for
some reason during INITREMOTE. I can imagine such a hack, but it doesn't
seem worth complicating the code in such an ugly way to support it.

Unfortunately, both TestRemote and Annex.Import needed the Remote
to have a new field added that holds its RemoteStateHandle.
2019-10-14 13:51:42 -04:00

134 lines
3.6 KiB
Haskell

{- Web remote.
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Remote.Web (remote, getWebUrls) where
import Annex.Common
import Types.Remote
import Remote.Helper.Messages
import Remote.Helper.ExportImport
import qualified Git
import qualified Git.Construct
import Annex.Content
import Config.Cost
import Config
import Logs.Web
import Annex.UUID
import Utility.Metered
import qualified Annex.Url as Url
import Annex.YoutubeDl
remote :: RemoteType
remote = RemoteType
{ typename = "web"
, enumerate = list
, generate = gen
, setup = error "not supported"
, exportSupported = exportUnsupported
, importSupported = importUnsupported
}
-- 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 :: Bool -> Annex [Git.Repo]
list _autoinit = do
r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)
return [r]
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r _ c gc rs = do
cst <- remoteCost gc expensiveRemoteCost
return $ Just Remote
{ uuid = webUUID
, cost = cst
, name = Git.repoDescribe r
, storeKey = uploadKey
, retrieveKeyFile = downloadKey
, retrieveKeyFileCheap = downloadKeyCheap
-- HttpManagerRestricted is used here, so this is
-- secure.
, retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = dropKey
, lockContent = Nothing
, checkPresent = checkKey
, checkPresentCheap = False
, exportActions = exportUnsupported
, importActions = importUnsupported
, whereisKey = Nothing
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, gitconfig = gc
, localpath = Nothing
, getRepo = return r
, readonly = True
, appendonly = False
, availability = GloballyAvailable
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return []
, claimUrl = Nothing -- implicitly claims all urls
, checkUrl = Nothing
, remoteStateHandle = rs
}
downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
downloadKey key _af dest p = unVerified $ get =<< getWebUrls key
where
get [] = do
warning "no known url"
return False
get urls = untilTrue urls $ \u -> do
let (u', downloader) = getDownloader u
case downloader of
YoutubeDownloader -> do
showOutput
youtubeDlTo key u' dest
_ -> downloadUrl key p [u'] dest
downloadKeyCheap :: Key -> AssociatedFile -> 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) =<< getWebUrls k
return True
checkKey :: Key -> Annex Bool
checkKey key = do
us <- getWebUrls key
if null us
then return False
else either giveup 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
showChecking u'
case downloader of
YoutubeDownloader -> youtubeDlCheck u'
_ -> do
Url.withUrlOptions $ liftIO . catchMsgIO .
Url.checkBoth u' (keySize key)
where
firsthit [] miss _ = return miss
firsthit (u:rest) _ a = do
r <- a u
case r of
Right True -> return r
_ -> firsthit rest r a
getWebUrls :: Key -> Annex [URLString]
getWebUrls key = filter supported <$> getUrls key
where
supported u = snd (getDownloader u)
`elem` [WebDownloader, YoutubeDownloader]