2011-10-15 20:25:51 +00:00
|
|
|
{- Web url logs.
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2011-2014 Joey Hess <id@joeyh.name>
|
2011-10-15 20:25:51 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
module Logs.Web (
|
|
|
|
URLString,
|
2012-11-29 21:01:07 +00:00
|
|
|
getUrls,
|
2014-12-08 17:32:27 +00:00
|
|
|
getUrlsWithPrefix,
|
2011-10-15 20:36:56 +00:00
|
|
|
setUrlPresent,
|
2012-11-29 21:01:07 +00:00
|
|
|
setUrlMissing,
|
2013-08-22 22:25:21 +00:00
|
|
|
knownUrls,
|
|
|
|
Downloader(..),
|
|
|
|
getDownloader,
|
|
|
|
setDownloader,
|
2016-01-19 19:55:32 +00:00
|
|
|
setDownloader',
|
2014-12-08 23:14:24 +00:00
|
|
|
setTempUrl,
|
|
|
|
removeTempUrl,
|
2011-10-15 20:25:51 +00:00
|
|
|
) where
|
|
|
|
|
2013-07-28 19:27:36 +00:00
|
|
|
import qualified Data.ByteString.Lazy.Char8 as L
|
2014-12-08 23:14:24 +00:00
|
|
|
import qualified Data.Map as M
|
2013-07-28 19:27:36 +00:00
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2014-12-08 23:14:24 +00:00
|
|
|
import qualified Annex
|
2013-08-29 22:51:22 +00:00
|
|
|
import Logs
|
2011-10-15 20:25:51 +00:00
|
|
|
import Logs.Presence
|
|
|
|
import Logs.Location
|
2013-07-28 19:27:36 +00:00
|
|
|
import qualified Annex.Branch
|
|
|
|
import Annex.CatFile
|
|
|
|
import qualified Git
|
|
|
|
import qualified Git.LsFiles
|
2014-12-08 17:40:15 +00:00
|
|
|
import Utility.Url
|
2016-01-19 19:55:32 +00:00
|
|
|
import Annex.UUID
|
|
|
|
import qualified Types.Remote as Remote
|
2011-10-15 20:25:51 +00:00
|
|
|
|
2011-10-15 20:36:56 +00:00
|
|
|
{- Gets all urls that a key might be available from. -}
|
2011-10-15 20:25:51 +00:00
|
|
|
getUrls :: Key -> Annex [URLString]
|
2014-12-08 23:14:24 +00:00
|
|
|
getUrls key = do
|
2015-01-28 21:17:26 +00:00
|
|
|
config <- Annex.getGitConfig
|
|
|
|
l <- go $ urlLogFile config key : oldurlLogs config key
|
2014-12-08 23:14:24 +00:00
|
|
|
tmpl <- Annex.getState (maybeToList . M.lookup key . Annex.tempurls)
|
|
|
|
return (tmpl ++ l)
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
|
|
|
go [] = return []
|
|
|
|
go (l:ls) = do
|
2015-04-01 21:53:16 +00:00
|
|
|
us <- currentLogInfo l
|
2012-11-11 04:51:07 +00:00
|
|
|
if null us
|
|
|
|
then go ls
|
|
|
|
else return us
|
2011-10-15 20:25:51 +00:00
|
|
|
|
2014-12-08 17:32:27 +00:00
|
|
|
getUrlsWithPrefix :: Key -> String -> Annex [URLString]
|
2015-03-27 22:49:03 +00:00
|
|
|
getUrlsWithPrefix key prefix = filter (prefix `isPrefixOf`)
|
|
|
|
. map (fst . getDownloader)
|
|
|
|
<$> getUrls key
|
2014-12-08 17:32:27 +00:00
|
|
|
|
2014-12-08 23:14:24 +00:00
|
|
|
setUrlPresent :: UUID -> Key -> URLString -> Annex ()
|
|
|
|
setUrlPresent uuid key url = do
|
2011-10-15 20:25:51 +00:00
|
|
|
us <- getUrls key
|
2015-01-28 21:17:26 +00:00
|
|
|
unless (url `elem` us) $ do
|
|
|
|
config <- Annex.getGitConfig
|
|
|
|
addLog (urlLogFile config key) =<< logNow InfoPresent url
|
2014-12-29 18:22:47 +00:00
|
|
|
logChange key uuid InfoPresent
|
2011-10-15 20:36:56 +00:00
|
|
|
|
2014-12-08 23:14:24 +00:00
|
|
|
setUrlMissing :: UUID -> Key -> URLString -> Annex ()
|
|
|
|
setUrlMissing uuid key url = do
|
2015-01-28 21:17:26 +00:00
|
|
|
config <- Annex.getGitConfig
|
|
|
|
addLog (urlLogFile config key) =<< logNow InfoMissing url
|
2013-04-22 21:18:53 +00:00
|
|
|
whenM (null <$> getUrls key) $
|
2014-12-08 23:14:24 +00:00
|
|
|
logChange key uuid InfoMissing
|
2013-07-28 19:27:36 +00:00
|
|
|
|
|
|
|
{- Finds all known urls. -}
|
2015-03-31 17:29:51 +00:00
|
|
|
knownUrls :: Annex [(Key, URLString)]
|
2013-07-28 19:27:36 +00:00
|
|
|
knownUrls = do
|
|
|
|
{- Ensure the git-annex branch's index file is up-to-date and
|
|
|
|
- any journaled changes are reflected in it, since we're going
|
|
|
|
- to query its index directly. -}
|
|
|
|
Annex.Branch.update
|
2018-08-02 18:06:06 +00:00
|
|
|
Annex.Branch.commit =<< Annex.Branch.commitMessage
|
2013-07-28 19:27:36 +00:00
|
|
|
Annex.Branch.withIndex $ do
|
|
|
|
top <- fromRepo Git.repoPath
|
|
|
|
(l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top]
|
2015-03-31 17:29:51 +00:00
|
|
|
r <- mapM getkeyurls l
|
2013-07-28 19:27:36 +00:00
|
|
|
void $ liftIO cleanup
|
|
|
|
return $ concat r
|
|
|
|
where
|
2015-03-31 17:29:51 +00:00
|
|
|
getkeyurls (f, s, _) = case urlLogFileKey f of
|
|
|
|
Just k -> zip (repeat k) <$> geturls s
|
|
|
|
Nothing -> return []
|
2013-07-28 19:27:36 +00:00
|
|
|
geturls Nothing = return []
|
2014-10-09 18:53:13 +00:00
|
|
|
geturls (Just logsha) = getLog . L.unpack <$> catObject logsha
|
2013-08-22 22:25:21 +00:00
|
|
|
|
2014-12-08 23:14:24 +00:00
|
|
|
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) }
|
|
|
|
|
2017-11-28 21:17:40 +00:00
|
|
|
data Downloader = WebDownloader | YoutubeDownloader | QuviDownloader | OtherDownloader
|
2015-03-05 17:50:15 +00:00
|
|
|
deriving (Eq, Show)
|
2014-12-08 23:14:24 +00:00
|
|
|
|
|
|
|
{- To keep track of how an url is downloaded, it's mangled slightly in
|
2017-11-28 21:17:40 +00:00
|
|
|
- the log, with a prefix indicating when a Downloader is used. -}
|
2014-12-08 23:14:24 +00:00
|
|
|
setDownloader :: URLString -> Downloader -> String
|
|
|
|
setDownloader u WebDownloader = u
|
|
|
|
setDownloader u QuviDownloader = "quvi:" ++ u
|
2017-11-28 21:17:40 +00:00
|
|
|
setDownloader u YoutubeDownloader = "yt:" ++ u
|
2014-12-08 23:14:24 +00:00
|
|
|
setDownloader u OtherDownloader = ":" ++ u
|
2013-08-22 22:25:21 +00:00
|
|
|
|
2016-01-19 19:55:32 +00:00
|
|
|
setDownloader' :: URLString -> Remote -> String
|
|
|
|
setDownloader' u r
|
|
|
|
| Remote.uuid r == webUUID = setDownloader u WebDownloader
|
|
|
|
| otherwise = setDownloader u OtherDownloader
|
|
|
|
|
2013-08-22 22:25:21 +00:00
|
|
|
getDownloader :: URLString -> (URLString, Downloader)
|
|
|
|
getDownloader u = case separate (== ':') u of
|
2017-11-28 21:17:40 +00:00
|
|
|
("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)
|
2014-12-08 23:14:24 +00:00
|
|
|
("", u') -> (u', OtherDownloader)
|
|
|
|
_ -> (u, WebDownloader)
|