Youtube support! (And 53 other video hosts)

When quvi is installed, git-annex addurl automatically uses it to detect
when an page is a video, and downloads the video file.

web special remote: Also support using quvi, for getting files,
or checking if files exist in the web.

This commit was sponsored by Mark Hepburn. Thanks!

2 files changed, 99 insertions, 0 deletions

diff --git a/Utility/Path.hs b/Utility/Path.hs
index 79e8e8089..b6214b247 100644
--- a/Utility/Path.hs
+++ b/Utility/Path.hs
@@ -14,6 +14,7 @@ import System.FilePath
 import System.Directory
 import Data.List
 import Data.Maybe
+import Data.Char
 import Control.Applicative
 
 #ifdef mingw32_HOST_OS
@@ -236,3 +237,18 @@ fileNameLengthLimit dir = do
 		else return $ minimum [l, 255]
   where
 #endif
+
+{- Given a string that we'd like to use as the basis for FilePath, but that
+ - was provided by a third party and is not to be trusted, returns the closest
+ - sane FilePath.
+ -
+ - All spaces and punctuation are replaced with '_', except for '.'
+ - "../" will thus turn into ".._", which is safe.
+ -}
+sanitizeFilePath :: String -> FilePath
+sanitizeFilePath = map sanitize
+  where
+  	sanitize c
+		| c == '.' = c
+		| isSpace c || isPunctuation c || c == '/' = '_'
+		| otherwise = c
diff --git a/Utility/Quvi.hs b/Utility/Quvi.hs
new file mode 100644
index 000000000..68cc4a3f6
--- /dev/null
+++ b/Utility/Quvi.hs
@@ -0,0 +1,83 @@
+{- querying quvi (import qualified)
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Utility.Quvi where
+
+import Common
+import Utility.Url
+
+import Data.Aeson
+import Data.ByteString.Lazy.UTF8 (fromString)
+
+data Page = Page
+	{ pageTitle :: String
+	, pageLinks :: [Link]
+	} deriving (Show)
+
+data Link = Link
+	{ linkSuffix :: String
+	, linkUrl :: URLString
+	} deriving (Show)
+
+instance FromJSON Page where
+	parseJSON (Object v) = Page
+		<$> v .: "page_title"
+		<*> v .: "link"
+	parseJSON _ = mzero
+
+instance FromJSON Link where
+	parseJSON (Object v) = Link
+		<$> v .: "file_suffix"
+		<*> v .: "url"
+	parseJSON _ = mzero
+
+type Query a = [CommandParam] -> URLString -> IO a
+
+{- Throws an error when quvi is not installed. -}
+forceQuery :: Query (Maybe Page)
+forceQuery ps url = flip catchNonAsync (const notinstalled) (query' ps url)
+  where
+  	notinstalled = error "quvi failed, or is not installed"
+
+{- Returns Nothing if the page is not a video page, or quvi is not
+ - installed. -}
+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])
+
+queryLinks :: Query [URLString]
+queryLinks ps url = maybe [] (map linkUrl . pageLinks) <$> query ps url
+
+{- Checks if quvi can still find a download link for an url.
+ - If quvi is not installed, returns False. -}
+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
+ - anything. Also returns False if quvi is not installed. -}
+supported :: URLString -> IO Bool
+supported url = boolSystem "quvi" [Params "-v mute --support", Param url]
+
+quiet :: CommandParam
+quiet = Params "-v quiet"
+
+noredir :: CommandParam
+noredir = Params "-e -resolve"
+
+{- Only return http results, not streaming protocols. -}
+httponly :: CommandParam
+httponly = Params "-c http"
+
+{- Avoids error messages being printed to stderr, instead they are
+ - put in the JSON. -}
+hideerrors :: CommandParam
+hideerrors = Params "-l +errors"