git-annex/Remote/Web.hs

274 lines
8.4 KiB
Haskell
Raw Normal View History

{- Web remote.
-
- Copyright 2011-2024 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 Types.ProposedAccepted
import Types.Creds
import Types.Key
import Remote.Helper.Special
2019-02-20 19:55:01 +00:00
import Remote.Helper.ExportImport
import qualified Git
import qualified Git.Construct
import Annex.Content
import Annex.Verify
import Config.Cost
import Config
import Logs.Web
2014-12-17 17:57:52 +00:00
import Annex.UUID
import Utility.Metered
import Utility.Glob
import qualified Annex.Url as Url
import Annex.YoutubeDl
import Annex.SpecialRemote.Config
import Logs.Remote
import Logs.EquivilantKeys
import Backend
import Backend.VURL.Utilities (generateEquivilantKey)
import qualified Data.Map as M
2011-12-31 08:11:39 +00:00
remote :: RemoteType
remote = RemoteType
{ typename = "web"
, enumerate = list
, generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser urlincludeField
(FieldDesc "only use urls matching this glob")
, optionalStringParser urlexcludeField
(FieldDesc "don't use urls that match this glob")
]
, setup = setupInstance
, exportSupported = exportUnsupported
2019-02-20 19:55:01 +00:00
, importSupported = importUnsupported
add thirdPartyPopulated interface This is to support, eg a borg repo as a special remote, which is populated not by running git-annex commands, but by using borg. Then git-annex sync lists the content of the remote, learns which files are annex objects, and treats those as present in the remote. So, most of the import machinery is reused, to a new purpose. While normally importtree maintains a remote tracking branch, this does not, because the files stored in the remote are annex object files, not user-visible filenames. But, internally, a git tree is still generated, of the files on the remote that are annex objects. This tree is used by retrieveExportWithContentIdentifier, etc. As with other import/export remotes, that the tree is recorded in the export log, and gets grafted into the git-annex branch. importKey changed to be able to return Nothing, to indicate when an ImportLocation is not an annex object and so should be skipped from being included in the tree. It did not seem to make sense to have git-annex import do this, since from the user's perspective, it's not like other imports. So only git-annex sync does it. Note that, git-annex sync does not yet download objects from such remotes that are preferred content. importKeys is run with content downloading disabled, to avoid getting the content of all objects. Perhaps what's needed is for seekSyncContent to be run with these remotes, but I don't know if it will just work (in particular, it needs to avoid trying to transfer objects to them), so I skipped that for now. (Untested and unused as of yet.) This commit was sponsored by Jochen Bartl on Patreon.
2020-12-18 18:52:57 +00:00
, thirdPartyPopulated = False
}
-- The web remote always exists.
-- (If the web should cease to exist, remove this module and redistribute
-- a new release to the survivors by carrier pigeon.)
--
-- There may also be other instances of the web remote, which can be
-- limited to accessing particular urls, and have different costs.
list :: Bool -> Annex [Git.Repo]
list _autoinit = do
2015-02-12 19:33:05 +00:00
r <- liftIO $ Git.Construct.remoteNamed "web" (pure Git.Construct.fromUnknown)
others <- findSpecialRemotes "web"
-- List the main one last, this makes its name be used instead
-- of the other names when git-annex is referring to content on the
-- web.
return (others++[r])
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u rc gc rs = do
c <- parsedRemoteConfig remote rc
2023-01-12 17:18:25 +00:00
cst <- remoteCost gc c expensiveRemoteCost
urlincludeexclude <- mkUrlIncludeExclude c
2014-12-16 19:26:13 +00:00
return $ Just Remote
{ uuid = if u == NoUUID then webUUID else u
, cost = cst
2014-12-16 19:26:13 +00:00
, name = Git.repoDescribe r
, storeKey = uploadKey
, retrieveKeyFile = downloadKey urlincludeexclude
, retrieveKeyFileCheap = Nothing
-- HttpManagerRestricted is used here, so this is
-- secure.
, retrievalSecurityPolicy = RetrievalAllKeysSecure
, removeKey = dropKey urlincludeexclude
, lockContent = Nothing
, checkPresent = checkKey urlincludeexclude
2014-12-16 19:26:13 +00:00
, checkPresentCheap = False
, exportActions = exportUnsupported
2019-02-20 19:55:01 +00:00
, importActions = importUnsupported
, whereisKey = Nothing
2014-12-16 19:26:13 +00:00
, remoteFsck = Nothing
, repairRepo = Nothing
, config = c
, gitconfig = gc
, localpath = Nothing
, getRepo = return r
2014-12-16 19:26:13 +00:00
, readonly = True
, appendonly = False
, untrustworthy = False
, availability = pure GloballyAvailable
2014-12-16 19:26:13 +00:00
, remotetype = remote
, mkUnavailable = return Nothing
, getInfo = return []
-- claimingUrl makes the web special remote claim
-- urls that are not claimed by other remotes,
-- so no need to claim anything here.
, claimUrl = Nothing
2014-12-16 19:26:13 +00:00
, checkUrl = Nothing
, remoteStateHandle = rs
2014-12-16 19:26:13 +00:00
}
setupInstance :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
setupInstance _ mu _ c _ = do
u <- maybe (liftIO genUUID) return mu
gitConfigSpecialRemote u c [("web", "true")]
return (c, u)
downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification
downloadKey urlincludeexclude key _af dest p vc =
go =<< getWebUrls' urlincludeexclude key
2012-11-11 04:51:07 +00:00
where
go [] = giveup "no known url"
go urls = dl (partition (not . isyoutube) (map getDownloader urls)) >>= \case
Just v -> return v
Nothing -> giveup $ unwords
[ "downloading from all"
, show (length urls)
, "known url(s) failed"
]
isyoutube (_, YoutubeDownloader) = True
isyoutube _ = False
dl ([], ytus) = flip getM (map fst ytus) $ \u ->
ifM (youtubeDlTo key u dest p)
( postdl UnVerified
, return Nothing
)
dl (us, ytus) = do
iv <- startVerifyKeyContentIncrementally vc key
ifM (Url.withUrlOptions $ downloadUrl True key p iv (map fst us) dest)
( finishVerifyKeyContentIncrementally iv >>= \case
(True, v) -> postdl v
(False, _) -> dl ([], ytus)
, dl ([], ytus)
)
postdl v@Verified = return (Just v)
postdl v
-- For a VURL key that was not verified on download,
-- need to generate a hashed key for the content downloaded
-- from the web, and record it for later use verifying this
-- content.
--
-- But when the VURL key has a known size, and already has a
-- recorded hashed key, don't record a new key, since the
-- content on the web is expected to be stable for such a key.
| fromKey keyVariety key == VURLKey =
case fromKey keySize key of
Nothing ->
getEquivilantKeys key
>>= recordvurlkey
Just _ -> do
eks <- getEquivilantKeys key
if null eks
then recordvurlkey eks
else return (Just v)
| otherwise = return (Just v)
recordvurlkey eks = do
-- Make sure to pick a backend that is cryptographically
-- secure.
db <- defaultBackend
let b = if isCryptographicallySecure db
then db
else defaultHashBackend
generateEquivilantKey b (toRawFilePath dest) >>= \case
Nothing -> return Nothing
Just ek -> do
unless (ek `elem` eks) $
setEquivilantKey key ek
return (Just Verified)
uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex ()
uploadKey _ _ _ _ = giveup "upload to web not supported"
toward SafeDropProof expiry checking Added Maybe POSIXTime to SafeDropProof, which gets set when the proof is based on a LockedCopy. If there are several LockedCopies, it uses the closest expiry time. That is not optimal, it may be that the proof expires based on one LockedCopy but another one has not expired. But that seems unlikely to really happen, and anyway the user can just re-run a drop if it fails due to expiry. Pass the SafeDropProof to removeKey, which is responsible for checking it for expiry in situations where that could be a problem. Which really only means in Remote.Git. Made Remote.Git check expiry when dropping from a local remote. Checking expiry when dropping from a P2P remote is not yet implemented. P2P.Protocol.remove has SafeDropProof plumbed through to it for that purpose. Fixing the remaining 2 build warnings should complete this work. Note that the use of a POSIXTime here means that if the clock gets set forward while git-annex is in the middle of a drop, it may say that dropping took too long. That seems ok. Less ok is that if the clock gets turned back a sufficient amount (eg 5 minutes), proof expiry won't be noticed. It might be better to use the Monotonic clock, but that doesn't advance when a laptop is suspended, and while there is the linux Boottime clock, that is not available on other systems. Perhaps a combination of POSIXTime and the Monotonic clock could detect laptop suspension and also detect clock being turned back? There is a potential future flag day where p2pDefaultLockContentRetentionDuration is not assumed, but is probed using the P2P protocol, and peers that don't support it can no longer produce a LockedCopy. Until that happens, when git-annex is communicating with older peers there is a risk of data loss when a ssh connection closes during LOCKCONTENT.
2024-07-04 16:23:46 +00:00
dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex ()
dropKey urlincludeexclude _proof k = mapM_ (setUrlMissing k) =<< getWebUrls' urlincludeexclude k
checkKey :: UrlIncludeExclude -> Key -> Annex Bool
checkKey urlincludeexclude key = do
us <- getWebUrls' urlincludeexclude key
if null us
then return False
else either giveup return =<< checkKey' key us
2013-09-09 06:16:22 +00:00
checkKey' :: Key -> [URLString] -> Annex (Either String Bool)
checkKey' key us = firsthit us (Right False) $ \u -> do
let (u', downloader) = getDownloader u
case downloader of
YoutubeDownloader -> youtubeDlCheck u'
_ -> catchMsgIO $
Url.withUrlOptions $ Url.checkBoth u' (fromKey keySize key)
2013-09-09 06:16:22 +00:00
where
firsthit [] miss _ = return miss
2013-09-09 06:16:22 +00:00
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 = getWebUrls' alwaysInclude key
getWebUrls' :: UrlIncludeExclude -> Key -> Annex [URLString]
getWebUrls' urlincludeexclude key =
filter supported <$> getUrls key
where
supported u = supporteddownloader u
&& checkUrlIncludeExclude urlincludeexclude u
supporteddownloader u = snd (getDownloader u)
`elem` [WebDownloader, YoutubeDownloader]
urlincludeField :: RemoteConfigField
urlincludeField = Accepted "urlinclude"
urlexcludeField :: RemoteConfigField
urlexcludeField = Accepted "urlexclude"
data UrlIncludeExclude = UrlIncludeExclude
{ checkUrlIncludeExclude :: URLString -> Bool
}
alwaysInclude :: UrlIncludeExclude
alwaysInclude = UrlIncludeExclude { checkUrlIncludeExclude = const True }
mkUrlIncludeExclude :: ParsedRemoteConfig -> Annex UrlIncludeExclude
mkUrlIncludeExclude = go fallback
where
go b pc = case (getglob urlincludeField pc, getglob urlexcludeField pc) of
(Nothing, Nothing) -> b
(minclude, mexclude) -> mk minclude mexclude
getglob f pc = do
glob <- getRemoteConfigValue f pc
2023-03-13 23:06:23 +00:00
Just $ compileGlob glob CaseInsensitive (GlobFilePath False)
mk minclude mexclude = pure $ UrlIncludeExclude
{ checkUrlIncludeExclude = \u -> and
[ case minclude of
Just glob -> matchGlob glob u
Nothing -> True
, case mexclude of
Nothing -> True
Just glob -> not (matchGlob glob u)
]
}
-- When nothing to include or exclude is specified, only include
-- urls that are not explicitly included by other web special remotes.
fallback = do
rcs <- M.elems . M.filter iswebremote <$> remoteConfigMap
l <- forM rcs $ \rc ->
parsedRemoteConfig remote rc
>>= go (pure neverinclude)
pure $ UrlIncludeExclude
{ checkUrlIncludeExclude = \u ->
not (any (\c -> checkUrlIncludeExclude c u) l)
}
iswebremote rc = (fromProposedAccepted <$> M.lookup typeField rc)
== Just (typename remote)
neverinclude = UrlIncludeExclude { checkUrlIncludeExclude = const False }