diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Example Sandeep.C.R (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Example Author Name nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,19 @@ +### Hastily - A downloader of subtitles + +Finding the right subtitle for a movie file can be a frustrating experience if the movie file name does not have a unique release name, or there is no subtitle available that is specifically made +for the release/file you have in your possession. In such cases, you often have to resort to trial and error method. And there is no guarantee that among the 15 or 20 subtitles available, one them will +match the movie file you have. + +Hastily is a program to help you in such cases. The way it works is simple. + +1. You invoke Hastily passing a partial movie name as an argument. +2. Hastily will search the and provide you with a list of movie names that contains the search key that you passed. You can select the correct movie from that list. +3. Hastily will search and find all the available subtitles for that movie. +4. It will then extract and scan the subtitle files and find a dialogue that does not repeat in the same subtitle file and also appears in the most of the downloaded subtitles. +5. It will then print out the time when that particular dialogue appears in all of the downloaded subtitles. + +You have to find out when that particular dialogue appears in your movie file. Use this time and the list printed out by Hastily to find the best matching subtitle among those. + +Right now Hastily uses OMDB API to search for the movies and opensubtitles.org to search and download subtitles. And right now it will only process .srt files. + +Have fun! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.String +import Data.String.Conversions +import Data.Text (Text, intercalate) +import System.Console.GetOpt +import System.Directory +import System.Environment (getArgs) +import Text.Printf + +import qualified Text.Hastily.MovieInfoSources.Omdb.Omdb as Omdb +import qualified Text.Hastily.MovieSubtitleSources.OpenSubtitles.OpenSubtitles as OpenSubtitles +import qualified Text.Hastily.Report as Report +import qualified Text.Hastily.SubtitleFileTypes.Srt.Srt as Srt +import Text.Hastily.Types + +data Flag = MovieNameSlug String|Language String|DiscCount String|ReleaseNameSlug String| + SkipWord String|TargetDir String|SkipNetwork deriving (Show) + +main :: IO () +main = do + (movie_name, language, disc_count, release_name, skip_words, target, skip_network) <- parseOptions + (movie, movie_files) <- if not skip_network then do + either_err_movie_info <- Omdb.getMovieInfo movie_name + case either_err_movie_info of + Left err -> error $ show err + Right (Omdb.OMDBSearchResult movie_matches) -> do + right_movie <- getUserSelection movie_matches + try $ createDirectory (cs target):: IO (Either SomeException ()) + movie_files <- downloadSubtitleFromSources right_movie language disc_count release_name (cs target) [OpenSubtitles.getSubtitles] + return (right_movie, movie_files) + else do + movie_files <- Srt.getSrtFilesInDir $ cs target + return (MovieInfo "dummy" "" "" "", movie_files) + subtitles <- mapM (Srt.parseFile movie) movie_files + Report.generate skip_words subtitles + where + downloadSubtitleFromSources :: + MovieInfo -> Text -> Text -> Maybe Text -> FilePath -> + [(MovieInfo -> Text -> Text -> Maybe Text -> FilePath -> IO [FilePath])] -> IO [FilePath] + downloadSubtitleFromSources mi lang discs release target xs = do + either_list <- mapM applyArgs xs + gatherFiles either_list + where + applyArgs :: (MovieInfo -> Text -> Text -> Maybe Text -> FilePath -> IO [FilePath]) -> IO (Either SomeException [FilePath]) + applyArgs f = try $ f mi lang discs release target + gatherFiles :: [(Either SomeException [FilePath])] -> IO [FilePath] + gatherFiles either_files_list = do + path_lists <- mapM getFiles either_files_list + return $ concat path_lists + getFiles :: Either SomeException [FilePath] -> IO [FilePath] + getFiles (Right files) = return files + getFiles (Left exception) = do + putStrLn $ show $ exception + return [] + +options :: [OptDescr Flag] +options = [ + Option ['n'] ["name"] (ReqArg MovieNameSlug " moviename") "Full or partial movie name.", + Option ['l'] ["language"] (ReqArg Language " subtitlelanguage") "Required subtitle language", + Option ['d'] ["discs"] (ReqArg DiscCount " noofdiscs") "No of discs/files", + Option ['s'] ["skipword"] (ReqArg SkipWord " skipword") "Skip dialogues with these words when searching for candidate dialogue.", + Option ['t'] ["target-dir"] (ReqArg TargetDir " targetdirectory") "Target directory to store subtitles.", + Option ['r'] ["release-name"] (ReqArg ReleaseNameSlug " releasename") "A partial string of a release name to prefer eg BRRip, 720p", + Option ['i'] ["skip-network"] (NoArg SkipNetwork) "Do not fetch movie details or subtitles. Instead just print report using subtitles in the target directory." + ] + +parseOptions :: IO (Text, Text, Text, Maybe Text, [Text], Text, Bool) +parseOptions = do + argv <- getArgs + case getOpt Permute options argv of + ([], _, errors) -> printError errors options + (_, item, errors@(x:xs)) -> printError errors options + (options, [], []) -> do + return $ makeOptionsFrom options + _ -> error "Bad parameters!" + where + printError errors options = ioError $ userError $ concat errors ++ usageInfo "Usage:" options + makeOptionsFrom :: [Flag] -> (Text, Text, Text, Maybe Text, [Text], Text, Bool) + makeOptionsFrom options = (getMovieName options, getLanguage options, + getDiscs options, getReleaseName options, + getSkipWords options, getTargetDir options, getSkipNetwork options) + getMovieName [] = error "A partial movie name required!"::Text + getMovieName (o:os) = case o of MovieNameSlug m -> cs m; _ -> getMovieName os + getLanguage [] = "english"::Text + getLanguage (o:os) = case o of + Language m -> cs m + _ -> getLanguage os + getDiscs [] = "1"::Text + getDiscs (o:os) = case o of DiscCount m -> cs m; _ -> getDiscs os + getReleaseName [] = Nothing::Maybe Text + getReleaseName (o:os) = case o of ReleaseNameSlug m -> Just (cs m); _ -> getReleaseName os + getSkipWords [] = []::[Text] + getSkipWords (o:os) = case o of SkipWord x -> [cs x] ++ (getSkipWords os); _ -> getSkipWords os + getTargetDir [] = "subtitles"::Text + getTargetDir (o:os) = case o of TargetDir x -> (cs x); _ -> getTargetDir os + getSkipNetwork [] = False + getSkipNetwork (o:os) = case o of SkipNetwork -> True; _ -> getSkipNetwork os + +getUserSelection :: [MovieInfo] -> IO MovieInfo +getUserSelection movie_matches = do + showMatches movie_matches + getSelection movie_matches + +getSelection :: [MovieInfo] -> IO MovieInfo +getSelection movie_matches = do + selected_index <- getNumberBetween 1 movie_count + return $ movie_matches !! (selected_index - 1) + where + movie_count = length movie_matches + +showMatches :: [MovieInfo] -> IO () +showMatches ms = zipWithM_ printMovieInfo [(1::Integer)..] ms + where + printMovieInfo index movie_info = do + putStrLn $ printf "%d. %s" index $ show movie_info + +getNumberBetween :: Int -> Int -> IO Int +getNumberBetween start end = do + putStrLn $ printf "Enter a number between 1 and %d, or q to quit." end + input <- getLine + if input == "q" + then error "User abort!" + else case reads input :: [(Int, String)] of + [] -> getNumberBetween start end + [(index, "")] -> if index >= start && index <= end + then return index + else getNumberBetween start end + _ -> getNumberBetween start end diff --git a/hastily.cabal b/hastily.cabal new file mode 100644 --- /dev/null +++ b/hastily.cabal @@ -0,0 +1,68 @@ +name: hastily +version: 0.1.0.4 +synopsis: A program to download subtitle files. +description: Please see README.md +homepage: http://bitbucket.org/sras/hastily +license: BSD3 +license-file: LICENSE +author: Sandeep.C.r +maintainer: sandeepcr2@gmail.com +copyright: 2015 Sandeep.C.R +category: Cli +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Text.Hastily.MovieInfoSources.Omdb.Omdb, + Text.Hastily.MovieSubtitleSources.OpenSubtitles.OpenSubtitles, + Text.Hastily.Types, + Text.Hastily.Network, + Text.Hastily.Report, + Text.Hastily.SubtitleFileTypes.Srt.Srt, + Text.Hastily.Unpack.Zip.ZipExtractor, + Text.Hastily.MovieSubtitleSources.OpenSubtitles.Languages + other-modules: + build-depends: base >= 4.6 && < 5, + http-client, + http-types, + bytestring, + aeson, + string-conversions, + text, + filepath, + directory, + zip-archive, + directory-tree, + parsec, + concurrent-extra, + unbounded-delays, + containers, + exceptions, + hxt + default-language: Haskell2010 + +executable hastily + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base >= 4.6 && < 5 + , string-conversions + , directory + , text + , hastily + default-language: Haskell2010 + +test-suite hastily-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hastily + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: mercurial + location: https://bitbucket.org/sras/hastily diff --git a/src/Text/Hastily/MovieInfoSources/Omdb/Omdb.hs b/src/Text/Hastily/MovieInfoSources/Omdb/Omdb.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/MovieInfoSources/Omdb/Omdb.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.MovieInfoSources.Omdb.Omdb + ( + getMovieInfo, + OMDBSearchResult(OMDBSearchResult) + ) where + +import Data.Aeson +import Data.ByteString.Char8 hiding (putStrLn) +import qualified Data.ByteString.Lazy as LZ +import Data.String.Conversions +import Data.Text (Text) +import Network.HTTP.Client +import Control.Applicative +import Data.Functor + +import Text.Hastily.Network +import Text.Hastily.Types +import Control.Exception + +--sampleJSON = cs $ pack "{\"Search\":[{\"Title\":\"Ferris Bueller's Day Off\",\"Year\":\"1986\",\"imdbID\":\"tt0091042\",\"Type\":\"movie\"},{\"Title\":\"Ferris Bueller\",\"Year\":\"1990–1991\",\"imdbID\":\"tt0098795\",\"Type\":\"series\"},{\"Title\":\"The Night Ferris Bueller Died\",\"Year\":\"1999\",\"imdbID\":\"tt0240760\",\"Type\":\"movie\"},{\"Title\":\"Inside Story: Ferris Bueller's Day Off\",\"Year\":\"2011\",\"imdbID\":\"tt2150301\",\"Type\":\"movie\"},{\"Title\":\"The Ferris Wheel\",\"Year\":\"1896\",\"imdbID\":\"tt2207641\",\"Type\":\"movie\"},{\"Title\":\"Farewell, Ferris Wheel\",\"Year\":\"2012\",\"imdbID\":\"tt2349677\",\"Type\":\"movie\"},{\"Title\":\"Ferris Wheel at Night\",\"Year\":\"2013\",\"imdbID\":\"tt2496624\",\"Type\":\"movie\"},{\"Title\":\"Ferris Wheel on Fire\",\"Year\":\"2010\",\"imdbID\":\"tt2991876\",\"Type\":\"movie\"},{\"Title\":\"Brad Ferris' Game Plan\",\"Year\":\"2013–\",\"imdbID\":\"tt3464692\",\"Type\":\"series\"},{\"Title\":\"When the Ferris Wheel Stops\",\"Year\":\"2015\",\"imdbID\":\"tt4158616\",\"Type\":\"movie\"}]}" + +data OMDBSearchResult = OMDBSearchResult [MovieInfo] deriving (Show) + +instance FromJSON OMDBSearchResult where + parseJSON (Object v) = OMDBSearchResult <$> v .: "Search" + +getMovieInfo :: Text -> IO (Either SomeException OMDBSearchResult) +getMovieInfo slug = do + either_response_body <- getFrom "http://www.omdbapi.com" [("r", "json"), ("s", slug)] + case either_response_body of + Left err -> do + putStrLn "Querying OMDB for movie details failed!" + return $ Left err + Right response_body -> case eitherDecode response_body::Either String OMDBSearchResult of + Left err -> error err + Right result -> return $ Right result diff --git a/src/Text/Hastily/MovieSubtitleSources/OpenSubtitles/Languages.hs b/src/Text/Hastily/MovieSubtitleSources/OpenSubtitles/Languages.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/MovieSubtitleSources/OpenSubtitles/Languages.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.MovieSubtitleSources.OpenSubtitles.Languages + ( + languages + ) where + +import Data.Text + +languages = [("syriac", "syr"), ("serbian", "scc"), ("sinhalese", "sin"), ("breton", "bre"), ("polish", "pol"), ("latvian", "lav"), ("croatian", "hrv"), ("kazakh", "kaz"), ("galician", "glg"), ("chinese bilingual", "zhe"), ("bosnian", "bos"), ("german", "ger"), ("turkish", "tur"), ("vietnamese", "vie"), ("ukrainian", "ukr"), ("albanian", "alb"), ("dutch", "dut"), ("swedish", "swe"), ("swahili", "swa"), ("bulgarian", "bul"), ("japanese", "jpn"), ("hindi", "hin"), ("slovak", "slo"), ("french", "fre"), ("danish", "dan"), ("luxembourgish", "ltz"), ("icelandic", "ice"), ("georgian", "geo"), ("italian", "ita"), ("montenegrin", "mne"), ("tagalog", "tgl"), ("mongolian", "mon"), ("lithuanian", "lit"), ("persian", "per"), ("estonian", "est"), ("thai", "tha"), ("belarusian", "bel"), ("portuguese", "por"), ("indonesian", "ind"), ("catalan", "cat"), ("esperanto", "epo"), ("finnish", "fin"), ("malay", "may"), ("hungarian", "hun"), ("telugu", "tel"), ("chinese (simplified) ", "chi"), ("armenian", "arm"), ("burmese", "bur"), ("bengali", "ben"), ("afrikaans", " afr"), ("korean", "kor"), ("chinese (traditional)", "zht"), ("occitan", "oci"), ("manipuri", "mni"), ("malayalam", "mal"), ("greek", "ell"), ("sl ovenian", "slv"), ("romanian", "rum"), ("spanish", "spa"), ("urdu", "urd"), ("portuguese-br", "pob"), ("hebrew", "heb"), ("macedonian", "mac"), ("czech", "cze"), ("english", "eng"), ("tamil", "tam"), ("russian", "rus"), ("norwegian", "nor"), ("arabic", "ara"), ("khmer", "khm"), ("basque", "baq")]::[(Text, Text)] diff --git a/src/Text/Hastily/MovieSubtitleSources/OpenSubtitles/OpenSubtitles.hs b/src/Text/Hastily/MovieSubtitleSources/OpenSubtitles/OpenSubtitles.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/MovieSubtitleSources/OpenSubtitles/OpenSubtitles.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} + +module Text.Hastily.MovieSubtitleSources.OpenSubtitles.OpenSubtitles + ( + getSubtitles + ) where + +import Control.Exception +import Control.Monad +import qualified Data.ByteString as BS +import Data.ByteString.Char8 as C (split) +import Data.String.Conversions +import Data.Text hiding + (filter, + length, + zip, + zip3, + zipWith) +import Network.HTTP.Client +import System.Directory +import System.FilePath +import Text.Printf +import Text.XML.HXT.Core + +import qualified Text.Hastily.MovieSubtitleSources.OpenSubtitles.Languages as Ops +import Text.Hastily.Network +import Text.Hastily.SubtitleFileTypes.Srt.Srt +import Text.Hastily.Types +import Text.Hastily.Unpack.Zip.ZipExtractor + +zip4 a b c d = zipWith doZip (zip3 a b c) d + where + doZip (a, b, c) d = (a, b, c, d) + + +getLang :: Text -> Text +getLang lang = case lookup lang Ops.languages of + Just lan -> lan + _ -> error $ cs ( "List of available languages \n" ++ (cs $ intercalate "\n" $ fmap (cs.fst) Ops.languages) ++ "\n\ncannot find language '" ++ (cs lang::String) ++ "'.\n" ::String) + +getSubtitles :: MovieInfo -> Text -> Text -> Maybe Text -> FilePath -> IO [FilePath] +getSubtitles movie_info lang cd_count maybe_prefer_slug dst_folder = do + let language = getLang lang + links <- getSubtitleLinks movie_info language 0 [] + try $ createDirectory dstSubFolder :: IO (Either SomeException ()) + zipWithM_ (\a b -> extractFromEitherPath $ downloadLink dstSubFolder a b) (filter filterLink links) [1..] + getSrtFilesInDir dstSubFolder + where + filterLink :: (String, String, String, String) -> Bool + filterLink (link, sub_language, sub_release_name, sub_cd_count) = + case maybe_prefer_slug of + Nothing -> cd_count == (cs sub_cd_count) + Just slug -> let slug_lc = toLower $ slug + release_name_lc = toLower $ (cs sub_release_name::Text) + in cd_count == (cs sub_cd_count) && (isInfixOf slug_lc release_name_lc) + dstSubFolder = dst_folder "opensubtitles.org" + +extractFromEitherPath :: IO (Either SomeException FilePath) -> IO (Either SomeException ()) +extractFromEitherPath io_either_path = do + either_path <- io_either_path + case either_path of + Left err -> return $ Left err + Right file_path -> extractFiles file_path + +getSubtitleLinks + :: MovieInfo + -> Text + -> Integer + -> [(String, String, String, String)] + -> IO [(String, String, String, String)] +getSubtitleLinks movie_info language offset result = do + (total, item_count, links) <- getResults movie_info language offset + let new_result = result ++ links + let link_count = offset + item_count + if item_count > link_count + then getSubtitleLinks movie_info language (link_count) new_result + else return new_result + +getResults + :: MovieInfo + -> Text + -> Integer + -> IO (Integer, Integer, [(String, String, String, String)]) +getResults movie_info language offset = do + result_xml <- getResultXml movie_info language offset + tc <- itemCount result_xml + ic <- responseItemCount result_xml + sub_details <- runX $ result_xml >>> getSubtitleDetails + let cd_count = [] + let language = [] + let movie_release_names = [] + let subtitle_links = [] + return (tc, ic, sub_details) + where + getSubtitleDetails = deep (isElem >>>hasName "subtitle") >>> + proc x -> do + subtitle_link <- getAttrValue "LinkDownload" <<< deep (hasName "IDSubtitle") -< x + release_name <- getText <<< getChildren <<< deep (hasName "MovieReleaseName") -< x + cd_count <- getText <<< getChildren <<< deep (hasName "SubSumCD") -< x + language <- getText <<< getChildren <<< deep (hasName "LanguageName") -< x + returnA -< (subtitle_link, language, release_name, cd_count) + getResultXml movie_info language offset = do + response <- (getXmlResponse movie_info language offset) + return $ response >>> (deepest (hasName "search")) >>> getChildren >>> (hasName "results") + itemCount result_xml = do + item_count_result <- runX ( result_xml >>> getAttrValue "itemsfound") + if (length item_count_result) == 0 + then error "opensubtitles.org: No subtitles found!" + else return $ (read $ item_count_result!!0::Integer) + responseItemCount result_xml = do + item_count_result <- runX ( result_xml >>> getAttrValue "items") + if (length item_count_result) == 0 + then error "opensubtitles.org: No subtitles found!" + else return $ (read $ item_count_result!!0::Integer) + getXmlResponse movie_info language offset = do + either_error_response_text <- getFrom (makeUrl (imdb movie_info) language offset) [] + case either_error_response_text of + Left err -> error "Quering opensubtitles.org failed!" + Right response_text -> return $ readString [ withValidate no , withRemoveWS yes] $ cs response_text + where + makeUrl :: Text -> Text -> Integer -> String + makeUrl imdb language offset = printf "http://www.opensubtitles.org/en/search/sublanguageid-%s/imdbid-%s/offset-%s/xml" (cs language::String) (cs imdb::String) (show offset) + +downloadLink + :: Show a => + FilePath + -> (String, t, t1, t2) -> a -> IO (Either SomeException FilePath) +downloadLink dir (link, _, _, _) index = do + putStrLn $ printf "Downloading %s" link + request <- parseUrl link + full_path <- fullPath dir request + either_err <- getFromUrlAndDo link [] (saveResponse full_path (show index)) + case either_err of + Left err -> do + --putStrLn "Downloading failed: " ++ link + return $ Left err + Right a -> return $ Right a + where + saveResponse path index response = do + putStrLn $ printf "Saving to %s" path + response_content <- brConsume $ responseBody response + BS.writeFile path (BS.intercalate "" response_content) + return path + fullPath dir request = do + let f_name = fileName request + created <- try $ createDirectory (dir f_name) :: IO (Either SomeException ()) + case created of + Left err -> error $ "ERROR: Cannot create directory " ++ (dir f_name) + Right () -> return $ dir f_name f_name + where + fileName :: Request -> FilePath + fileName request = cs $ Prelude.last $ C.split '/' (path request) diff --git a/src/Text/Hastily/Network.hs b/src/Text/Hastily/Network.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/Network.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.Network ( + getFrom, + getFromUrlAndDo + ) where + +import Control.Concurrent.Thread.Delay (delay) +import Control.Exception +import Control.Monad.Catch hiding (try) +import Data.ByteString.Char8 hiding (putStrLn) +import qualified Data.ByteString.Lazy as LZ +import Data.String.Conversions +import Data.Text (Text) +import Network.HTTP.Client + +makeGetRequestObject :: Control.Monad.Catch.MonadThrow m => String -> [(Text, Text)] -> m Request +makeGetRequestObject url query_pairs = do + r <- parseUrl url + return $ setQueryString (makeBST query_pairs) r + where + makeBST :: [(Text, Text)] -> [(ByteString, Maybe ByteString)] + makeBST st = fmap makeBST' st + where + makeBST' :: (Text, Text) -> (ByteString, Maybe ByteString) + makeBST' (a1, a2) = (pack $ (cs a1::String), Just $ pack $ (cs a2::String)) + +getFrom :: String -> [(Text, Text)] -> IO (Either SomeException LZ.ByteString) +getFrom url query_pairs = + getFrom' url query_pairs 0 + where + getFrom' :: String -> [(Text, Text)] -> Integer -> IO (Either SomeException LZ.ByteString) + getFrom' url query_pairs attempt_count = do + manager <- newManager defaultManagerSettings + request <- makeGetRequestObject url query_pairs + either_response <- try $ httpLbs request manager :: IO (Either SomeException (Response LZ.ByteString)) + case either_response of + Left err -> do + showErr err + if attempt_count < 5 + then getFrom' url query_pairs (attempt_count + 1) + else return $ Left err + Right response -> return $ Right $ responseBody response + +getFromUrlAndDo :: String -> [(Text, Text)] -> (Response BodyReader -> IO b) -> IO (Either SomeException b) +getFromUrlAndDo url query_pairs func = getFromUrlAndDo' url query_pairs func 0 + where + getFromUrlAndDo' :: String -> [(Text, Text)] -> (Response BodyReader -> IO b) -> Integer -> IO (Either SomeException b) + getFromUrlAndDo' url query_pairs func attempt_count = do + manager <- newManager defaultManagerSettings + request <- makeGetRequestObject url query_pairs + either_result <- try $ withResponse request manager func + case either_result of + Left err -> do + showErr err + if attempt_count < 5 + then getFromUrlAndDo' url query_pairs func (attempt_count + 1) + else return $ Left err + Right result -> return $ Right result + +showErr :: SomeException -> IO () +showErr err = do + putStrLn $ show err + putStrLn "Retrying in 5 seconds.." + delay 5000000 diff --git a/src/Text/Hastily/Report.hs b/src/Text/Hastily/Report.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/Report.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.Report ( + generate, + findCandidateDialog + ) where + + +import Data.List (intersect) +import Data.List +import qualified Data.Map as Map +import Data.String.Conversions +import qualified Data.Text as DT +import System.Directory +import System.IO +import Text.Printf + +import Text.Hastily.Types + +generate :: [DT.Text] -> [Subtitle] -> IO () +generate skip_words subs = do + let dialog_frequency_pair = findCandidateDialog skip_words subs + printReport (filter isEmpty subs) $ fst dialog_frequency_pair + where + isEmpty :: Subtitle -> Bool + isEmpty s = (length $ subtitle_dialogs s) > 0 + +printReport :: [Subtitle] -> SubtitleDialog -> IO () +printReport subs candidate_dialog = if (length subs==0) + then putStrLn "No subtitles found!" + else do + putStrLn $ printf "Computing candidate dialog..." + maybe_handle <- let report_filename = "hastily-report.txt" in + doesFileExist report_filename >>= (\x -> if not x + then fmap Just $ openFile report_filename WriteMode + else do + putStrLn "WARNING: Existing report file found. Will not overwrite!" + return Nothing) + printHeaders candidate_dialog maybe_handle + mapM_ (findAndPrintReport candidate_dialog maybe_handle) subs + case maybe_handle of + Just handle -> hClose handle + _ -> return () + where + outPut maybe_handle str = do + putStrLn str + case maybe_handle of + Just handle -> hPutStrLn handle str + _ -> return () + printHeaders candidate_dialog maybe_handle = do + outPut maybe_handle $ printf "\nDialogue\n--------\n%s\n--------" (cs $ dialog candidate_dialog::String) + outPut maybe_handle $ printf "%-29s | %s" ("Time"::String) ("File"::String) + outPut maybe_handle $ printf "%-29s | %s" ("----"::String) ("----"::String) + findAndPrintReport :: SubtitleDialog -> Maybe Handle -> Subtitle -> IO () + findAndPrintReport c_dialog maybe_handle sub = do + outPut maybe_handle $ printf "%-29s | %s" (findTimeFor c_dialog (subtitle_dialogs sub)) (subtitle_file sub) + where + findTimeFor :: SubtitleDialog -> [SubtitleDialog] -> String + findTimeFor c_dialog [] = "Dialog not found!" + findTimeFor c_dialog (d:ds) = if d == c_dialog + then printf "%s --> %s" (cs $ start_time d::String) (cs $ end_time d::String) + else findTimeFor c_dialog ds + +-- Find a dialog whose time is used to compare +-- subtitles. The following process is used to find this dialog. +-- 1. For each subtitle file, prepare a list of dialogues that appear only once in the movie. +-- 2. Among those list, select dialogues that appear in the most of them. +-- 3. Among those list of dialogues, pick one that appears closest to the start. +findCandidateDialog :: [DT.Text] -> [Subtitle] -> (SubtitleDialog, Int) +findCandidateDialog skip_words subs = head $ sortBy compareFunction $ getCombinedHistogram non_repeating_dialog_sets + where + compareFunction (SubtitleDialog st1 _ _ _, a) (SubtitleDialog st2 _ _ _, b) = + -- Sort dialogs by decreasing order of their frequency. + -- if two dialogs appear in same number of files, then sort them + -- by the time they first appear, so that earlier ones are prefered. + let ordering = compare b a in + if ordering == EQ then compare st1 st2 else ordering + non_repeating_dialog_sets = fmap (getNonRepeatingDialogList skip_words) subs + +-- given a subtitle, return a list of subtitle dialogs that does not +-- appear more than once or contain the list of skip words +getNonRepeatingDialogList :: [DT.Text] -> Subtitle -> [SubtitleDialog] +getNonRepeatingDialogList skip_words (Subtitle _ _ dialogs) = fmap fst $ + filter (\(dialog, count) -> (count == 1) && (dialog `doesNotContain` skip_words) ) $ getHistogram dialogs + where + doesNotContain sub_dialog skip_words = all (\word -> not $ word `DT.isInfixOf` (digest sub_dialog)) $ fmap DT.toLower skip_words + +-- Make a list of tuples. Each tuple in this list will +-- hold a subtitle dialog and the number of times it appears in +-- all the avaliable subs +getCombinedHistogram :: [[SubtitleDialog]] -> [(SubtitleDialog, Int)] +getCombinedHistogram dlgxs = getHistogram $ flatenList dlgxs + where + flatenList dlgs = foldl (++) [] dlgxs + +getHistogram :: [SubtitleDialog] -> [(SubtitleDialog, Int)] +getHistogram subdx = Map.toList $ foldl addDialogToMap (makeMap subdx) subdx + where + addDialogToMap :: Map.Map SubtitleDialog Int -> SubtitleDialog -> Map.Map SubtitleDialog Int + addDialogToMap map dg = Map.update (\f -> Just (f+1)) dg map + makeMap :: [SubtitleDialog] -> Map.Map SubtitleDialog Int + makeMap subdx = Map.fromList $ zip (nub subdx) $ repeat 0 diff --git a/src/Text/Hastily/SubtitleFileTypes/Srt/Srt.hs b/src/Text/Hastily/SubtitleFileTypes/Srt/Srt.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/SubtitleFileTypes/Srt/Srt.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.SubtitleFileTypes.Srt.Srt + ( + getSrtFilesInDir, + parseFile, + srtParser + ) where + +import Control.Applicative ((<*)) +import qualified Data.ByteString as BS +import Data.Char +import Data.String.Conversions +import qualified Data.Text as DT +import Data.Text.Encoding +import Data.Text.Encoding.Error +import Text.Hastily.Types +import System.Directory.Tree +import System.FilePath +import System.IO +import Text.Parsec ((<|>)) +import qualified Text.Parsec as Parsec + +getSrtFilesInDir :: FilePath -> IO [FilePath] +getSrtFilesInDir destination = do + anchored_dir_tree <- build destination + -- Filter out everything that is not an .srt file + let file_dt = filter isfile $ flattenDir $ filterDir (\x -> case x of (File name a) -> (takeExtension name) == ".srt";Dir _ _ -> True;_->False) (dirTree anchored_dir_tree) + -- Extract FilePath objects out the the result tree + return $ fmap (\(File name file_path) -> file_path) file_dt + where + isfile x = case x of + File _ _ -> True + _ -> False + +parseFile :: MovieInfo -> FilePath -> IO Subtitle +parseFile movie_info file_path = do + putStrLn $ "Parsing subtitles from " ++ file_path + handle <- openBinaryFile file_path ReadMode + doParse handle + where + doParse handle = do + b_string <- BS.hGetContents handle + -- Drop bytes util the charecter '1' is found + -- This is a hack to account for the BOM marker in some + -- utf-8 encoded files + let string = DT.dropWhile (/= '1') $ decodeUtf8With ignore b_string + case Parsec.parse srtParser "(mainparser)" string of + Right subtitles -> case subtitles of + [] -> do + putStrLn $ "WARNING : No subtitles could be read from file " ++ file_path + return $ Subtitle movie_info file_path [] + all@(x:xs) -> do + putStrLn $ "Read " ++ (show $ length all) ++ " dialogues." + return $ Subtitle movie_info file_path subtitles + Left err -> do + print err + return $ Subtitle movie_info file_path [] + +srtParser :: Parsec.Parsec DT.Text () [SubtitleDialog] +srtParser = Parsec.many $ Parsec.try chunk_parser + where + makeDigest dialog = DT.filter isAlphaNum $ DT.toLower dialog + newLine = (Parsec.string "\n") <|> (Parsec.string "\r\n") + separator = Parsec.count 2 newLine + separatorOrEof = do + separator + chunk_parser = do + let time_parser = Parsec.many (Parsec.digit <|> (Parsec.char ':') <|> (Parsec.char ',')) + index <- (Parsec.many Parsec.digit) + newLine + start_time <- time_parser + Parsec.many1 $ Parsec.char ' ' + Parsec.string "-->" + Parsec.many1 $ Parsec.char ' ' + end_time <- time_parser + newLine + dialog <- Parsec.manyTill Parsec.anyChar (Parsec.try separatorOrEof) + return $ SubtitleDialog (cs start_time) (cs end_time) (cs dialog) (makeDigest $ cs dialog) diff --git a/src/Text/Hastily/Types.hs b/src/Text/Hastily/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.Types ( + MovieInfo(MovieInfo), + imdb, year, name, movieType, + SubtitleDialog(SubtitleDialog), + start_time, end_time, + digest, dialog, + Subtitle (Subtitle), + subtitle_movieinfo, subtitle_dialogs, subtitle_file + ) where + +import Data.Aeson +import Data.String.Conversions +import Data.Text +import System.FilePath +import Text.Printf +import Control.Applicative +import Data.Functor + +data MovieInfo = MovieInfo {imdb::Text, year::Text, name::Text, movieType::Text} + +data SubtitleDialog = SubtitleDialog {start_time::Text, end_time::Text, dialog::Text, digest::Text} deriving (Show) + +data Subtitle = Subtitle {subtitle_movieinfo::MovieInfo, subtitle_file::FilePath, subtitle_dialogs::[SubtitleDialog]} deriving (Show) + +instance Eq SubtitleDialog where + (==) a b = digest a == digest b + +instance Ord SubtitleDialog where + compare a b = compare (digest a) (digest b) + +instance Show MovieInfo where + show movie_info = printf "%s , Year: %s, Imdb: %s, Type: %s" movie_name movie_year movie_imdb movie_type + where + movie_name = (cs $ name movie_info)::String + movie_imdb = (cs $ imdb movie_info)::String + movie_year = (cs $ year movie_info)::String + movie_type = (cs $ movieType movie_info)::String + +instance FromJSON MovieInfo where + parseJSON (Object v) = MovieInfo <$> v .: "imdbID" <*> v .: "Year"<*> v .: "Title"<*> v .: "Type" diff --git a/src/Text/Hastily/Unpack/Zip/ZipExtractor.hs b/src/Text/Hastily/Unpack/Zip/ZipExtractor.hs new file mode 100644 --- /dev/null +++ b/src/Text/Hastily/Unpack/Zip/ZipExtractor.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Text.Hastily.Unpack.Zip.ZipExtractor + ( + extractFiles + ) where + +import Codec.Archive.Zip +import Control.Exception +import Control.Exception +import qualified Data.ByteString.Lazy as BS +import Data.String.Conversions +import Data.Text (toLower) +import System.Directory +import System.FilePath + +extractFiles :: FilePath -> IO (Either SomeException ()) +extractFiles file_path = do + let destination = (takeDirectory file_path) "files" in do + try $ createDirectory destination :: IO (Either SomeException ()) + zip_string <- BS.readFile file_path + try $ extractFilesFromArchive (options destination) (toArchive zip_string) :: IO (Either SomeException ()) + where + options destination = [OptDestination destination, OptVerbose] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"