1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
{- Web url logs.
-
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
module Logs.Web (
URLString,
getUrls,
getUrlsWithPrefix,
setUrlPresent,
setUrlMissing,
withKnownUrls,
Downloader(..),
getDownloader,
setDownloader,
setDownloader',
setTempUrl,
removeTempUrl,
) where
import qualified Data.Map as M
import Annex.Common
import qualified Annex
import Logs
import Logs.Presence
import Logs.Location
import qualified Annex.Branch
import qualified Git.LsTree
import Git.CatFile (catObjectStreamLsTree)
import Git.FilePath
import Utility.Url
import Annex.UUID
import qualified Types.Remote as Remote
{- Gets all urls that a key might be available from. -}
getUrls :: Key -> Annex [URLString]
getUrls key = do
config <- Annex.getGitConfig
l <- go $ urlLogFile config key : oldurlLogs config key
tmpl <- Annex.getState (maybeToList . M.lookup key . Annex.tempurls)
return (tmpl ++ l)
where
go [] = return []
go (l:ls) = do
us <- currentLogInfo l
if null us
then go ls
else return $ map (decodeBS . fromLogInfo) us
getUrlsWithPrefix :: Key -> String -> Annex [URLString]
getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`)
. map (fst . getDownloader)
<$> getUrls key
setUrlPresent :: Key -> URLString -> Annex ()
setUrlPresent key url = do
us <- getUrls key
unless (url `elem` us) $ do
config <- Annex.getGitConfig
addLog (urlLogFile config key)
=<< logNow InfoPresent (LogInfo (encodeBS url))
-- If the url does not have an OtherDownloader, it must be present
-- in the web.
case snd (getDownloader url) of
OtherDownloader -> return ()
_ -> logChange key webUUID InfoPresent
setUrlMissing :: Key -> URLString -> Annex ()
setUrlMissing key url = do
config <- Annex.getGitConfig
addLog (urlLogFile config key)
=<< logNow InfoMissing (LogInfo (encodeBS url))
-- If the url was a web url (not OtherDownloader) and none of
-- the remaining urls for the key are web urls, the key must not
-- be present in the web.
when (isweb url) $
whenM (null . filter isweb <$> getUrls key) $
logChange key webUUID InfoMissing
where
isweb u = case snd (getDownloader u) of
OtherDownloader -> False
_ -> True
{- Finds all known urls. -}
withKnownUrls :: (Annex (Maybe (Key, [URLString])) -> Annex a) -> Annex a
withKnownUrls a = do
{- Ensure any journalled changes are committed to the git-annex
- branch, since we're going to look at its tree. -}
_ <- Annex.Branch.update
Annex.Branch.commit =<< Annex.Branch.commitMessage
(l, cleanup) <- inRepo $ Git.LsTree.lsTree
Git.LsTree.LsTreeRecursive
Annex.Branch.fullname
g <- Annex.gitRepo
let want = urlLogFileKey . getTopFilePath . Git.LsTree.file
catObjectStreamLsTree l want g (\reader -> a (go reader))
`finally` void (liftIO cleanup)
where
go reader = liftIO reader >>= \case
Just (k, Just content) ->
case geturls content of
[] -> go reader
us -> return (Just (k, us))
Just (_, Nothing) -> go reader
Nothing -> return Nothing
geturls = map (decodeBS . fromLogInfo) . getLog
setTempUrl :: Key -> URLString -> Annex ()
setTempUrl key url = Annex.changeState $ \s ->
s { Annex.tempurls = M.insert key url (Annex.tempurls s) }
removeTempUrl :: Key -> Annex ()
removeTempUrl key = Annex.changeState $ \s ->
s { Annex.tempurls = M.delete key (Annex.tempurls s) }
data Downloader = WebDownloader | YoutubeDownloader | QuviDownloader | OtherDownloader
deriving (Eq, Show)
{- To keep track of how an url is downloaded, it's mangled slightly in
- the log, with a prefix indicating when a Downloader is used. -}
setDownloader :: URLString -> Downloader -> String
setDownloader u WebDownloader = u
setDownloader u QuviDownloader = "quvi:" ++ u
setDownloader u YoutubeDownloader = "yt:" ++ u
setDownloader u OtherDownloader = ":" ++ u
setDownloader' :: URLString -> Remote -> String
setDownloader' u r
| Remote.uuid r == webUUID = setDownloader u WebDownloader
| otherwise = setDownloader u OtherDownloader
getDownloader :: URLString -> (URLString, Downloader)
getDownloader u = case separate (== ':') u of
("yt", u') -> (u', YoutubeDownloader)
-- quvi is not used any longer; youtube-dl should be able to handle
-- all urls it did.
("quvi", u') -> (u', YoutubeDownloader)
("", u') -> (u', OtherDownloader)
_ -> (u, WebDownloader)
|
