diff options
| -rw-r--r-- | Build/Configure.hs | 1 | ||||
| -rw-r--r-- | Utility/Quvi.hs | 70 | ||||
| -rw-r--r-- | Utility/Url.hs | 3 | ||||
| -rw-r--r-- | debian/changelog | 2 |
4 files changed, 65 insertions, 11 deletions
diff --git a/Build/Configure.hs b/Build/Configure.hs index aeff256b4..d17f6cbf0 100644 --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -35,6 +35,7 @@ tests = , TestCase "wget" $ testCmd "wget" "wget --version >/dev/null" , TestCase "bup" $ testCmd "bup" "bup --version >/dev/null" , TestCase "quvi" $ testCmd "quvi" "quvi --version >/dev/null" + , TestCase "newquvi" $ testCmd "newquvi" "quvi info >/dev/null" , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" , TestCase "ionice" $ testCmd "ionice" "ionice -c3 true >/dev/null" , TestCase "gpg" $ maybeSelectCmd "gpg" diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs index cce02d646..e8d0a0d11 100644 --- a/Utility/Quvi.hs +++ b/Utility/Quvi.hs @@ -11,9 +11,13 @@ module Utility.Quvi where import Common import Utility.Url +import Build.SysConfig (newquvi) import Data.Aeson import Data.ByteString.Lazy.UTF8 (fromString) +import qualified Data.Map as M +import Network.URI (uriAuthority, uriRegName) +import Data.Char data Page = Page { pageTitle :: String @@ -25,6 +29,7 @@ data Link = Link , linkUrl :: URLString } deriving (Show) +{- JSON instances for quvi 0.4. -} instance FromJSON Page where parseJSON (Object v) = Page <$> v .: "page_title" @@ -37,6 +42,18 @@ instance FromJSON Link where <*> v .: "url" parseJSON _ = mzero +{- "enum" format used by quvi 0.9 -} +parseEnum :: String -> Maybe Page +parseEnum s = Page + <$> get "QUVI_MEDIA_PROPERTY_TITLE" + <*> ((:[]) <$> link) + where + link = Link + <$> get "QUVI_MEDIA_STREAM_PROPERTY_CONTAINER" + <*> get "QUVI_MEDIA_STREAM_PROPERTY_URL" + get = flip M.lookup m + m = M.fromList $ map (separate (== '=')) $ lines s + type Query a = [CommandParam] -> URLString -> IO a {- Throws an error when quvi is not installed. -} @@ -54,8 +71,11 @@ query :: Query (Maybe Page) query ps url = flip catchNonAsync (const $ return Nothing) (query' ps url) query' :: Query (Maybe Page) -query' ps url = decode . fromString - <$> readProcess "quvi" (toCommand $ ps ++ [Param url]) +query' ps url + | newquvi = parseEnum + <$> readProcess "quvi" (toCommand $ [Param "dump", Param "-p", Param "enum"] ++ ps ++ [Param url]) + | otherwise = decode . fromString + <$> readProcess "quvi" (toCommand $ ps ++ [Param url]) queryLinks :: Query [URLString] queryLinks ps url = maybe [] (map linkUrl . pageLinks) <$> query ps url @@ -65,17 +85,47 @@ queryLinks ps url = maybe [] (map linkUrl . pageLinks) <$> query ps url check :: Query Bool check ps url = maybe False (not . null . pageLinks) <$> query ps url -{- Checks if an url is supported by quvi, without hitting it, or outputting +{- Checks if an url is supported by quvi, as quickly as possible + - (without hitting it if possible), and without outputting - anything. Also returns False if quvi is not installed. -} supported :: URLString -> IO Bool -supported url = boolSystem "quvi" [Params "--verbosity mute --support", Param url] - +supported url + {- Use quvi-info to see if the url's domain is supported. + - If so, have to do a online verification of the url. -} + | newquvi = (firstlevel <&&> secondlevel) + `catchNonAsync` (\_ -> return False) + | otherwise = boolSystem "quvi" [Params "--verbosity mute --support", Param url] + where + firstlevel = case uriAuthority =<< parseURIRelaxed url of + Nothing -> return False + Just auth -> do + let domain = map toLower $ uriRegName auth + let basedomain = intercalate "." $ reverse $ take 2 $ reverse $ split "." domain + any (\h -> domain `isSuffixOf` h || basedomain `isSuffixOf` h) + . map (map toLower) <$> listdomains + secondlevel = snd <$> processTranscript "quvi" + (toCommand [Param "dump", Param "-o", Param url]) Nothing + +listdomains :: IO [String] +listdomains + | newquvi = concatMap (split ",") + . concatMap (drop 1 . words) + . filter ("domains: " `isPrefixOf`) . lines + <$> readProcess "quvi" + (toCommand [Param "info", Param "-p", Param "domains"]) + | otherwise = return [] + +{- Disables progress, but not information output. -} quiet :: CommandParam -quiet = Params "--verbosity quiet" - -noredir :: CommandParam -noredir = Params "-e -resolve" +quiet + -- Cannot use quiet as it now disables informational output. + -- No way to disable progress. + | newquvi = Param "--verbosity verbose" + | otherwise = Params "--verbosity quiet" {- Only return http results, not streaming protocols. -} httponly :: CommandParam -httponly = Params "-c http" +httponly + -- No way to do it with 0.9? + | newquvi = Params "" + | otherwise = Params "-c http" diff --git a/Utility/Url.hs b/Utility/Url.hs index 97296c920..03c311fd2 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -14,7 +14,8 @@ module Utility.Url ( checkBoth, exists, download, - downloadQuiet + downloadQuiet, + parseURIRelaxed ) where import Common diff --git a/debian/changelog b/debian/changelog index 9f6f6992c..8b894f1fa 100644 --- a/debian/changelog +++ b/debian/changelog @@ -11,6 +11,8 @@ git-annex (5.20131121) UNRELEASED; urgency=low * annex.autoupgrade configures both the above upgrade behaviors. * Fix bug that broke switching between local repositories in the webapp when they use the new guarded direct mode. + * Added support for quvi 0.9. Slightly suboptimal due to limitations in its + interface compared with the old version. -- Joey Hess <joeyh@debian.org> Wed, 20 Nov 2013 18:30:47 -0400 |