git-annex/Remote/Web.hs

{- 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
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
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

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
	, importSupported = importUnsupported
	, 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
	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
	cst <- remoteCost gc c expensiveRemoteCost
 	urlincludeexclude <- mkUrlIncludeExclude c
	return $ Just Remote
		{ uuid = if u == NoUUID then webUUID else u
		, cost = cst
		, 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
		, 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
		, untrustworthy = False
		, availability = pure GloballyAvailable
		, 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
		, checkUrl = Nothing
		, remoteStateHandle = rs
		}

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
  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"

dropKey :: UrlIncludeExclude -> Key -> Annex ()
dropKey urlincludeexclude 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
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)
  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 = 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
		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 }